git.maemo.org Git - opencv/blob - 3rdparty/lapack/dtrtrs.c

   1 #include "clapack.h"
   2
   3 /* Table of constant values */
   4
   5 static doublereal c_b12 = 1.;
   6
   7 /* Subroutine */ int dtrtrs_(char *uplo, char *trans, char *diag, integer *n,
   8         integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *
   9         ldb, integer *info)
  10 {
  11     /* System generated locals */
  12     integer a_dim1, a_offset, b_dim1, b_offset, i__1;
  13
  14     /* Local variables */
  15     extern logical lsame_(char *, char *);
  16     extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
  17             integer *, integer *, doublereal *, doublereal *, integer *,
  18             doublereal *, integer *), xerbla_(
  19             char *, integer *);
  20     logical nounit;
  21
  22
  23 /*  -- LAPACK routine (version 3.1) -- */
  24 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
  25 /*     November 2006 */
  26
  27 /*     .. Scalar Arguments .. */
  28 /*     .. */
  29 /*     .. Array Arguments .. */
  30 /*     .. */
  31
  32 /*  Purpose */
  33 /*  ======= */
  34
  35 /*  DTRTRS solves a triangular system of the form */
  36
  37 /*     A * X = B  or  A**T * X = B, */
  38
  39 /*  where A is a triangular matrix of order N, and B is an N-by-NRHS */
  40 /*  matrix.  A check is made to verify that A is nonsingular. */
  41
  42 /*  Arguments */
  43 /*  ========= */
  44
  45 /*  UPLO    (input) CHARACTER*1 */
  46 /*          = 'U':  A is upper triangular; */
  47 /*          = 'L':  A is lower triangular. */
  48
  49 /*  TRANS   (input) CHARACTER*1 */
  50 /*          Specifies the form of the system of equations: */
  51 /*          = 'N':  A * X = B  (No transpose) */
  52 /*          = 'T':  A**T * X = B  (Transpose) */
  53 /*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose) */
  54
  55 /*  DIAG    (input) CHARACTER*1 */
  56 /*          = 'N':  A is non-unit triangular; */
  57 /*          = 'U':  A is unit triangular. */
  58
  59 /*  N       (input) INTEGER */
  60 /*          The order of the matrix A.  N >= 0. */
  61
  62 /*  NRHS    (input) INTEGER */
  63 /*          The number of right hand sides, i.e., the number of columns */
  64 /*          of the matrix B.  NRHS >= 0. */
  65
  66 /*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
  67 /*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N */
  68 /*          upper triangular part of the array A contains the upper */
  69 /*          triangular matrix, and the strictly lower triangular part of */
  70 /*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower */
  71 /*          triangular part of the array A contains the lower triangular */
  72 /*          matrix, and the strictly upper triangular part of A is not */
  73 /*          referenced.  If DIAG = 'U', the diagonal elements of A are */
  74 /*          also not referenced and are assumed to be 1. */
  75
  76 /*  LDA     (input) INTEGER */
  77 /*          The leading dimension of the array A.  LDA >= max(1,N). */
  78
  79 /*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
  80 /*          On entry, the right hand side matrix B. */
  81 /*          On exit, if INFO = 0, the solution matrix X. */
  82
  83 /*  LDB     (input) INTEGER */
  84 /*          The leading dimension of the array B.  LDB >= max(1,N). */
  85
  86 /*  INFO    (output) INTEGER */
  87 /*          = 0:  successful exit */
  88 /*          < 0: if INFO = -i, the i-th argument had an illegal value */
  89 /*          > 0: if INFO = i, the i-th diagonal element of A is zero, */
  90 /*               indicating that the matrix is singular and the solutions */
  91 /*               X have not been computed. */
  92
  93 /*  ===================================================================== */
  94
  95 /*     .. Parameters .. */
  96 /*     .. */
  97 /*     .. Local Scalars .. */
  98 /*     .. */
  99 /*     .. External Functions .. */
 100 /*     .. */
 101 /*     .. External Subroutines .. */
 102 /*     .. */
 103 /*     .. Intrinsic Functions .. */
 104 /*     .. */
 105 /*     .. Executable Statements .. */
 106
 107 /*     Test the input parameters. */
 108
 109     /* Parameter adjustments */
 110     a_dim1 = *lda;
 111     a_offset = 1 + a_dim1;
 112     a -= a_offset;
 113     b_dim1 = *ldb;
 114     b_offset = 1 + b_dim1;
 115     b -= b_offset;
 116
 117     /* Function Body */
 118     *info = 0;
 119     nounit = lsame_(diag, "N");
 120     if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
 121         *info = -1;
 122     } else if (! lsame_(trans, "N") && ! lsame_(trans,
 123             "T") && ! lsame_(trans, "C")) {
 124         *info = -2;
 125     } else if (! nounit && ! lsame_(diag, "U")) {
 126         *info = -3;
 127     } else if (*n < 0) {
 128         *info = -4;
 129     } else if (*nrhs < 0) {
 130         *info = -5;
 131     } else if (*lda < max(1,*n)) {
 132         *info = -7;
 133     } else if (*ldb < max(1,*n)) {
 134         *info = -9;
 135     }
 136     if (*info != 0) {
 137         i__1 = -(*info);
 138         xerbla_("DTRTRS", &i__1);
 139         return 0;
 140     }
 141
 142 /*     Quick return if possible */
 143
 144     if (*n == 0) {
 145         return 0;
 146     }
 147
 148 /*     Check for singularity. */
 149
 150     if (nounit) {
 151         i__1 = *n;
 152         for (*info = 1; *info <= i__1; ++(*info)) {
 153             if (a[*info + *info * a_dim1] == 0.) {
 154                 return 0;
 155             }
 156 /* L10: */
 157         }
 158     }
 159     *info = 0;
 160
 161 /*     Solve A * x = b  or  A' * x = b. */
 162
 163     dtrsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[
 164             b_offset], ldb);
 165
 166     return 0;
 167
 168 /*     End of DTRTRS */
 169
 170 } /* dtrtrs_ */