001:       SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
002: *
003: *  -- LAPACK routine (version 3.2) --
004: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
005: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
006: *     November 2006
007: *
008: *     .. Scalar Arguments ..
009:       CHARACTER          VECT
010:       INTEGER            INFO, K, LDA, LWORK, M, N
011: *     ..
012: *     .. Array Arguments ..
013:       DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
014: *     ..
015: *
016: *  Purpose
017: *  =======
018: *
019: *  DORGBR generates one of the real orthogonal matrices Q or P**T
020: *  determined by DGEBRD when reducing a real matrix A to bidiagonal
021: *  form: A = Q * B * P**T.  Q and P**T are defined as products of
022: *  elementary reflectors H(i) or G(i) respectively.
023: *
024: *  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
025: *  is of order M:
026: *  if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n
027: *  columns of Q, where m >= n >= k;
028: *  if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an
029: *  M-by-M matrix.
030: *
031: *  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
032: *  is of order N:
033: *  if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m
034: *  rows of P**T, where n >= m >= k;
035: *  if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as
036: *  an N-by-N matrix.
037: *
038: *  Arguments
039: *  =========
040: *
041: *  VECT    (input) CHARACTER*1
042: *          Specifies whether the matrix Q or the matrix P**T is
043: *          required, as defined in the transformation applied by DGEBRD:
044: *          = 'Q':  generate Q;
045: *          = 'P':  generate P**T.
046: *
047: *  M       (input) INTEGER
048: *          The number of rows of the matrix Q or P**T to be returned.
049: *          M >= 0.
050: *
051: *  N       (input) INTEGER
052: *          The number of columns of the matrix Q or P**T to be returned.
053: *          N >= 0.
054: *          If VECT = 'Q', M >= N >= min(M,K);
055: *          if VECT = 'P', N >= M >= min(N,K).
056: *
057: *  K       (input) INTEGER
058: *          If VECT = 'Q', the number of columns in the original M-by-K
059: *          matrix reduced by DGEBRD.
060: *          If VECT = 'P', the number of rows in the original K-by-N
061: *          matrix reduced by DGEBRD.
062: *          K >= 0.
063: *
064: *  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
065: *          On entry, the vectors which define the elementary reflectors,
066: *          as returned by DGEBRD.
067: *          On exit, the M-by-N matrix Q or P**T.
068: *
069: *  LDA     (input) INTEGER
070: *          The leading dimension of the array A. LDA >= max(1,M).
071: *
072: *  TAU     (input) DOUBLE PRECISION array, dimension
073: *                                (min(M,K)) if VECT = 'Q'
074: *                                (min(N,K)) if VECT = 'P'
075: *          TAU(i) must contain the scalar factor of the elementary
076: *          reflector H(i) or G(i), which determines Q or P**T, as
077: *          returned by DGEBRD in its array argument TAUQ or TAUP.
078: *
079: *  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
080: *          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
081: *
082: *  LWORK   (input) INTEGER
083: *          The dimension of the array WORK. LWORK >= max(1,min(M,N)).
084: *          For optimum performance LWORK >= min(M,N)*NB, where NB
085: *          is the optimal blocksize.
086: *
087: *          If LWORK = -1, then a workspace query is assumed; the routine
088: *          only calculates the optimal size of the WORK array, returns
089: *          this value as the first entry of the WORK array, and no error
090: *          message related to LWORK is issued by XERBLA.
091: *
092: *  INFO    (output) INTEGER
093: *          = 0:  successful exit
094: *          < 0:  if INFO = -i, the i-th argument had an illegal value
095: *
096: *  =====================================================================
097: *
098: *     .. Parameters ..
099:       DOUBLE PRECISION   ZERO, ONE
100:       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
101: *     ..
102: *     .. Local Scalars ..
103:       LOGICAL            LQUERY, WANTQ
104:       INTEGER            I, IINFO, J, LWKOPT, MN, NB
105: *     ..
106: *     .. External Functions ..
107:       LOGICAL            LSAME
108:       INTEGER            ILAENV
109:       EXTERNAL           LSAME, ILAENV
110: *     ..
111: *     .. External Subroutines ..
112:       EXTERNAL           DORGLQ, DORGQR, XERBLA
113: *     ..
114: *     .. Intrinsic Functions ..
115:       INTRINSIC          MAX, MIN
116: *     ..
117: *     .. Executable Statements ..
118: *
119: *     Test the input arguments
120: *
121:       INFO = 0
122:       WANTQ = LSAME( VECT, 'Q' )
123:       MN = MIN( M, N )
124:       LQUERY = ( LWORK.EQ.-1 )
125:       IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
126:          INFO = -1
127:       ELSE IF( M.LT.0 ) THEN
128:          INFO = -2
129:       ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
130:      $         K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
131:      $         MIN( N, K ) ) ) ) THEN
132:          INFO = -3
133:       ELSE IF( K.LT.0 ) THEN
134:          INFO = -4
135:       ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
136:          INFO = -6
137:       ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
138:          INFO = -9
139:       END IF
140: *
141:       IF( INFO.EQ.0 ) THEN
142:          IF( WANTQ ) THEN
143:             NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
144:          ELSE
145:             NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
146:          END IF
147:          LWKOPT = MAX( 1, MN )*NB
148:          WORK( 1 ) = LWKOPT
149:       END IF
150: *
151:       IF( INFO.NE.0 ) THEN
152:          CALL XERBLA( 'DORGBR', -INFO )
153:          RETURN
154:       ELSE IF( LQUERY ) THEN
155:          RETURN
156:       END IF
157: *
158: *     Quick return if possible
159: *
160:       IF( M.EQ.0 .OR. N.EQ.0 ) THEN
161:          WORK( 1 ) = 1
162:          RETURN
163:       END IF
164: *
165:       IF( WANTQ ) THEN
166: *
167: *        Form Q, determined by a call to DGEBRD to reduce an m-by-k
168: *        matrix
169: *
170:          IF( M.GE.K ) THEN
171: *
172: *           If m >= k, assume m >= n >= k
173: *
174:             CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
175: *
176:          ELSE
177: *
178: *           If m < k, assume m = n
179: *
180: *           Shift the vectors which define the elementary reflectors one
181: *           column to the right, and set the first row and column of Q
182: *           to those of the unit matrix
183: *
184:             DO 20 J = M, 2, -1
185:                A( 1, J ) = ZERO
186:                DO 10 I = J + 1, M
187:                   A( I, J ) = A( I, J-1 )
188:    10          CONTINUE
189:    20       CONTINUE
190:             A( 1, 1 ) = ONE
191:             DO 30 I = 2, M
192:                A( I, 1 ) = ZERO
193:    30       CONTINUE
194:             IF( M.GT.1 ) THEN
195: *
196: *              Form Q(2:m,2:m)
197: *
198:                CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
199:      $                      LWORK, IINFO )
200:             END IF
201:          END IF
202:       ELSE
203: *
204: *        Form P', determined by a call to DGEBRD to reduce a k-by-n
205: *        matrix
206: *
207:          IF( K.LT.N ) THEN
208: *
209: *           If k < n, assume k <= m <= n
210: *
211:             CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
212: *
213:          ELSE
214: *
215: *           If k >= n, assume m = n
216: *
217: *           Shift the vectors which define the elementary reflectors one
218: *           row downward, and set the first row and column of P' to
219: *           those of the unit matrix
220: *
221:             A( 1, 1 ) = ONE
222:             DO 40 I = 2, N
223:                A( I, 1 ) = ZERO
224:    40       CONTINUE
225:             DO 60 J = 2, N
226:                DO 50 I = J - 1, 2, -1
227:                   A( I, J ) = A( I-1, J )
228:    50          CONTINUE
229:                A( 1, J ) = ZERO
230:    60       CONTINUE
231:             IF( N.GT.1 ) THEN
232: *
233: *              Form P'(2:n,2:n)
234: *
235:                CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
236:      $                      LWORK, IINFO )
237:             END IF
238:          END IF
239:       END IF
240:       WORK( 1 ) = LWKOPT
241:       RETURN
242: *
243: *     End of DORGBR
244: *
245:       END
246: