dorgbr.c
Go to the documentation of this file.
00001 /* dorgbr.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Table of constant values */
00017 
00018 static integer c__1 = 1;
00019 static integer c_n1 = -1;
00020 
00021 /* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k, 
00022         doublereal *a, integer *lda, doublereal *tau, doublereal *work, 
00023         integer *lwork, integer *info)
00024 {
00025     /* System generated locals */
00026     integer a_dim1, a_offset, i__1, i__2, i__3;
00027 
00028     /* Local variables */
00029     integer i__, j, nb, mn;
00030     extern logical lsame_(char *, char *);
00031     integer iinfo;
00032     logical wantq;
00033     extern /* Subroutine */ int xerbla_(char *, integer *);
00034     extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
00035             integer *, integer *);
00036     extern /* Subroutine */ int dorglq_(integer *, integer *, integer *, 
00037             doublereal *, integer *, doublereal *, doublereal *, integer *, 
00038             integer *), dorgqr_(integer *, integer *, integer *, doublereal *, 
00039              integer *, doublereal *, doublereal *, integer *, integer *);
00040     integer lwkopt;
00041     logical lquery;
00042 
00043 
00044 /*  -- LAPACK routine (version 3.2) -- */
00045 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00046 /*     November 2006 */
00047 
00048 /*     .. Scalar Arguments .. */
00049 /*     .. */
00050 /*     .. Array Arguments .. */
00051 /*     .. */
00052 
00053 /*  Purpose */
00054 /*  ======= */
00055 
00056 /*  DORGBR generates one of the real orthogonal matrices Q or P**T */
00057 /*  determined by DGEBRD when reducing a real matrix A to bidiagonal */
00058 /*  form: A = Q * B * P**T.  Q and P**T are defined as products of */
00059 /*  elementary reflectors H(i) or G(i) respectively. */
00060 
00061 /*  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q */
00062 /*  is of order M: */
00063 /*  if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n */
00064 /*  columns of Q, where m >= n >= k; */
00065 /*  if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an */
00066 /*  M-by-M matrix. */
00067 
00068 /*  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T */
00069 /*  is of order N: */
00070 /*  if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m */
00071 /*  rows of P**T, where n >= m >= k; */
00072 /*  if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as */
00073 /*  an N-by-N matrix. */
00074 
00075 /*  Arguments */
00076 /*  ========= */
00077 
00078 /*  VECT    (input) CHARACTER*1 */
00079 /*          Specifies whether the matrix Q or the matrix P**T is */
00080 /*          required, as defined in the transformation applied by DGEBRD: */
00081 /*          = 'Q':  generate Q; */
00082 /*          = 'P':  generate P**T. */
00083 
00084 /*  M       (input) INTEGER */
00085 /*          The number of rows of the matrix Q or P**T to be returned. */
00086 /*          M >= 0. */
00087 
00088 /*  N       (input) INTEGER */
00089 /*          The number of columns of the matrix Q or P**T to be returned. */
00090 /*          N >= 0. */
00091 /*          If VECT = 'Q', M >= N >= min(M,K); */
00092 /*          if VECT = 'P', N >= M >= min(N,K). */
00093 
00094 /*  K       (input) INTEGER */
00095 /*          If VECT = 'Q', the number of columns in the original M-by-K */
00096 /*          matrix reduced by DGEBRD. */
00097 /*          If VECT = 'P', the number of rows in the original K-by-N */
00098 /*          matrix reduced by DGEBRD. */
00099 /*          K >= 0. */
00100 
00101 /*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
00102 /*          On entry, the vectors which define the elementary reflectors, */
00103 /*          as returned by DGEBRD. */
00104 /*          On exit, the M-by-N matrix Q or P**T. */
00105 
00106 /*  LDA     (input) INTEGER */
00107 /*          The leading dimension of the array A. LDA >= max(1,M). */
00108 
00109 /*  TAU     (input) DOUBLE PRECISION array, dimension */
00110 /*                                (min(M,K)) if VECT = 'Q' */
00111 /*                                (min(N,K)) if VECT = 'P' */
00112 /*          TAU(i) must contain the scalar factor of the elementary */
00113 /*          reflector H(i) or G(i), which determines Q or P**T, as */
00114 /*          returned by DGEBRD in its array argument TAUQ or TAUP. */
00115 
00116 /*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
00117 /*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
00118 
00119 /*  LWORK   (input) INTEGER */
00120 /*          The dimension of the array WORK. LWORK >= max(1,min(M,N)). */
00121 /*          For optimum performance LWORK >= min(M,N)*NB, where NB */
00122 /*          is the optimal blocksize. */
00123 
00124 /*          If LWORK = -1, then a workspace query is assumed; the routine */
00125 /*          only calculates the optimal size of the WORK array, returns */
00126 /*          this value as the first entry of the WORK array, and no error */
00127 /*          message related to LWORK is issued by XERBLA. */
00128 
00129 /*  INFO    (output) INTEGER */
00130 /*          = 0:  successful exit */
00131 /*          < 0:  if INFO = -i, the i-th argument had an illegal value */
00132 
00133 /*  ===================================================================== */
00134 
00135 /*     .. Parameters .. */
00136 /*     .. */
00137 /*     .. Local Scalars .. */
00138 /*     .. */
00139 /*     .. External Functions .. */
00140 /*     .. */
00141 /*     .. External Subroutines .. */
00142 /*     .. */
00143 /*     .. Intrinsic Functions .. */
00144 /*     .. */
00145 /*     .. Executable Statements .. */
00146 
00147 /*     Test the input arguments */
00148 
00149     /* Parameter adjustments */
00150     a_dim1 = *lda;
00151     a_offset = 1 + a_dim1;
00152     a -= a_offset;
00153     --tau;
00154     --work;
00155 
00156     /* Function Body */
00157     *info = 0;
00158     wantq = lsame_(vect, "Q");
00159     mn = min(*m,*n);
00160     lquery = *lwork == -1;
00161     if (! wantq && ! lsame_(vect, "P")) {
00162         *info = -1;
00163     } else if (*m < 0) {
00164         *info = -2;
00165     } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && (
00166             *m > *n || *m < min(*n,*k))) {
00167         *info = -3;
00168     } else if (*k < 0) {
00169         *info = -4;
00170     } else if (*lda < max(1,*m)) {
00171         *info = -6;
00172     } else if (*lwork < max(1,mn) && ! lquery) {
00173         *info = -9;
00174     }
00175 
00176     if (*info == 0) {
00177         if (wantq) {
00178             nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1);
00179         } else {
00180             nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1);
00181         }
00182         lwkopt = max(1,mn) * nb;
00183         work[1] = (doublereal) lwkopt;
00184     }
00185 
00186     if (*info != 0) {
00187         i__1 = -(*info);
00188         xerbla_("DORGBR", &i__1);
00189         return 0;
00190     } else if (lquery) {
00191         return 0;
00192     }
00193 
00194 /*     Quick return if possible */
00195 
00196     if (*m == 0 || *n == 0) {
00197         work[1] = 1.;
00198         return 0;
00199     }
00200 
00201     if (wantq) {
00202 
00203 /*        Form Q, determined by a call to DGEBRD to reduce an m-by-k */
00204 /*        matrix */
00205 
00206         if (*m >= *k) {
00207 
00208 /*           If m >= k, assume m >= n >= k */
00209 
00210             dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
00211                     iinfo);
00212 
00213         } else {
00214 
00215 /*           If m < k, assume m = n */
00216 
00217 /*           Shift the vectors which define the elementary reflectors one */
00218 /*           column to the right, and set the first row and column of Q */
00219 /*           to those of the unit matrix */
00220 
00221             for (j = *m; j >= 2; --j) {
00222                 a[j * a_dim1 + 1] = 0.;
00223                 i__1 = *m;
00224                 for (i__ = j + 1; i__ <= i__1; ++i__) {
00225                     a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
00226 /* L10: */
00227                 }
00228 /* L20: */
00229             }
00230             a[a_dim1 + 1] = 1.;
00231             i__1 = *m;
00232             for (i__ = 2; i__ <= i__1; ++i__) {
00233                 a[i__ + a_dim1] = 0.;
00234 /* L30: */
00235             }
00236             if (*m > 1) {
00237 
00238 /*              Form Q(2:m,2:m) */
00239 
00240                 i__1 = *m - 1;
00241                 i__2 = *m - 1;
00242                 i__3 = *m - 1;
00243                 dorgqr_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
00244                         1], &work[1], lwork, &iinfo);
00245             }
00246         }
00247     } else {
00248 
00249 /*        Form P', determined by a call to DGEBRD to reduce a k-by-n */
00250 /*        matrix */
00251 
00252         if (*k < *n) {
00253 
00254 /*           If k < n, assume k <= m <= n */
00255 
00256             dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, &
00257                     iinfo);
00258 
00259         } else {
00260 
00261 /*           If k >= n, assume m = n */
00262 
00263 /*           Shift the vectors which define the elementary reflectors one */
00264 /*           row downward, and set the first row and column of P' to */
00265 /*           those of the unit matrix */
00266 
00267             a[a_dim1 + 1] = 1.;
00268             i__1 = *n;
00269             for (i__ = 2; i__ <= i__1; ++i__) {
00270                 a[i__ + a_dim1] = 0.;
00271 /* L40: */
00272             }
00273             i__1 = *n;
00274             for (j = 2; j <= i__1; ++j) {
00275                 for (i__ = j - 1; i__ >= 2; --i__) {
00276                     a[i__ + j * a_dim1] = a[i__ - 1 + j * a_dim1];
00277 /* L50: */
00278                 }
00279                 a[j * a_dim1 + 1] = 0.;
00280 /* L60: */
00281             }
00282             if (*n > 1) {
00283 
00284 /*              Form P'(2:n,2:n) */
00285 
00286                 i__1 = *n - 1;
00287                 i__2 = *n - 1;
00288                 i__3 = *n - 1;
00289                 dorglq_(&i__1, &i__2, &i__3, &a[(a_dim1 << 1) + 2], lda, &tau[
00290                         1], &work[1], lwork, &iinfo);
00291             }
00292         }
00293     }
00294     work[1] = (doublereal) lwkopt;
00295     return 0;
00296 
00297 /*     End of DORGBR */
00298 
00299 } /* dorgbr_ */


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:47