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