SRC/sorgbr.f

   1 *> \brief \b SORGBR
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download SORGBR + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorgbr.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorgbr.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorgbr.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       CHARACTER          VECT
  25 *       INTEGER            INFO, K, LDA, LWORK, M, N
  26 *       ..
  27 *       .. Array Arguments ..
  28 *       REAL               A( LDA, * ), TAU( * ), WORK( * )
  29 *       ..
  30 *
  31 *
  32 *> \par Purpose:
  33 *  =============
  34 *>
  35 *> \verbatim
  36 *>
  37 *> SORGBR generates one of the real orthogonal matrices Q or P**T
  38 *> determined by SGEBRD when reducing a real matrix A to bidiagonal
  39 *> form: A = Q * B * P**T.  Q and P**T are defined as products of
  40 *> elementary reflectors H(i) or G(i) respectively.
  41 *>
  42 *> If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
  43 *> is of order M:
  44 *> if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n
  45 *> columns of Q, where m >= n >= k;
  46 *> if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an
  47 *> M-by-M matrix.
  48 *>
  49 *> If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
  50 *> is of order N:
  51 *> if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m
  52 *> rows of P**T, where n >= m >= k;
  53 *> if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as
  54 *> an N-by-N matrix.
  55 *> \endverbatim
  56 *
  57 *  Arguments:
  58 *  ==========
  59 *
  60 *> \param[in] VECT
  61 *> \verbatim
  62 *>          VECT is CHARACTER*1
  63 *>          Specifies whether the matrix Q or the matrix P**T is
  64 *>          required, as defined in the transformation applied by SGEBRD:
  65 *>          = 'Q':  generate Q;
  66 *>          = 'P':  generate P**T.
  67 *> \endverbatim
  68 *>
  69 *> \param[in] M
  70 *> \verbatim
  71 *>          M is INTEGER
  72 *>          The number of rows of the matrix Q or P**T to be returned.
  73 *>          M >= 0.
  74 *> \endverbatim
  75 *>
  76 *> \param[in] N
  77 *> \verbatim
  78 *>          N is INTEGER
  79 *>          The number of columns of the matrix Q or P**T to be returned.
  80 *>          N >= 0.
  81 *>          If VECT = 'Q', M >= N >= min(M,K);
  82 *>          if VECT = 'P', N >= M >= min(N,K).
  83 *> \endverbatim
  84 *>
  85 *> \param[in] K
  86 *> \verbatim
  87 *>          K is INTEGER
  88 *>          If VECT = 'Q', the number of columns in the original M-by-K
  89 *>          matrix reduced by SGEBRD.
  90 *>          If VECT = 'P', the number of rows in the original K-by-N
  91 *>          matrix reduced by SGEBRD.
  92 *>          K >= 0.
  93 *> \endverbatim
  94 *>
  95 *> \param[in,out] A
  96 *> \verbatim
  97 *>          A is REAL array, dimension (LDA,N)
  98 *>          On entry, the vectors which define the elementary reflectors,
  99 *>          as returned by SGEBRD.
 100 *>          On exit, the M-by-N matrix Q or P**T.
 101 *> \endverbatim
 102 *>
 103 *> \param[in] LDA
 104 *> \verbatim
 105 *>          LDA is INTEGER
 106 *>          The leading dimension of the array A. LDA >= max(1,M).
 107 *> \endverbatim
 108 *>
 109 *> \param[in] TAU
 110 *> \verbatim
 111 *>          TAU is REAL array, dimension
 112 *>                                (min(M,K)) if VECT = 'Q'
 113 *>                                (min(N,K)) if VECT = 'P'
 114 *>          TAU(i) must contain the scalar factor of the elementary
 115 *>          reflector H(i) or G(i), which determines Q or P**T, as
 116 *>          returned by SGEBRD in its array argument TAUQ or TAUP.
 117 *> \endverbatim
 118 *>
 119 *> \param[out] WORK
 120 *> \verbatim
 121 *>          WORK is REAL array, dimension (MAX(1,LWORK))
 122 *>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
 123 *> \endverbatim
 124 *>
 125 *> \param[in] LWORK
 126 *> \verbatim
 127 *>          LWORK is INTEGER
 128 *>          The dimension of the array WORK. LWORK >= max(1,min(M,N)).
 129 *>          For optimum performance LWORK >= min(M,N)*NB, where NB
 130 *>          is the optimal blocksize.
 131 *>
 132 *>          If LWORK = -1, then a workspace query is assumed; the routine
 133 *>          only calculates the optimal size of the WORK array, returns
 134 *>          this value as the first entry of the WORK array, and no error
 135 *>          message related to LWORK is issued by XERBLA.
 136 *> \endverbatim
 137 *>
 138 *> \param[out] INFO
 139 *> \verbatim
 140 *>          INFO is INTEGER
 141 *>          = 0:  successful exit
 142 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
 143 *> \endverbatim
 144 *
 145 *  Authors:
 146 *  ========
 147 *
 148 *> \author Univ. of Tennessee
 149 *> \author Univ. of California Berkeley
 150 *> \author Univ. of Colorado Denver
 151 *> \author NAG Ltd.
 152 *
 153 *> \date April 2012
 154 *
 155 *> \ingroup realGBcomputational
 156 *
 157 *  =====================================================================
 158       SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
 159 *
 160 *  -- LAPACK computational routine (version 3.4.1) --
 161 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 162 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 163 *     April 2012
 164 *
 165 *     .. Scalar Arguments ..
 166       CHARACTER          VECT
 167       INTEGER            INFO, K, LDA, LWORK, M, N
 168 *     ..
 169 *     .. Array Arguments ..
 170       REAL               A( LDA, * ), TAU( * ), WORK( * )
 171 *     ..
 172 *
 173 *  =====================================================================
 174 *
 175 *     .. Parameters ..
 176       REAL               ZERO, ONE
 177       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
 178 *     ..
 179 *     .. Local Scalars ..
 180       LOGICAL            LQUERY, WANTQ
 181       INTEGER            I, IINFO, J, LWKOPT, MN
 182 *     ..
 183 *     .. External Functions ..
 184       LOGICAL            LSAME
 185       INTEGER            ILAENV
 186       EXTERNAL           ILAENV, LSAME
 187 *     ..
 188 *     .. External Subroutines ..
 189       EXTERNAL           SORGLQ, SORGQR, XERBLA
 190 *     ..
 191 *     .. Intrinsic Functions ..
 192       INTRINSIC          MAX, MIN
 193 *     ..
 194 *     .. Executable Statements ..
 195 *
 196 *     Test the input arguments
 197 *
 198       INFO = 0
 199       WANTQ = LSAME( VECT, 'Q' )
 200       MN = MIN( M, N )
 201       LQUERY = ( LWORK.EQ.-1 )
 202       IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
 203          INFO = -1
 204       ELSE IF( M.LT.0 ) THEN
 205          INFO = -2
 206       ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
 207      $         K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
 208      $         MIN( N, K ) ) ) ) THEN
 209          INFO = -3
 210       ELSE IF( K.LT.0 ) THEN
 211          INFO = -4
 212       ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
 213          INFO = -6
 214       ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
 215          INFO = -9
 216       END IF
 217 *
 218       IF( INFO.EQ.0 ) THEN
 219          WORK( 1 ) = 1
 220          IF( WANTQ ) THEN
 221             IF( M.GE.K ) THEN
 222                CALL SORGQR( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
 223             ELSE
 224                IF( M.GT.1 ) THEN
 225                   CALL SORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
 226      $                         -1, IINFO )
 227                END IF
 228             END IF
 229          ELSE
 230             IF( K.LT.N ) THEN
 231                CALL SORGLQ( M, N, K, A, LDA, TAU, WORK, -1, IINFO )
 232             ELSE
 233                IF( N.GT.1 ) THEN
 234                   CALL SORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
 235      $                         -1, IINFO )
 236                END IF
 237             END IF
 238          END IF
 239          LWKOPT = WORK( 1 )
 240          LWKOPT = MAX (LWKOPT, MN)
 241       END IF
 242 *
 243       IF( INFO.NE.0 ) THEN
 244          CALL XERBLA( 'SORGBR', -INFO )
 245          RETURN
 246       ELSE IF( LQUERY ) THEN
 247          WORK( 1 ) = LWKOPT
 248          RETURN
 249       END IF
 250 *
 251 *     Quick return if possible
 252 *
 253       IF( M.EQ.0 .OR. N.EQ.0 ) THEN
 254          WORK( 1 ) = 1
 255          RETURN
 256       END IF
 257 *
 258       IF( WANTQ ) THEN
 259 *
 260 *        Form Q, determined by a call to SGEBRD to reduce an m-by-k
 261 *        matrix
 262 *
 263          IF( M.GE.K ) THEN
 264 *
 265 *           If m >= k, assume m >= n >= k
 266 *
 267             CALL SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
 268 *
 269          ELSE
 270 *
 271 *           If m < k, assume m = n
 272 *
 273 *           Shift the vectors which define the elementary reflectors one
 274 *           column to the right, and set the first row and column of Q
 275 *           to those of the unit matrix
 276 *
 277             DO 20 J = M, 2, -1
 278                A( 1, J ) = ZERO
 279                DO 10 I = J + 1, M
 280                   A( I, J ) = A( I, J-1 )
 281    10          CONTINUE
 282    20       CONTINUE
 283             A( 1, 1 ) = ONE
 284             DO 30 I = 2, M
 285                A( I, 1 ) = ZERO
 286    30       CONTINUE
 287             IF( M.GT.1 ) THEN
 288 *
 289 *              Form Q(2:m,2:m)
 290 *
 291                CALL SORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
 292      $                      LWORK, IINFO )
 293             END IF
 294          END IF
 295       ELSE
 296 *
 297 *        Form P**T, determined by a call to SGEBRD to reduce a k-by-n
 298 *        matrix
 299 *
 300          IF( K.LT.N ) THEN
 301 *
 302 *           If k < n, assume k <= m <= n
 303 *
 304             CALL SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
 305 *
 306          ELSE
 307 *
 308 *           If k >= n, assume m = n
 309 *
 310 *           Shift the vectors which define the elementary reflectors one
 311 *           row downward, and set the first row and column of P**T to
 312 *           those of the unit matrix
 313 *
 314             A( 1, 1 ) = ONE
 315             DO 40 I = 2, N
 316                A( I, 1 ) = ZERO
 317    40       CONTINUE
 318             DO 60 J = 2, N
 319                DO 50 I = J - 1, 2, -1
 320                   A( I, J ) = A( I-1, J )
 321    50          CONTINUE
 322                A( 1, J ) = ZERO
 323    60       CONTINUE
 324             IF( N.GT.1 ) THEN
 325 *
 326 *              Form P**T(2:n,2:n)
 327 *
 328                CALL SORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
 329      $                      LWORK, IINFO )
 330             END IF
 331          END IF
 332       END IF
 333       WORK( 1 ) = LWKOPT
 334       RETURN
 335 *
 336 *     End of SORGBR
 337 *
 338       END