Int KLU_rgrowth /* return TRUE if successful, FALSE otherwise */ ( Int *Ap, Int *Ai, double *Ax, KLU_symbolic *Symbolic, KLU_numeric *Numeric, KLU_common *Common ) { double temp, max_ai, max_ui, min_block_rgrowth ; Entry aik ; Int *Q, *Ui, *Uip, *Ulen, *Pinv ; Unit *LU ; Entry *Aentry, *Ux, *Ukk ; double *Rs ; Int i, newrow, oldrow, k1, k2, nk, j, oldcol, k, pend, len ; /* ---------------------------------------------------------------------- */ /* check inputs */ /* ---------------------------------------------------------------------- */ if (Common == NULL) { return (FALSE) ; } if (Symbolic == NULL || Ap == NULL || Ai == NULL || Ax == NULL) { Common->status = KLU_INVALID ; return (FALSE) ; } if (Numeric == NULL) { /* treat this as a singular matrix */ Common->rgrowth = 0 ; Common->status = KLU_SINGULAR ; return (TRUE) ; } Common->status = KLU_OK ; /* ---------------------------------------------------------------------- */ /* compute the reciprocal pivot growth */ /* ---------------------------------------------------------------------- */ Aentry = (Entry *) Ax ; Pinv = Numeric->Pinv ; Rs = Numeric->Rs ; Q = Symbolic->Q ; Common->rgrowth = 1 ; for (i = 0 ; i < Symbolic->nblocks ; i++) { k1 = Symbolic->R[i] ; k2 = Symbolic->R[i+1] ; nk = k2 - k1 ; if (nk == 1) { continue ; /* skip singleton blocks */ } LU = (Unit *) Numeric->LUbx[i] ; Uip = Numeric->Uip + k1 ; Ulen = Numeric->Ulen + k1 ; Ukk = ((Entry *) Numeric->Udiag) + k1 ; min_block_rgrowth = 1 ; for (j = 0 ; j < nk ; j++) { max_ai = 0 ; max_ui = 0 ; oldcol = Q[j + k1] ; pend = Ap [oldcol + 1] ; for (k = Ap [oldcol] ; k < pend ; k++) { oldrow = Ai [k] ; newrow = Pinv [oldrow] ; if (newrow < k1) { continue ; /* skip entry outside the block */ } ASSERT (newrow < k2) ; if (Rs != NULL) { /* aik = Aentry [k] / Rs [oldrow] */ SCALE_DIV_ASSIGN (aik, Aentry [k], Rs [newrow]) ; } else { aik = Aentry [k] ; } /* temp = ABS (aik) */ ABS (temp, aik) ; if (temp > max_ai) { max_ai = temp ; } } /* Ui is set but not used. This is OK, because otherwise the macro would have to be redesigned. */ GET_POINTER (LU, Uip, Ulen, Ui, Ux, j, len) ; for (k = 0 ; k < len ; k++) { /* temp = ABS (Ux [k]) */ ABS (temp, Ux [k]) ; if (temp > max_ui) { max_ui = temp ; } } /* consider the diagonal element */ ABS (temp, Ukk [j]) ; if (temp > max_ui) { max_ui = temp ; } /* if max_ui is 0, skip the column */ if (SCALAR_IS_ZERO (max_ui)) { continue ; } temp = max_ai / max_ui ; if (temp < min_block_rgrowth) { min_block_rgrowth = temp ; } } if (min_block_rgrowth < Common->rgrowth) { Common->rgrowth = min_block_rgrowth ; } } return (TRUE) ; }
Int KLU_solve ( /* inputs, not modified */ KLU_symbolic *Symbolic, KLU_numeric *Numeric, Int d, /* leading dimension of B */ Int nrhs, /* number of right-hand-sides */ /* right-hand-side on input, overwritten with solution to Ax=b on output */ double B [ ], /* size n*nrhs, in column-oriented form, with * leading dimension d. */ /* --------------- */ KLU_common *Common ) { Entry x [4], offik, s ; double rs, *Rs ; Entry *Offx, *X, *Bz, *Udiag ; Int *Q, *R, *Pnum, *Offp, *Offi, *Lip, *Uip, *Llen, *Ulen ; Unit **LUbx ; Int k1, k2, nk, k, block, pend, n, p, nblocks, chunk, nr, i ; /* ---------------------------------------------------------------------- */ /* check inputs */ /* ---------------------------------------------------------------------- */ if (Common == NULL) { return (FALSE) ; } if (Numeric == NULL || Symbolic == NULL || d < Symbolic->n || nrhs < 0 || B == NULL) { Common->status = KLU_INVALID ; return (FALSE) ; } Common->status = KLU_OK ; /* ---------------------------------------------------------------------- */ /* get the contents of the Symbolic object */ /* ---------------------------------------------------------------------- */ Bz = (Entry *) B ; n = Symbolic->n ; nblocks = Symbolic->nblocks ; Q = Symbolic->Q ; R = Symbolic->R ; /* ---------------------------------------------------------------------- */ /* get the contents of the Numeric object */ /* ---------------------------------------------------------------------- */ ASSERT (nblocks == Numeric->nblocks) ; Pnum = Numeric->Pnum ; Offp = Numeric->Offp ; Offi = Numeric->Offi ; Offx = (Entry *) Numeric->Offx ; Lip = Numeric->Lip ; Llen = Numeric->Llen ; Uip = Numeric->Uip ; Ulen = Numeric->Ulen ; LUbx = (Unit **) Numeric->LUbx ; Udiag = Numeric->Udiag ; Rs = Numeric->Rs ; X = (Entry *) Numeric->Xwork ; ASSERT (KLU_valid (n, Offp, Offi, Offx)) ; /* ---------------------------------------------------------------------- */ /* solve in chunks of 4 columns at a time */ /* ---------------------------------------------------------------------- */ for (chunk = 0 ; chunk < nrhs ; chunk += 4) { /* ------------------------------------------------------------------ */ /* get the size of the current chunk */ /* ------------------------------------------------------------------ */ nr = MIN (nrhs - chunk, 4) ; /* ------------------------------------------------------------------ */ /* scale and permute the right hand side, X = P*(R\B) */ /* ------------------------------------------------------------------ */ if (Rs == NULL) { /* no scaling */ switch (nr) { case 1: for (k = 0 ; k < n ; k++) { X [k] = Bz [Pnum [k]] ; } break ; case 2: for (k = 0 ; k < n ; k++) { i = Pnum [k] ; X [2*k ] = Bz [i ] ; X [2*k + 1] = Bz [i + d ] ; } break ; case 3: for (k = 0 ; k < n ; k++) { i = Pnum [k] ; X [3*k ] = Bz [i ] ; X [3*k + 1] = Bz [i + d ] ; X [3*k + 2] = Bz [i + d*2] ; } break ; case 4: for (k = 0 ; k < n ; k++) { i = Pnum [k] ; X [4*k ] = Bz [i ] ; X [4*k + 1] = Bz [i + d ] ; X [4*k + 2] = Bz [i + d*2] ; X [4*k + 3] = Bz [i + d*3] ; } break ; } } else { switch (nr) { case 1: for (k = 0 ; k < n ; k++) { SCALE_DIV_ASSIGN (X [k], Bz [Pnum [k]], Rs [k]) ; } break ; case 2: for (k = 0 ; k < n ; k++) { i = Pnum [k] ; rs = Rs [k] ; SCALE_DIV_ASSIGN (X [2*k], Bz [i], rs) ; SCALE_DIV_ASSIGN (X [2*k + 1], Bz [i + d], rs) ; } break ; case 3: for (k = 0 ; k < n ; k++) { i = Pnum [k] ; rs = Rs [k] ; SCALE_DIV_ASSIGN (X [3*k], Bz [i], rs) ; SCALE_DIV_ASSIGN (X [3*k + 1], Bz [i + d], rs) ; SCALE_DIV_ASSIGN (X [3*k + 2], Bz [i + d*2], rs) ; } break ; case 4: for (k = 0 ; k < n ; k++) { i = Pnum [k] ; rs = Rs [k] ; SCALE_DIV_ASSIGN (X [4*k], Bz [i], rs) ; SCALE_DIV_ASSIGN (X [4*k + 1], Bz [i + d], rs) ; SCALE_DIV_ASSIGN (X [4*k + 2], Bz [i + d*2], rs) ; SCALE_DIV_ASSIGN (X [4*k + 3], Bz [i + d*3], rs) ; } break ; } } /* ------------------------------------------------------------------ */ /* solve X = (L*U + Off)\X */ /* ------------------------------------------------------------------ */ for (block = nblocks-1 ; block >= 0 ; block--) { /* -------------------------------------------------------------- */ /* the block of size nk is from rows/columns k1 to k2-1 */ /* -------------------------------------------------------------- */ k1 = R [block] ; k2 = R [block+1] ; nk = k2 - k1 ; PRINTF (("solve %d, k1 %d k2-1 %d nk %d\n", block, k1,k2-1,nk)) ; /* solve the block system */ if (nk == 1) { s = Udiag [k1] ; switch (nr) { case 1: DIV (X [k1], X [k1], s) ; break ; case 2: DIV (X [2*k1], X [2*k1], s) ; DIV (X [2*k1 + 1], X [2*k1 + 1], s) ; break ; case 3: DIV (X [3*k1], X [3*k1], s) ; DIV (X [3*k1 + 1], X [3*k1 + 1], s) ; DIV (X [3*k1 + 2], X [3*k1 + 2], s) ; break ; case 4: DIV (X [4*k1], X [4*k1], s) ; DIV (X [4*k1 + 1], X [4*k1 + 1], s) ; DIV (X [4*k1 + 2], X [4*k1 + 2], s) ; DIV (X [4*k1 + 3], X [4*k1 + 3], s) ; break ; } } else { KLU_lsolve (nk, Lip + k1, Llen + k1, LUbx [block], nr, X + nr*k1) ; KLU_usolve (nk, Uip + k1, Ulen + k1, LUbx [block], Udiag + k1, nr, X + nr*k1) ; } /* -------------------------------------------------------------- */ /* block back-substitution for the off-diagonal-block entries */ /* -------------------------------------------------------------- */ if (block > 0) { switch (nr) { case 1: for (k = k1 ; k < k2 ; k++) { pend = Offp [k+1] ; x [0] = X [k] ; for (p = Offp [k] ; p < pend ; p++) { MULT_SUB (X [Offi [p]], Offx [p], x [0]) ; } } break ; case 2: for (k = k1 ; k < k2 ; k++) { pend = Offp [k+1] ; x [0] = X [2*k ] ; x [1] = X [2*k + 1] ; for (p = Offp [k] ; p < pend ; p++) { i = Offi [p] ; offik = Offx [p] ; MULT_SUB (X [2*i], offik, x [0]) ; MULT_SUB (X [2*i + 1], offik, x [1]) ; } } break ; case 3: for (k = k1 ; k < k2 ; k++) { pend = Offp [k+1] ; x [0] = X [3*k ] ; x [1] = X [3*k + 1] ; x [2] = X [3*k + 2] ; for (p = Offp [k] ; p < pend ; p++) { i = Offi [p] ; offik = Offx [p] ; MULT_SUB (X [3*i], offik, x [0]) ; MULT_SUB (X [3*i + 1], offik, x [1]) ; MULT_SUB (X [3*i + 2], offik, x [2]) ; } } break ; case 4: for (k = k1 ; k < k2 ; k++) { pend = Offp [k+1] ; x [0] = X [4*k ] ; x [1] = X [4*k + 1] ; x [2] = X [4*k + 2] ; x [3] = X [4*k + 3] ; for (p = Offp [k] ; p < pend ; p++) { i = Offi [p] ; offik = Offx [p] ; MULT_SUB (X [4*i], offik, x [0]) ; MULT_SUB (X [4*i + 1], offik, x [1]) ; MULT_SUB (X [4*i + 2], offik, x [2]) ; MULT_SUB (X [4*i + 3], offik, x [3]) ; } } break ; } } } /* ------------------------------------------------------------------ */ /* permute the result, Bz = Q*X */ /* ------------------------------------------------------------------ */ switch (nr) { case 1: for (k = 0 ; k < n ; k++) { Bz [Q [k]] = X [k] ; } break ; case 2: for (k = 0 ; k < n ; k++) { i = Q [k] ; Bz [i ] = X [2*k ] ; Bz [i + d ] = X [2*k + 1] ; } break ; case 3: for (k = 0 ; k < n ; k++) { i = Q [k] ; Bz [i ] = X [3*k ] ; Bz [i + d ] = X [3*k + 1] ; Bz [i + d*2] = X [3*k + 2] ; } break ; case 4: for (k = 0 ; k < n ; k++) { i = Q [k] ; Bz [i ] = X [4*k ] ; Bz [i + d ] = X [4*k + 1] ; Bz [i + d*2] = X [4*k + 2] ; Bz [i + d*3] = X [4*k + 3] ; } break ; } /* ------------------------------------------------------------------ */ /* go to the next chunk of B */ /* ------------------------------------------------------------------ */ Bz += d*4 ; } return (TRUE) ; }
Int KLU_condest /* return TRUE if successful, FALSE otherwise */ ( Int Ap [ ], double Ax [ ], KLU_symbolic *Symbolic, KLU_numeric *Numeric, KLU_common *Common ) { double xj, Xmax, csum, anorm, ainv_norm, est_old, est_new, abs_value ; Entry *Udiag, *Aentry, *X, *S ; Int i, j, jmax, jnew, pend, n ; #ifndef COMPLEX Int unchanged ; #endif /* ---------------------------------------------------------------------- */ /* check inputs */ /* ---------------------------------------------------------------------- */ if (Common == NULL) { return (FALSE) ; } if (Symbolic == NULL || Ap == NULL || Ax == NULL) { Common->status = KLU_INVALID ; return (FALSE) ; } abs_value = 0 ; if (Numeric == NULL) { /* treat this as a singular matrix */ Common->condest = 1 / abs_value ; Common->status = KLU_SINGULAR ; return (TRUE) ; } Common->status = KLU_OK ; /* ---------------------------------------------------------------------- */ /* get inputs */ /* ---------------------------------------------------------------------- */ n = Symbolic->n ; Udiag = Numeric->Udiag ; /* ---------------------------------------------------------------------- */ /* check if diagonal of U has a zero on it */ /* ---------------------------------------------------------------------- */ for (i = 0 ; i < n ; i++) { ABS (abs_value, Udiag [i]) ; if (SCALAR_IS_ZERO (abs_value)) { Common->condest = 1 / abs_value ; Common->status = KLU_SINGULAR ; return (TRUE) ; } } /* ---------------------------------------------------------------------- */ /* compute 1-norm (maximum column sum) of the matrix */ /* ---------------------------------------------------------------------- */ anorm = 0.0 ; Aentry = (Entry *) Ax ; for (i = 0 ; i < n ; i++) { pend = Ap [i + 1] ; csum = 0.0 ; for (j = Ap [i] ; j < pend ; j++) { ABS (abs_value, Aentry [j]) ; csum += abs_value ; } if (csum > anorm) { anorm = csum ; } } /* ---------------------------------------------------------------------- */ /* compute estimate of 1-norm of inv (A) */ /* ---------------------------------------------------------------------- */ /* get workspace (size 2*n Entry's) */ X = Numeric->Xwork ; /* size n space used in KLU_solve, tsolve */ X += n ; /* X is size n */ S = X + n ; /* S is size n */ for (i = 0 ; i < n ; i++) { CLEAR (S [i]) ; CLEAR (X [i]) ; REAL (X [i]) = 1.0 / ((double) n) ; } jmax = 0 ; ainv_norm = 0.0 ; for (i = 0 ; i < 5 ; i++) { if (i > 0) { /* X [jmax] is the largest entry in X */ for (j = 0 ; j < n ; j++) { /* X [j] = 0 ;*/ CLEAR (X [j]) ; } REAL (X [jmax]) = 1 ; } KLU_solve (Symbolic, Numeric, n, 1, (double *) X, Common) ; est_old = ainv_norm ; ainv_norm = 0.0 ; for (j = 0 ; j < n ; j++) { /* ainv_norm += ABS (X [j]) ;*/ ABS (abs_value, X [j]) ; ainv_norm += abs_value ; } #ifndef COMPLEX unchanged = TRUE ; for (j = 0 ; j < n ; j++) { double s = (X [j] >= 0) ? 1 : -1 ; if (s != (Int) REAL (S [j])) { S [j] = s ; unchanged = FALSE ; } } if (i > 0 && (ainv_norm <= est_old || unchanged)) { break ; } #else for (j = 0 ; j < n ; j++) { if (IS_NONZERO (X [j])) { ABS (abs_value, X [j]) ; SCALE_DIV_ASSIGN (S [j], X [j], abs_value) ; } else { CLEAR (S [j]) ; REAL (S [j]) = 1 ; } } if (i > 0 && ainv_norm <= est_old) { break ; } #endif for (j = 0 ; j < n ; j++) { X [j] = S [j] ; } #ifndef COMPLEX /* do a transpose solve */ KLU_tsolve (Symbolic, Numeric, n, 1, X, Common) ; #else /* do a conjugate transpose solve */ KLU_tsolve (Symbolic, Numeric, n, 1, (double *) X, 1, Common) ; #endif /* jnew = the position of the largest entry in X */ jnew = 0 ; Xmax = 0 ; for (j = 0 ; j < n ; j++) { /* xj = ABS (X [j]) ;*/ ABS (xj, X [j]) ; if (xj > Xmax) { Xmax = xj ; jnew = j ; } } if (i > 0 && jnew == jmax) { /* the position of the largest entry did not change * from the previous iteration */ break ; } jmax = jnew ; } /* ---------------------------------------------------------------------- */ /* compute another estimate of norm(inv(A),1), and take the largest one */ /* ---------------------------------------------------------------------- */ for (j = 0 ; j < n ; j++) { CLEAR (X [j]) ; if (j % 2) { REAL (X [j]) = 1 + ((double) j) / ((double) (n-1)) ; } else { REAL (X [j]) = -1 - ((double) j) / ((double) (n-1)) ; } } KLU_solve (Symbolic, Numeric, n, 1, (double *) X, Common) ; est_new = 0.0 ; for (j = 0 ; j < n ; j++) { /* est_new += ABS (X [j]) ;*/ ABS (abs_value, X [j]) ; est_new += abs_value ; } est_new = 2 * est_new / (3 * n) ; ainv_norm = MAX (est_new, ainv_norm) ; /* ---------------------------------------------------------------------- */ /* compute estimate of condition number */ /* ---------------------------------------------------------------------- */ Common->condest = ainv_norm * anorm ; return (TRUE) ; }
Int KLU_refactor /* returns TRUE if successful, FALSE otherwise */ ( /* inputs, not modified */ Int Ap [ ], /* size n+1, column pointers */ Int Ai [ ], /* size nz, row indices */ double Ax [ ], KLU_symbolic<Entry, Int> *Symbolic, /* input/output */ KLU_numeric<Entry, Int> *Numeric, KLU_common<Entry, Int> *Common ) { Entry ukk, ujk, s ; Entry *Offx, *Lx, *Ux, *X, *Az, *Udiag ; double *Rs ; Int *P, *Q, *R, *Pnum, *Offp, *Offi, *Ui, *Li, *Pinv, *Lip, *Uip, *Llen, *Ulen ; Unit **LUbx ; Unit *LU ; Int k1, k2, nk, k, block, oldcol, pend, oldrow, n, p, newrow, scale, nblocks, poff, i, j, up, ulen, llen, maxblock, nzoff ; /* ---------------------------------------------------------------------- */ /* check inputs */ /* ---------------------------------------------------------------------- */ if (Common == NULL) { return (FALSE) ; } Common->status = KLU_OK ; if (Numeric == NULL) { /* invalid Numeric object */ Common->status = KLU_INVALID ; return (FALSE) ; } Common->numerical_rank = EMPTY ; Common->singular_col = EMPTY ; Az = (Entry *) Ax ; /* ---------------------------------------------------------------------- */ /* get the contents of the Symbolic object */ /* ---------------------------------------------------------------------- */ n = Symbolic->n ; P = Symbolic->P ; Q = Symbolic->Q ; R = Symbolic->R ; nblocks = Symbolic->nblocks ; maxblock = Symbolic->maxblock ; /* ---------------------------------------------------------------------- */ /* get the contents of the Numeric object */ /* ---------------------------------------------------------------------- */ Pnum = Numeric->Pnum ; Offp = Numeric->Offp ; Offi = Numeric->Offi ; Offx = (Entry *) Numeric->Offx ; LUbx = (Unit **) Numeric->LUbx ; scale = Common->scale ; if (scale > 0) { /* factorization was not scaled, but refactorization is scaled */ if (Numeric->Rs == NULL) { Numeric->Rs = (double *)KLU_malloc (n, sizeof (double), Common) ; if (Common->status < KLU_OK) { Common->status = KLU_OUT_OF_MEMORY ; return (FALSE) ; } } } else { /* no scaling for refactorization; ensure Numeric->Rs is freed. This * does nothing if Numeric->Rs is already NULL. */ Numeric->Rs = (double *) KLU_free (Numeric->Rs, n, sizeof (double), Common) ; } Rs = Numeric->Rs ; Pinv = Numeric->Pinv ; X = (Entry *) Numeric->Xwork ; Common->nrealloc = 0 ; Udiag = (Entry *) Numeric->Udiag ; nzoff = Symbolic->nzoff ; /* ---------------------------------------------------------------------- */ /* check the input matrix compute the row scale factors, Rs */ /* ---------------------------------------------------------------------- */ /* do no scale, or check the input matrix, if scale < 0 */ if (scale >= 0) { /* check for out-of-range indices, but do not check for duplicates */ if (!KLU_scale (scale, n, Ap, Ai, Ax, Rs, NULL, Common)) { return (FALSE) ; } } /* ---------------------------------------------------------------------- */ /* clear workspace X */ /* ---------------------------------------------------------------------- */ for (k = 0 ; k < maxblock ; k++) { /* X [k] = 0 */ CLEAR (X [k]) ; } poff = 0 ; /* ---------------------------------------------------------------------- */ /* factor each block */ /* ---------------------------------------------------------------------- */ if (scale <= 0) { /* ------------------------------------------------------------------ */ /* no scaling */ /* ------------------------------------------------------------------ */ for (block = 0 ; block < nblocks ; block++) { /* -------------------------------------------------------------- */ /* the block is from rows/columns k1 to k2-1 */ /* -------------------------------------------------------------- */ k1 = R [block] ; k2 = R [block+1] ; nk = k2 - k1 ; if (nk == 1) { /* ---------------------------------------------------------- */ /* singleton case */ /* ---------------------------------------------------------- */ oldcol = Q [k1] ; pend = Ap [oldcol+1] ; CLEAR (s) ; for (p = Ap [oldcol] ; p < pend ; p++) { newrow = Pinv [Ai [p]] - k1 ; if (newrow < 0 && poff < nzoff) { /* entry in off-diagonal block */ Offx [poff] = Az [p] ; poff++ ; } else { /* singleton */ s = Az [p] ; } } Udiag [k1] = s ; } else { /* ---------------------------------------------------------- */ /* construct and factor the kth block */ /* ---------------------------------------------------------- */ Lip = Numeric->Lip + k1 ; Llen = Numeric->Llen + k1 ; Uip = Numeric->Uip + k1 ; Ulen = Numeric->Ulen + k1 ; LU = LUbx [block] ; for (k = 0 ; k < nk ; k++) { /* ------------------------------------------------------ */ /* scatter kth column of the block into workspace X */ /* ------------------------------------------------------ */ oldcol = Q [k+k1] ; pend = Ap [oldcol+1] ; for (p = Ap [oldcol] ; p < pend ; p++) { newrow = Pinv [Ai [p]] - k1 ; if (newrow < 0 && poff < nzoff) { /* entry in off-diagonal block */ Offx [poff] = Az [p] ; poff++ ; } else { /* (newrow,k) is an entry in the block */ X [newrow] = Az [p] ; } } /* ------------------------------------------------------ */ /* compute kth column of U, and update kth column of A */ /* ------------------------------------------------------ */ GET_POINTER (LU, Uip, Ulen, Ui, Ux, k, ulen) ; for (up = 0 ; up < ulen ; up++) { j = Ui [up] ; ujk = X [j] ; /* X [j] = 0 */ CLEAR (X [j]) ; Ux [up] = ujk ; GET_POINTER (LU, Lip, Llen, Li, Lx, j, llen) ; for (p = 0 ; p < llen ; p++) { /* X [Li [p]] -= Lx [p] * ujk */ MULT_SUB (X [Li [p]], Lx [p], ujk) ; } } /* get the diagonal entry of U */ ukk = X [k] ; /* X [k] = 0 */ CLEAR (X [k]) ; /* singular case */ if (IS_ZERO (ukk)) { /* matrix is numerically singular */ Common->status = KLU_SINGULAR ; if (Common->numerical_rank == EMPTY) { Common->numerical_rank = k+k1 ; Common->singular_col = Q [k+k1] ; } if (Common->halt_if_singular) { /* do not continue the factorization */ return (FALSE) ; } } Udiag [k+k1] = ukk ; /* gather and divide by pivot to get kth column of L */ GET_POINTER (LU, Lip, Llen, Li, Lx, k, llen) ; for (p = 0 ; p < llen ; p++) { i = Li [p] ; DIV (Lx [p], X [i], ukk) ; CLEAR (X [i]) ; } } } } } else { /* ------------------------------------------------------------------ */ /* scaling */ /* ------------------------------------------------------------------ */ for (block = 0 ; block < nblocks ; block++) { /* -------------------------------------------------------------- */ /* the block is from rows/columns k1 to k2-1 */ /* -------------------------------------------------------------- */ k1 = R [block] ; k2 = R [block+1] ; nk = k2 - k1 ; if (nk == 1) { /* ---------------------------------------------------------- */ /* singleton case */ /* ---------------------------------------------------------- */ oldcol = Q [k1] ; pend = Ap [oldcol+1] ; CLEAR (s) ; for (p = Ap [oldcol] ; p < pend ; p++) { oldrow = Ai [p] ; newrow = Pinv [oldrow] - k1 ; if (newrow < 0 && poff < nzoff) { /* entry in off-diagonal block */ /* Offx [poff] = Az [p] / Rs [oldrow] */ SCALE_DIV_ASSIGN (Offx [poff], Az [p], Rs [oldrow]) ; poff++ ; } else { /* singleton */ /* s = Az [p] / Rs [oldrow] */ SCALE_DIV_ASSIGN (s, Az [p], Rs [oldrow]) ; } } Udiag [k1] = s ; } else { /* ---------------------------------------------------------- */ /* construct and factor the kth block */ /* ---------------------------------------------------------- */ Lip = Numeric->Lip + k1 ; Llen = Numeric->Llen + k1 ; Uip = Numeric->Uip + k1 ; Ulen = Numeric->Ulen + k1 ; LU = LUbx [block] ; for (k = 0 ; k < nk ; k++) { /* ------------------------------------------------------ */ /* scatter kth column of the block into workspace X */ /* ------------------------------------------------------ */ oldcol = Q [k+k1] ; pend = Ap [oldcol+1] ; for (p = Ap [oldcol] ; p < pend ; p++) { oldrow = Ai [p] ; newrow = Pinv [oldrow] - k1 ; if (newrow < 0 && poff < nzoff) { /* entry in off-diagonal part */ /* Offx [poff] = Az [p] / Rs [oldrow] */ SCALE_DIV_ASSIGN (Offx [poff], Az [p], Rs [oldrow]); poff++ ; } else { /* (newrow,k) is an entry in the block */ /* X [newrow] = Az [p] / Rs [oldrow] */ SCALE_DIV_ASSIGN (X [newrow], Az [p], Rs [oldrow]) ; } } /* ------------------------------------------------------ */ /* compute kth column of U, and update kth column of A */ /* ------------------------------------------------------ */ GET_POINTER (LU, Uip, Ulen, Ui, Ux, k, ulen) ; for (up = 0 ; up < ulen ; up++) { j = Ui [up] ; ujk = X [j] ; /* X [j] = 0 */ CLEAR (X [j]) ; Ux [up] = ujk ; GET_POINTER (LU, Lip, Llen, Li, Lx, j, llen) ; for (p = 0 ; p < llen ; p++) { /* X [Li [p]] -= Lx [p] * ujk */ MULT_SUB (X [Li [p]], Lx [p], ujk) ; } } /* get the diagonal entry of U */ ukk = X [k] ; /* X [k] = 0 */ CLEAR (X [k]) ; /* singular case */ if (IS_ZERO (ukk)) { /* matrix is numerically singular */ Common->status = KLU_SINGULAR ; if (Common->numerical_rank == EMPTY) { Common->numerical_rank = k+k1 ; Common->singular_col = Q [k+k1] ; } if (Common->halt_if_singular) { /* do not continue the factorization */ return (FALSE) ; } } Udiag [k+k1] = ukk ; /* gather and divide by pivot to get kth column of L */ GET_POINTER (LU, Lip, Llen, Li, Lx, k, llen) ; for (p = 0 ; p < llen ; p++) { i = Li [p] ; DIV (Lx [p], X [i], ukk) ; CLEAR (X [i]) ; } } } } } /* ---------------------------------------------------------------------- */ /* permute scale factors Rs according to pivotal row order */ /* ---------------------------------------------------------------------- */ if (scale > 0) { for (k = 0 ; k < n ; k++) { /* TODO : Check. REAL(X[k]) Can be just X[k] */ /* REAL (X [k]) = Rs [Pnum [k]] ; */ X [k] = Rs [Pnum [k]] ; } for (k = 0 ; k < n ; k++) { Rs [k] = REAL (X [k]) ; } } #ifndef NDEBUGKLU2 ASSERT (Offp [n] == poff) ; ASSERT (Symbolic->nzoff == poff) ; PRINTF (("\n------------------- Off diagonal entries, new:\n")) ; ASSERT (KLU_valid (n, Offp, Offi, Offx)) ; if (Common->status == KLU_OK) { PRINTF (("\n ########### KLU_BTF_REFACTOR done, nblocks %d\n",nblocks)); for (block = 0 ; block < nblocks ; block++) { k1 = R [block] ; k2 = R [block+1] ; nk = k2 - k1 ; PRINTF (( "\n================KLU_refactor output: k1 %d k2 %d nk %d\n", k1, k2, nk)) ; if (nk == 1) { PRINTF (("singleton ")) ; PRINT_ENTRY (Udiag [k1]) ; } else { Lip = Numeric->Lip + k1 ; Llen = Numeric->Llen + k1 ; LU = (Unit *) Numeric->LUbx [block] ; PRINTF (("\n---- L block %d\n", block)) ; ASSERT (KLU_valid_LU (nk, TRUE, Lip, Llen, LU)) ; Uip = Numeric->Uip + k1 ; Ulen = Numeric->Ulen + k1 ; PRINTF (("\n---- U block %d\n", block)) ; ASSERT (KLU_valid_LU (nk, FALSE, Uip, Ulen, LU)) ; } } } #endif return (TRUE) ; }