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);
}
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
**/
}
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
**/
}
