001:       SUBROUTINE CORE_SSSMQR( SIDE, TRANS, M1, M2, NN, IB, K, A1, LDA1,
002:      $                       A2, LDA2, V, LDV, T, LDT, WORK, LDWORK,
003:      $                       INFO )
004: 
005: *********************************************************************
006: *     PLASMA core_blas routine (version 2.1.0)                      *
007: *     Author: Hatem Ltaief                                          *
008: *     Release Date: November, 15th 2009                             *
009: *     PLASMA is a software package provided by Univ. of Tennessee,  *
010: *     Univ. of California Berkeley and Univ. of Colorado Denver.    *
011: *********************************************************************
012: *
013: *     .. Scalar Arguments ..
014:       CHARACTER          SIDE, TRANS
015:       INTEGER            M1, M2, NN, K, IB, LDA1, LDA2, LDV, LDT
016:       INTEGER            LDWORK, INFO
017: *     ..
018: *     .. Array Arguments ..
019:       REAL            A1( LDA1, * ), A2( LDA2, * )
020:       REAL            V( LDV, * ), T( LDT, * ), WORK( * )
021: *     ..
022: *
023: *  Purpose
024: *  =======
025: *
026: *  CORE_SSSMQR overwrites the general real M1-by-NN tile A1 and 
027: *  M2-by-NN tile A2 with
028: *
029: *                      SIDE = 'L'        SIDE = 'R'
030: *  TRANS = 'N':         Q * | A1 |       | A1 | * Q
031: *                           | A2 |       | A2 |
032: *
033: *  TRANS = 'C':      Q**H * | A1 |       | A1 | * Q**H
034: *                           | A2 |       | A2 |
035: *
036: *  where Q is a real orthogonal matrix defined as the product of k
037: *  elementary reflectors
038: *
039: *        Q = H(1) H(2) . . . H(k)
040: *
041: *  as returned by CORE_STSQRT.
042: *
043: *  Only LEFT is supported !!!
044: *
045: *  Arguments
046: *  =========
047: *
048: *  SIDE    (input) CHARACTER*1
049: *          = 'L': apply Q or Q**H from the Left;
050: *          = 'R': apply Q or Q**H from the Right.
051: *
052: *  TRANS   (input) CHARACTER*1
053: *          = 'N':  No transpose, apply Q;
054: *          = 'C':  ConjTranspose, apply Q**H.
055: *
056: *  M1      (input) INTEGER
057: *          The number of rows of the tile A1. M1 >= 0.
058: *
059: *  M2      (input) INTEGER
060: *          The number of rows of the tile A2. M2 >= 0.
061: *
062: *  NN      (input) INTEGER
063: *          The number of columns of the tiles A1 and A2. NN >= 0.
064: *
065: *  IB      (input) INTEGER
066: *          The inner-blocking size.  IB >= 0.
067: *
068: *  K       (input) INTEGER
069: *          The number of elementary reflectors whose product defines
070: *          the matrix Q.
071: *
072: *  A1      (input/output) REAL array, dimension (LDA1,M1)
073: *          On entry, the M1-by-NN tile A1.
074: *          On exit, A1 is overwritten by the application of Q.
075: *
076: *  LDA1    (input) INTEGER
077: *          The leading dimension of the tile A1. LDA1 >= max(1,M1).
078: *
079: *  A2      (input/output) REAL array, dimension (LDA2,M2)
080: *          On entry, the M2-by-NN tile A2.
081: *          On exit, A2 is overwritten by the application of Q.
082: *
083: *  LDA2    (input) INTEGER
084: *          The leading dimension of the tile A2. LDA2 >= max(1,M2).
085: *
086: *  V       (input) REAL array, dimension (LDA,K)
087: *          The i-th column must contain the vector which defines the
088: *          elementary reflector H(i), for i = 1,2,...,k, as returned by
089: *          CORE_STSQRT in the first k columns of its array argument V.
090: *
091: *  LDV     (input) INTEGER
092: *          The leading dimension of the array V. LDV >= max(1,K).
093: *
094: *  T       (output) REAL array, dimension (LDT,NN)
095: *          The IB-by-NN triangular factor T of the block reflector.
096: *          T is upper triangular by block (economic storage);
097: *          The rest of the array is not referenced.
098: *
099: *  LDT     (input) INTEGER
100: *          The leading dimension of the array T. LDT >= IB.
101: *
102: *  WORK    (workspace/output) REAL array, dimension (MAX(1,LDWORK))
103: *
104: *  LDWORK  (input) INTEGER
105: *          The dimension of the array WORK.
106: *
107: *  INFO    (output) INTEGER
108: *          = 0:  successful exit
109: *          < 0:  if INFO = -i, the i-th argument had an illegal value
110: *
111: *  =====================================================================
112: *
113: *     .. Local Scalars ..
114:       LOGICAL            LEFT, NOTRAN
115:       INTEGER            I, I1, I2, I3, KB, IC, IINFO, JC,
116:      $                   MI, NI, NQ, NW
117: *     ..
118: *     .. External Functions ..
119:       LOGICAL            LSAME
120:       EXTERNAL           LSAME
121: *     ..
122: *     .. External Subroutines ..
123:       EXTERNAL           CORE_SSSRFB, XERBLA
124: *     ..
125: *     .. Intrinsic Functions ..
126:       INTRINSIC          MAX, MIN
127: *     ..
128: *     .. Executable Statements ..
129: *
130: *     Test the input arguments
131: *
132:       INFO = 0
133:       LEFT = LSAME( SIDE, 'L' )
134:       NOTRAN = LSAME( TRANS, 'N' )
135: *
136: *     Quick return if possible
137: *
138:       IF( M1.EQ.0 .OR. M2.EQ.0 .OR. NN.EQ.0 .OR. K.EQ.0 ) THEN
139:          RETURN
140:       END IF
141: *
142: *     NQ is the order of Q and NW is the minimum dimension of WORK
143: *
144:       IF( LEFT ) THEN
145:          NQ = M1
146:          NW = NN
147:       ELSE
148:          NQ = NN
149:          NW = M1
150:       END IF
151:       IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
152:          INFO = -1
153:       ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
154:          INFO = -2
155:       ELSE IF( M1.LT.0 ) THEN
156:          INFO = -3
157:       ELSE IF( M2.LT.0 ) THEN
158:          INFO = -4
159:       ELSE IF( NN.LT.0 ) THEN
160:          INFO = -5
161:       ELSE IF( IB.LT.0 ) THEN
162:          INFO = -6
163:       ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
164:          INFO = -7
165:       ELSE IF( LDA1.LT.MAX( 1, NQ ) ) THEN
166:          INFO = -9
167:       END IF
168: *
169:       IF( INFO.NE.0 ) THEN
170:          CALL XERBLA( 'CORE_SSSMQR', -INFO )
171:          RETURN
172:       END IF
173: *
174:       IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
175:      $    ( .NOT.LEFT .AND. NOTRAN ) ) THEN
176:          I1 = 1
177:          I2 = K
178:          I3 = IB
179:       ELSE
180:          I1 = ( ( K-1 ) / IB )*IB + 1
181:          I2 = 1
182:          I3 = -IB
183:       END IF
184: *
185:       IF( LEFT ) THEN
186:          NI = NN
187:          JC = 1
188:       ELSE
189:          MI = M1
190:          IC = 1
191:       END IF
192: *
193:       DO 10 I = I1, I2, I3
194:          KB = MIN( IB, K-I+1 )
195:          IF( LEFT ) THEN
196: *
197: *           H or H' is applied to C(i:m,1:n)
198: *
199:             MI = M1 - I + 1
200:             IC = I
201:          ELSE
202: *
203: *           H or H' is applied to C(1:m,i:n)
204: *
205:             NI = NN - I + 1
206:             JC = I
207:          END IF
208: *
209: *        Apply H or H'
210: *
211:          CALL CORE_SSSRFB( SIDE, TRANS, 'Forward', 'Columnwise',
212:      $                    MI, M2, NI, KB, A1( IC, JC ), LDA1,
213:      $                    A2( 1, 1 ), LDA2,
214:      $                    V( 1, I ), LDV, T( 1, I ), LDT,
215:      $                    WORK, LDWORK, INFO )
216:    10 CONTINUE
217:       RETURN
218: *
219: *     End of CORE_SSSMQR
220: *
221:       END
222: