1 SUBROUTINE psgerqrv( M, N, A, IA, JA, DESCA, TAU, WORK )
13 REAL A( * ), TAU( * ), WORK( * )
122 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
123 $ LLD_, MB_, M_, NB_, N_, RSRC_
124 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
125 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
126 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
128 parameter( one = 1.0e+0, zero = 0.0e+0 )
131 CHARACTER COLBTOP, ROWBTOP
132 INTEGER I, IACOL, IAROW, IB, ICOFF, ICTXT, IIA, IN,
133 $ IPT, IPV, IPW, JJA, JV, K, MYCOL, MYROW, NPCOL,
137 INTEGER DESCV( DLEN_ )
145 INTEGER ICEIL, NUMROC
146 EXTERNAL iceil, numroc
155 ictxt = desca( ctxt_ )
156 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
159 in =
min( iceil( ia+m-k, desca( mb_ ) ) * desca( mb_ ), ia+m-1 )
161 icoff = mod( ja-1, desca( nb_ ) )
162 CALL infog2l( ia+m-k, ja, desca, nprow, npcol, myrow, mycol,
163 $ iia, jja, iarow, iacol )
164 nq = numroc( n+icoff, desca( nb_ ), mycol, iacol, npcol )
166 ipt = ipv + nq * desca( mb_ )
167 ipw = ipt + desca( mb_ ) * desca( mb_ )
168 CALL pb_topget( ictxt,
'Broadcast',
'Rowwise', rowbtop )
169 CALL pb_topget( ictxt,
'Broadcast',
'Columnwise', colbtop )
170 CALL pb_topset( ictxt,
'Broadcast',
'Rowwise',
' ' )
171 CALL pb_topset( ictxt,
'Broadcast',
'Columnwise',
'I-ring' )
173 CALL descset( descv, desca( mb_), n + icoff, desca( mb_ ),
174 $ desca( nb_ ), iarow, iacol, ictxt, desca( mb_ ) )
178 ib = in - ia - m + k + 1
179 jv = 1 + n - k + icoff
183 CALL pslarft(
'Backward',
'Rowwise', n-m+in-ia+1, ib, a, ia+m-k,
184 $ ja, desca, tau, work( ipt ), work( ipw ) )
188 CALL pslacpy(
'All', ib, n-m+in-ia+1, a, ia+m-k, ja, desca,
189 $ work( ipv ), 1, icoff+1, descv )
190 CALL pslaset(
'Upper', ib, ib, zero, one, work( ipv ), 1, jv,
196 CALL pslaset(
'All', ib, n-k, zero, zero, a, ia+m-k, ja,
198 CALL pslaset(
'Lower', ib-1, ib, zero, zero, a, ia+m-k+1,
203 CALL pslarfb(
'Right',
'Transpose',
'Backward',
'Rowwise',
204 $ in-ia+1, n-m+in-ia+1, ib, work( ipv ), 1, icoff+1,
205 $ descv, work( ipt ), a, ia, ja, desca, work( ipw ) )
207 descv( rsrc_ ) = mod( descv( rsrc_ ) + 1, nprow )
211 DO 10 i = in+1, ia+m-1, desca( mb_ )
212 ib =
min( ia+m-i, desca( mb_ ) )
213 jv = 1 + n - m + i - ia + icoff
217 CALL pslarft(
'Backward',
'Rowwise', n-m+i+ib-ia, ib, a, i, ja,
218 $ desca, tau, work( ipt ), work( ipw ) )
222 CALL pslacpy(
'All', ib, n-m+i+ib-ia, a, i, ja, desca,
223 $ work( ipv ), 1, icoff+1, descv )
224 CALL pslaset(
'Upper', ib, ib, zero, one, work( ipv ), 1, jv,
230 CALL pslaset(
'All', ib, n-m+i-ia, zero, zero, a, i, ja,
232 CALL pslaset(
'Lower', ib-1, ib, zero, zero, a, i+1,
233 $ ja+n-m+i-ia, desca )
237 CALL pslarfb(
'Right',
'Transpose',
'Backward',
'Rowwise',
238 $ i+ib-ia, n-m+i+ib-ia, ib, work( ipv ), 1,
239 $ icoff+1, descv, work( ipt ), a, ia, ja, desca,
242 descv( rsrc_ ) = mod( descv( rsrc_ ) + 1, nprow )
246 CALL pb_topset( ictxt,
'Broadcast',
'Rowwise', rowbtop )
247 CALL pb_topset( ictxt,
'Broadcast',
'Columnwise', colbtop )