1      SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
2     $                   WORK, INFO )
3*
4*  -- LAPACK routine (version 3.0) --
5*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
6*     Courant Institute, Argonne National Lab, and Rice University
7*     February 29, 1992
8*
9*     .. Scalar Arguments ..
10      CHARACTER          SIDE, TRANS
11      INTEGER            INFO, K, LDA, LDC, M, N
12*     ..
13*     .. Array Arguments ..
14      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
15*     ..
16*
17*  Purpose
18*  =======
19*
20*  DORML2 overwrites the general real m by n matrix C with
21*
22*        Q * C  if SIDE = 'L' and TRANS = 'N', or
23*
24*        Q'* C  if SIDE = 'L' and TRANS = 'T', or
25*
26*        C * Q  if SIDE = 'R' and TRANS = 'N', or
27*
28*        C * Q' if SIDE = 'R' and TRANS = 'T',
29*
30*  where Q is a real orthogonal matrix defined as the product of k
31*  elementary reflectors
32*
33*        Q = H(k) . . . H(2) H(1)
34*
35*  as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n
36*  if SIDE = 'R'.
37*
38*  Arguments
39*  =========
40*
41*  SIDE    (input) CHARACTER*1
42*          = 'L': apply Q or Q' from the Left
43*          = 'R': apply Q or Q' from the Right
44*
45*  TRANS   (input) CHARACTER*1
46*          = 'N': apply Q  (No transpose)
47*          = 'T': apply Q' (Transpose)
48*
49*  M       (input) INTEGER
50*          The number of rows of the matrix C. M >= 0.
51*
52*  N       (input) INTEGER
53*          The number of columns of the matrix C. N >= 0.
54*
55*  K       (input) INTEGER
56*          The number of elementary reflectors whose product defines
57*          the matrix Q.
58*          If SIDE = 'L', M >= K >= 0;
59*          if SIDE = 'R', N >= K >= 0.
60*
61*  A       (input) DOUBLE PRECISION array, dimension
62*                               (LDA,M) if SIDE = 'L',
63*                               (LDA,N) if SIDE = 'R'
64*          The i-th row must contain the vector which defines the
65*          elementary reflector H(i), for i = 1,2,...,k, as returned by
66*          DGELQF in the first k rows of its array argument A.
67*          A is modified by the routine but restored on exit.
68*
69*  LDA     (input) INTEGER
70*          The leading dimension of the array A. LDA >= max(1,K).
71*
72*  TAU     (input) DOUBLE PRECISION array, dimension (K)
73*          TAU(i) must contain the scalar factor of the elementary
74*          reflector H(i), as returned by DGELQF.
75*
76*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
77*          On entry, the m by n matrix C.
78*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
79*
80*  LDC     (input) INTEGER
81*          The leading dimension of the array C. LDC >= max(1,M).
82*
83*  WORK    (workspace) DOUBLE PRECISION array, dimension
84*                                   (N) if SIDE = 'L',
85*                                   (M) if SIDE = 'R'
86*
87*  INFO    (output) INTEGER
88*          = 0: successful exit
89*          < 0: if INFO = -i, the i-th argument had an illegal value
90*
91*  =====================================================================
92*
93*     .. Parameters ..
94      DOUBLE PRECISION   ONE
95      PARAMETER          ( ONE = 1.0D+0 )
96*     ..
97*     .. Local Scalars ..
98      LOGICAL            LEFT, NOTRAN
99      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
100      DOUBLE PRECISION   AII
101*     ..
102*     .. External Functions ..
103      LOGICAL            LSAME
104      EXTERNAL           LSAME
105*     ..
106*     .. External Subroutines ..
107      EXTERNAL           DLARF, XERBLA
108*     ..
109*     .. Intrinsic Functions ..
110      INTRINSIC          MAX
111*     ..
112*     .. Executable Statements ..
113*
114*     Test the input arguments
115*
116      INFO = 0
117      LEFT = LSAME( SIDE, 'L' )
118      NOTRAN = LSAME( TRANS, 'N' )
119*
120*     NQ is the order of Q
121*
122      IF( LEFT ) THEN
123         NQ = M
124      ELSE
125         NQ = N
126      END IF
127      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
128         INFO = -1
129      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
130         INFO = -2
131      ELSE IF( M.LT.0 ) THEN
132         INFO = -3
133      ELSE IF( N.LT.0 ) THEN
134         INFO = -4
135      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
136         INFO = -5
137      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
138         INFO = -7
139      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
140         INFO = -10
141      END IF
142      IF( INFO.NE.0 ) THEN
143         CALL XERBLA( 'DORML2', -INFO )
144         RETURN
145      END IF
146*
147*     Quick return if possible
148*
149      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
150     $   RETURN
151*
152      IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
153     $     THEN
154         I1 = 1
155         I2 = K
156         I3 = 1
157      ELSE
158         I1 = K
159         I2 = 1
160         I3 = -1
161      END IF
162*
163      IF( LEFT ) THEN
164         NI = N
165         JC = 1
166      ELSE
167         MI = M
168         IC = 1
169      END IF
170*
171      DO 10 I = I1, I2, I3
172         IF( LEFT ) THEN
173*
174*           H(i) is applied to C(i:m,1:n)
175*
176            MI = M - I + 1
177            IC = I
178         ELSE
179*
180*           H(i) is applied to C(1:m,i:n)
181*
182            NI = N - I + 1
183            JC = I
184         END IF
185*
186*        Apply H(i)
187*
188         AII = A( I, I )
189         A( I, I ) = ONE
190         CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
191     $               C( IC, JC ), LDC, WORK )
192         A( I, I ) = AII
193   10 CONTINUE
194      RETURN
195*
196*     End of DORML2
197*
198      END
199