コード例 #1
0
ファイル: lcp_matrix.c プロジェクト: ssketch/motorControl
void LU_Refactorize(PT_Basis pB)
{
	char L = 'L'; /* lower triangular */
	char D = 'U'; /* unit triangular matrix (diagonals are ones) */
	ptrdiff_t info, incx=1, incp;
	
	/* Matrix_Print_row(pB->pLX); */
	/* Matrix_Print_utril_row(pB->pUX); */

	/* factorize using lapack */
	dgetrf(&(Matrix_Rows(pB->pF)), &(Matrix_Rows(pB->pF)),
	       pMAT(pB->pF), &((pB->pF)->rows_alloc), pB->p, &info);

	/* store upper triangular matrix (including the diagonal to Ut), i.e. copy Ut <- F */
	/* lapack ignores remaining elements below diagonal when computing triangular solutions */
	Matrix_Copy(pB->pF, pB->pUt, pB->w);

	/* transform upper part of F (i.e. Ut) to triangular row major matrix UX*/
	/* UX <- F */
	Matrix_Full2RowTriangular(pB->pF, pB->pUX, pB->r);

	/* invert lower triangular part  */
	dtrtri( &L, &D, &(Matrix_Rows(pB->pF)), pMAT(pB->pF),
		&((pB->pF)->rows_alloc), &info);
			
	/* set strictly upper triangular parts to zeros because L is a full matrix
	 * and we need zeros to compute proper permutation inv(L)*P */
	Matrix_Uzeros(pB->pF);

	/* transpose matrix because dlaswp operates rowwise  and we need columnwise */
	/* LX <- F' */
	Matrix_Transpose(pB->pF, pB->pLX, pB->r);

	/* interchange columns according to pivots in pB->p and write to LX*/
	incp = -1; /* go backwards */
	dlaswp( &(Matrix_Rows(pB->pLX)), pMAT(pB->pLX), &((pB->pLX)->rows_alloc),
		&incx, &(Matrix_Rows(pB->pLX)) , pB->p, &incp);

	/* Matrix_Print_col(pB->pX); */
	/* Matrix_Print_row(pB->pLX); */
	/* Matrix_Print_col(pB->pUt); */
	/* Matrix_Print_utril_row(pB->pUX); */

	/* matrix F after solution is factored in [L\U], we want the original format for the next call
	   to dgesv, thus create a copy F <- X */
	Matrix_Copy(pB->pX, pB->pF, pB->w);


}
コード例 #2
0
ファイル: dgesv.c プロジェクト: MattWherry/yorick
void dgetrf( long m, long n, double a[], long lda, long ipiv[], long *info )
{
  /**
   *  -- LAPACK routine (version 1.1) --
   *     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
   *     Courant Institute, Argonne National Lab, and Rice University
   *     March 31, 1993
   *
   *     .. Scalar Arguments ..*/
  /**     ..
   *     .. Array Arguments ..*/
#undef ipiv_1
#define ipiv_1(a1) ipiv[a1-1]
#undef a_2
#define a_2(a1,a2) a[a1-1+lda*(a2-1)]
  /**     ..
   *
   *  Purpose
   *  =======
   *
   *  DGETRF computes an LU factorization of a general M-by-N matrix A
   *  using partial pivoting with row interchanges.
   *
   *  The factorization has the form
   *     A = P * L * U
   *  where P is a permutation matrix, L is lower triangular with unit
   *  diagonal elements (lower trapezoidal if m > n), and U is upper
   *  triangular (upper trapezoidal if m < n).
   *
   *  This is the right-looking Level 3 BLAS version of the algorithm.
   *
   *  Arguments
   *  =========
   *
   *  M       (input) INTEGER
   *          The number of rows of the matrix A.  M >= 0.
   *
   *  N       (input) INTEGER
   *          The number of columns of the matrix A.  N >= 0.
   *
   *  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
   *          On entry, the M-by-N matrix to be factored.
   *          On exit, the factors L and U from the factorization
   *          A = P*L*U; the unit diagonal elements of L are not stored.
   *
   *  LDA     (input) INTEGER
   *          The leading dimension of the array A.  LDA >= max(1,M).
   *
   *  IPIV    (output) INTEGER array, dimension (min(M,N))
   *          The pivot indices; for 1 <= i <= min(M,N), row i of the
   *          matrix was interchanged with row IPIV(i).
   *
   *  INFO    (output) INTEGER
   *          = 0:  successful exit
   *          < 0:  if INFO = -i, the i-th argument had an illegal value
   *          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
   *                has been completed, but the factor U is exactly
   *                singular, and division by zero will occur if it is used
   *                to solve a system of equations.
   *
   *  =====================================================================
   *
   *     .. Parameters ..*/
#undef one
#define one 1.0e+0
  /**     ..
   *     .. Local Scalars ..*/
  long            i, iinfo, j, jb, nb;
  /**     ..
   *     .. Intrinsic Functions ..*/
  /*      intrinsic          max, min;*/
  /**     ..
   *     .. Executable Statements ..
   *
   *     Test the input parameters.
   **/
  /*-----implicit-declarations-----*/
  /*-----end-of-declarations-----*/
  *info = 0;
  if( m<0 ) {
    *info = -1;
  } else if( n<0 ) {
    *info = -2;
  } else if( lda<max( 1, m ) ) {
    *info = -4;
  }
  if( *info!=0 ) {
    xerbla( "dgetrf", -*info );
    return;
  }
  /**
   *     Quick return if possible
   **/
  if( m==0 || n==0 )
    return;
  /**
   *     Determine the block size for this environment.
   **/
  nb = ilaenv( 1, "dgetrf", " ", m, n, -1, -1 );
  if( nb<=1 || nb>=min( m, n ) ) {
    /**
     *        Use unblocked code.
     **/
    dgetf2( m, n, a, lda, ipiv, info );
  } else {
    /**
     *        Use blocked code.
     **/
    for (j=1 ; nb>0?j<=min( m, n ):j>=min( m, n ) ; j+=nb) {
      jb = min( min( m, n )-j+1, nb );
      /**
       *           Factor diagonal and subdiagonal blocks and test for exact
       *           singularity.
       **/
      dgetf2( m-j+1, jb, &a_2( j, j ), lda, &ipiv_1( j ), &iinfo );
      /**
       *           Adjust INFO and the pivot indices.
       **/
      if( *info==0 && iinfo>0 )
        *info = iinfo + j - 1;
      for (i=j ; i<=min( m, j+jb-1 ) ; i+=1) {
        ipiv_1( i ) = j - 1 + ipiv_1( i );
      }
      /**
       *           Apply interchanges to columns 1:J-1.
       **/
      dlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 );

      if( j+jb<=n ) {
        /**
         *              Apply interchanges to columns J+JB:N.
         **/
        dlaswp( n-j-jb+1, &a_2( 1, j+jb ), lda, j, j+jb-1,
               ipiv, 1 );
        /**
         *              Compute block row of U.
         **/
        cblas_dtrsm(CblasColMajor, CblasLeft, CblasLower, CblasNoTrans,
                    CblasUnit, jb, n-j-jb+1, one, &a_2( j, j ), lda,
                    &a_2( j, j+jb ), lda );
        if( j+jb<=m ) {
          /**
           *                 Update trailing submatrix.
           **/
          cblas_dgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, m-j-jb+1,
                      n-j-jb+1, jb, -one, &a_2( j+jb, j ), lda,
                      &a_2( j, j+jb ), lda, one, &a_2( j+jb, j+jb ), lda );
        }
      }
    }
  }
  return;
  /**
   *     End of DGETRF
   **/
}
コード例 #3
0
ファイル: dgesv.c プロジェクト: MattWherry/yorick
void dgetrs( char trans, long n, long nrhs, double a[], long lda,
            long ipiv[], double b[], long ldb, long *info )
{
  /**
   *  -- LAPACK routine (version 1.1) --
   *     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
   *     Courant Institute, Argonne National Lab, and Rice University
   *     March 31, 1993
   *
   *     .. Scalar Arguments ..*/
  /**     ..
   *     .. Array Arguments ..*/
#undef ipiv_1
#define ipiv_1(a1) ipiv[a1-1]
#undef b_2
#define b_2(a1,a2) b[a1-1+ldb*(a2-1)]
#undef a_2
#define a_2(a1,a2) a[a1-1+lda*(a2-1)]
  /**     ..
   *
   *  Purpose
   *  =======
   *
   *  DGETRS solves a system of linear equations
   *     A * X = B  or  A' * X = B
   *  with a general N-by-N matrix A using the LU factorization computed
   *  by DGETRF.
   *
   *  Arguments
   *  =========
   *
   *  TRANS   (input) CHARACTER*1
   *          Specifies the form of the system of equations:
   *          = 'N':  A * X = B  (No transpose)
   *          = 'T':  A'* X = B  (Transpose)
   *          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
   *
   *  N       (input) INTEGER
   *          The order of the matrix A.  N >= 0.
   *
   *  NRHS    (input) INTEGER
   *          The number of right hand sides, i.e., the number of columns
   *          of the matrix B.  NRHS >= 0.
   *
   *  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
   *          The factors L and U from the factorization A = P*L*U
   *          as computed by DGETRF.
   *
   *  LDA     (input) INTEGER
   *          The leading dimension of the array A.  LDA >= max(1,N).
   *
   *  IPIV    (input) INTEGER array, dimension (N)
   *          The pivot indices from DGETRF; for 1<=i<=N, row i of the
   *          matrix was interchanged with row IPIV(i).
   *
   *  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
   *          On entry, the right hand side matrix B.
   *          On exit, the solution matrix X.
   *
   *  LDB     (input) INTEGER
   *          The leading dimension of the array B.  LDB >= max(1,N).
   *
   *  INFO    (output) INTEGER
   *          = 0:  successful exit
   *          < 0:  if INFO = -i, the i-th argument had an illegal value
   *
   *  =====================================================================
   *
   *     .. Parameters ..*/
#undef one
#define one 1.0e+0
  /**     ..
   *     .. Local Scalars ..*/
  int            notran;
  /**     ..
   *     .. Intrinsic Functions ..*/
  /*      intrinsic          max;*/
  /**     ..
   *     .. Executable Statements ..
   *
   *     Test the input parameters.
   **/
  /*-----implicit-declarations-----*/
  /*-----end-of-declarations-----*/
  *info = 0;
  notran = lsame( trans, 'n' );
  if( !notran && !lsame( trans, 't' ) && !
     lsame( trans, 'c' ) ) {
    *info = -1;
  } else if( n<0 ) {
    *info = -2;
  } else if( nrhs<0 ) {
    *info = -3;
  } else if( lda<max( 1, n ) ) {
    *info = -5;
  } else if( ldb<max( 1, n ) ) {
    *info = -8;
  }
  if( *info!=0 ) {
    xerbla( "dgetrs", -*info );
    return;
  }
  /**
   *     Quick return if possible
   **/
  if( n==0 || nrhs==0 )
    return;

  if( notran ) {
    /**
     *        Solve A * X = B.
     *
     *        Apply row interchanges to the right hand sides.
     **/
    dlaswp( nrhs, b, ldb, 1, n, ipiv, 1 );
    /**
     *        Solve L*X = B, overwriting B with X.
     **/
    cblas_dtrsm(CblasColMajor, CblasLeft, CblasLower, CblasNoTrans,
                CblasUnit, n, nrhs, one, a, lda, b, ldb );
    /**
     *        Solve U*X = B, overwriting B with X.
     **/
    cblas_dtrsm(CblasColMajor, CblasLeft, CblasUpper, CblasNoTrans,
                CblasNonUnit, n, nrhs, one, a, lda, b, ldb );
  } else {
    /**
     *        Solve A' * X = B.
     *
     *        Solve U'*X = B, overwriting B with X.
     **/
    cblas_dtrsm(CblasColMajor, CblasLeft, CblasUpper, CblasTrans,
                CblasNonUnit, n, nrhs, one, a, lda, b, ldb );
    /**
     *        Solve L'*X = B, overwriting B with X.
     **/
    cblas_dtrsm(CblasColMajor, CblasLeft, CblasLower, CblasTrans,
                CblasUnit, n, nrhs, one, a, lda, b, ldb );
    /**
     *        Apply row interchanges to the solution vectors.
     **/
    dlaswp( nrhs, b, ldb, 1, n, ipiv, -1 );
  }

  return;
  /**
   *     End of DGETRS
   **/
}