sormtr.c
Go to the documentation of this file.
00001 /* sormtr.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 static integer c__2 = 2;
00021 
00022 /* Subroutine */ int sormtr_(char *side, char *uplo, char *trans, integer *m, 
00023         integer *n, real *a, integer *lda, real *tau, real *c__, integer *ldc, 
00024          real *work, integer *lwork, integer *info)
00025 {
00026     /* System generated locals */
00027     address a__1[2];
00028     integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3;
00029     char ch__1[2];
00030 
00031     /* Builtin functions */
00032     /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
00033 
00034     /* Local variables */
00035     integer i1, i2, nb, mi, ni, nq, nw;
00036     logical left;
00037     extern logical lsame_(char *, char *);
00038     integer iinfo;
00039     logical upper;
00040     extern /* Subroutine */ int xerbla_(char *, integer *);
00041     extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
00042             integer *, integer *);
00043     extern /* Subroutine */ int sormql_(char *, char *, integer *, integer *, 
00044             integer *, real *, integer *, real *, real *, integer *, real *, 
00045             integer *, integer *);
00046     integer lwkopt;
00047     logical lquery;
00048     extern /* Subroutine */ int sormqr_(char *, char *, integer *, integer *, 
00049             integer *, real *, integer *, real *, real *, integer *, real *, 
00050             integer *, integer *);
00051 
00052 
00053 /*  -- LAPACK routine (version 3.2) -- */
00054 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00055 /*     November 2006 */
00056 
00057 /*     .. Scalar Arguments .. */
00058 /*     .. */
00059 /*     .. Array Arguments .. */
00060 /*     .. */
00061 
00062 /*  Purpose */
00063 /*  ======= */
00064 
00065 /*  SORMTR overwrites the general real M-by-N matrix C with */
00066 
00067 /*                  SIDE = 'L'     SIDE = 'R' */
00068 /*  TRANS = 'N':      Q * C          C * Q */
00069 /*  TRANS = 'T':      Q**T * C       C * Q**T */
00070 
00071 /*  where Q is a real orthogonal matrix of order nq, with nq = m if */
00072 /*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */
00073 /*  nq-1 elementary reflectors, as returned by SSYTRD: */
00074 
00075 /*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */
00076 
00077 /*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */
00078 
00079 /*  Arguments */
00080 /*  ========= */
00081 
00082 /*  SIDE    (input) CHARACTER*1 */
00083 /*          = 'L': apply Q or Q**T from the Left; */
00084 /*          = 'R': apply Q or Q**T from the Right. */
00085 
00086 /*  UPLO    (input) CHARACTER*1 */
00087 /*          = 'U': Upper triangle of A contains elementary reflectors */
00088 /*                 from SSYTRD; */
00089 /*          = 'L': Lower triangle of A contains elementary reflectors */
00090 /*                 from SSYTRD. */
00091 
00092 /*  TRANS   (input) CHARACTER*1 */
00093 /*          = 'N':  No transpose, apply Q; */
00094 /*          = 'T':  Transpose, apply Q**T. */
00095 
00096 /*  M       (input) INTEGER */
00097 /*          The number of rows of the matrix C. M >= 0. */
00098 
00099 /*  N       (input) INTEGER */
00100 /*          The number of columns of the matrix C. N >= 0. */
00101 
00102 /*  A       (input) REAL array, dimension */
00103 /*                               (LDA,M) if SIDE = 'L' */
00104 /*                               (LDA,N) if SIDE = 'R' */
00105 /*          The vectors which define the elementary reflectors, as */
00106 /*          returned by SSYTRD. */
00107 
00108 /*  LDA     (input) INTEGER */
00109 /*          The leading dimension of the array A. */
00110 /*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. */
00111 
00112 /*  TAU     (input) REAL array, dimension */
00113 /*                               (M-1) if SIDE = 'L' */
00114 /*                               (N-1) if SIDE = 'R' */
00115 /*          TAU(i) must contain the scalar factor of the elementary */
00116 /*          reflector H(i), as returned by SSYTRD. */
00117 
00118 /*  C       (input/output) REAL array, dimension (LDC,N) */
00119 /*          On entry, the M-by-N matrix C. */
00120 /*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
00121 
00122 /*  LDC     (input) INTEGER */
00123 /*          The leading dimension of the array C. LDC >= max(1,M). */
00124 
00125 /*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
00126 /*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
00127 
00128 /*  LWORK   (input) INTEGER */
00129 /*          The dimension of the array WORK. */
00130 /*          If SIDE = 'L', LWORK >= max(1,N); */
00131 /*          if SIDE = 'R', LWORK >= max(1,M). */
00132 /*          For optimum performance LWORK >= N*NB if SIDE = 'L', and */
00133 /*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
00134 /*          blocksize. */
00135 
00136 /*          If LWORK = -1, then a workspace query is assumed; the routine */
00137 /*          only calculates the optimal size of the WORK array, returns */
00138 /*          this value as the first entry of the WORK array, and no error */
00139 /*          message related to LWORK is issued by XERBLA. */
00140 
00141 /*  INFO    (output) INTEGER */
00142 /*          = 0:  successful exit */
00143 /*          < 0:  if INFO = -i, the i-th argument had an illegal value */
00144 
00145 /*  ===================================================================== */
00146 
00147 /*     .. Local Scalars .. */
00148 /*     .. */
00149 /*     .. External Functions .. */
00150 /*     .. */
00151 /*     .. External Subroutines .. */
00152 /*     .. */
00153 /*     .. Intrinsic Functions .. */
00154 /*     .. */
00155 /*     .. Executable Statements .. */
00156 
00157 /*     Test the input arguments */
00158 
00159     /* Parameter adjustments */
00160     a_dim1 = *lda;
00161     a_offset = 1 + a_dim1;
00162     a -= a_offset;
00163     --tau;
00164     c_dim1 = *ldc;
00165     c_offset = 1 + c_dim1;
00166     c__ -= c_offset;
00167     --work;
00168 
00169     /* Function Body */
00170     *info = 0;
00171     left = lsame_(side, "L");
00172     upper = lsame_(uplo, "U");
00173     lquery = *lwork == -1;
00174 
00175 /*     NQ is the order of Q and NW is the minimum dimension of WORK */
00176 
00177     if (left) {
00178         nq = *m;
00179         nw = *n;
00180     } else {
00181         nq = *n;
00182         nw = *m;
00183     }
00184     if (! left && ! lsame_(side, "R")) {
00185         *info = -1;
00186     } else if (! upper && ! lsame_(uplo, "L")) {
00187         *info = -2;
00188     } else if (! lsame_(trans, "N") && ! lsame_(trans, 
00189             "T")) {
00190         *info = -3;
00191     } else if (*m < 0) {
00192         *info = -4;
00193     } else if (*n < 0) {
00194         *info = -5;
00195     } else if (*lda < max(1,nq)) {
00196         *info = -7;
00197     } else if (*ldc < max(1,*m)) {
00198         *info = -10;
00199     } else if (*lwork < max(1,nw) && ! lquery) {
00200         *info = -12;
00201     }
00202 
00203     if (*info == 0) {
00204         if (upper) {
00205             if (left) {
00206 /* Writing concatenation */
00207                 i__1[0] = 1, a__1[0] = side;
00208                 i__1[1] = 1, a__1[1] = trans;
00209                 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
00210                 i__2 = *m - 1;
00211                 i__3 = *m - 1;
00212                 nb = ilaenv_(&c__1, "SORMQL", ch__1, &i__2, n, &i__3, &c_n1);
00213             } else {
00214 /* Writing concatenation */
00215                 i__1[0] = 1, a__1[0] = side;
00216                 i__1[1] = 1, a__1[1] = trans;
00217                 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
00218                 i__2 = *n - 1;
00219                 i__3 = *n - 1;
00220                 nb = ilaenv_(&c__1, "SORMQL", ch__1, m, &i__2, &i__3, &c_n1);
00221             }
00222         } else {
00223             if (left) {
00224 /* Writing concatenation */
00225                 i__1[0] = 1, a__1[0] = side;
00226                 i__1[1] = 1, a__1[1] = trans;
00227                 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
00228                 i__2 = *m - 1;
00229                 i__3 = *m - 1;
00230                 nb = ilaenv_(&c__1, "SORMQR", ch__1, &i__2, n, &i__3, &c_n1);
00231             } else {
00232 /* Writing concatenation */
00233                 i__1[0] = 1, a__1[0] = side;
00234                 i__1[1] = 1, a__1[1] = trans;
00235                 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2);
00236                 i__2 = *n - 1;
00237                 i__3 = *n - 1;
00238                 nb = ilaenv_(&c__1, "SORMQR", ch__1, m, &i__2, &i__3, &c_n1);
00239             }
00240         }
00241         lwkopt = max(1,nw) * nb;
00242         work[1] = (real) lwkopt;
00243     }
00244 
00245     if (*info != 0) {
00246         i__2 = -(*info);
00247         xerbla_("SORMTR", &i__2);
00248         return 0;
00249     } else if (lquery) {
00250         return 0;
00251     }
00252 
00253 /*     Quick return if possible */
00254 
00255     if (*m == 0 || *n == 0 || nq == 1) {
00256         work[1] = 1.f;
00257         return 0;
00258     }
00259 
00260     if (left) {
00261         mi = *m - 1;
00262         ni = *n;
00263     } else {
00264         mi = *m;
00265         ni = *n - 1;
00266     }
00267 
00268     if (upper) {
00269 
00270 /*        Q was determined by a call to SSYTRD with UPLO = 'U' */
00271 
00272         i__2 = nq - 1;
00273         sormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, &
00274                 tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo);
00275     } else {
00276 
00277 /*        Q was determined by a call to SSYTRD with UPLO = 'L' */
00278 
00279         if (left) {
00280             i1 = 2;
00281             i2 = 1;
00282         } else {
00283             i1 = 1;
00284             i2 = 2;
00285         }
00286         i__2 = nq - 1;
00287         sormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], &
00288                 c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo);
00289     }
00290     work[1] = (real) lwkopt;
00291     return 0;
00292 
00293 /*     End of SORMTR */
00294 
00295 } /* sormtr_ */


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:56:12