1 SUBROUTINE psorgqr( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK,
10 INTEGER IA, INFO, JA, K, LWORK, M, N
14 REAL A( * ), TAU( * ), WORK( * )
158 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
159 $ lld_, mb_, m_, nb_, n_, rsrc_
160 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
161 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
162 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
164 parameter( zero = 0.0e+0 )
168 CHARACTER COLBTOP, ROWBTOP
169 INTEGER I, IACOL, IAROW, ICTXT, IINFO, IPW, J, JB, JL,
170 $ jn, lwmin, mpa0, mycol, myrow, npcol, nprow,
174 INTEGER IDUM1( 2 ), IDUM2( 2 )
182 INTEGER ICEIL, INDXG2P, NUMROC
183 EXTERNAL iceil, indxg2p, numroc
186 INTRINSIC max,
min, mod, real
192 ictxt = desca( ctxt_ )
193 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
198 IF( nprow.EQ.-1 )
THEN
201 CALL chk1mat( m, 1, n, 2, ia, ja, desca, 7, info )
203 iarow = indxg2p( ia, desca( mb_ ), myrow, desca( rsrc_ ),
205 iacol = indxg2p( ja, desca( nb_ ), mycol, desca( csrc_ ),
207 mpa0 = numroc( m+mod( ia-1, desca( mb_ ) ), desca( mb_ ),
208 $ myrow, iarow, nprow )
209 nqa0 = numroc( n+mod( ja-1, desca( nb_ ) ), desca( nb_ ),
210 $ mycol, iacol, npcol )
211 lwmin = desca( nb_ ) * ( mpa0 + nqa0 + desca( nb_ ) )
213 work( 1 ) = real( lwmin )
214 lquery = ( lwork.EQ.-1 )
217 ELSE IF( k.LT.0 .OR. k.GT.n )
THEN
219 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
225 IF( lwork.EQ.-1 )
THEN
231 CALL pchk1mat( m, 1, n, 2, ia, ja, desca, 7, 2, idum1, idum2,
236 CALL pxerbla( ictxt,
'PSORGQR', -info )
238 ELSE IF( lquery )
THEN
247 ipw = desca( nb_ )*desca( nb_ ) + 1
248 jn =
min( iceil( ja, desca( nb_ ) ) * desca( nb_ ), ja+k-1 )
249 jl =
max( ( (ja+k-2) / desca( nb_ ) ) * desca( nb_ ) + 1, ja )
250 CALL pb_topget( ictxt,
'Broadcast',
'Rowwise', rowbtop )
251 CALL pb_topget( ictxt,
'Broadcast',
'Columnwise', colbtop )
252 CALL pb_topset( ictxt,
'Broadcast',
'Rowwise',
'D-ring' )
253 CALL pb_topset( ictxt,
'Broadcast',
'Columnwise',
' ' )
255 CALL pslaset(
'All', jl-ja, ja+n-jl, zero, zero, a, ia, jl,
260 CALL psorg2r( m-jl+ja, ja+n-jl, ja+k-jl, a, ia+jl-ja, jl, desca,
261 $ tau, work, lwork, iinfo )
265 IF( jl.GT.jn+1 )
THEN
269 DO 10 j = jl-desca( nb_ ), jn+1, -desca( nb_ )
270 jb =
min( desca( nb_ ), ja+n-j )
273 IF( j+jb.LE.ja+n-1 )
THEN
278 CALL pslarft(
'Forward',
'Columnwise', m-i+ia, jb, a, i,
279 $ j, desca, tau, work, work( ipw ) )
283 CALL pslarfb(
'Left',
'No transpose',
'Forward',
284 $
'Columnwise', m-i+ia, n-j-jb+ja, jb, a, i,
285 $ j, desca, work, a, i, j+jb, desca,
291 CALL psorg2r( m-i+ia, jb, jb, a, i, j, desca, tau, work,
296 CALL pslaset(
'All', i-ia, jb, zero, zero, a, ia, j, desca )
311 CALL pslarft(
'Forward',
'Columnwise', m, jb, a, ia, ja, desca,
312 $ tau, work, work( ipw ) )
316 CALL pslarfb(
'Left',
'No transpose',
'Forward',
'Columnwise',
317 $ m, n-jb, jb, a, ia, ja, desca, work, a, ia,
318 $ ja+jb, desca, work( ipw ) )
322 CALL psorg2r( m, jb, jb, a, ia, ja, desca, tau, work, lwork,
327 CALL pb_topget( ictxt,
'Broadcast',
'Rowwise', rowbtop )
328 CALL pb_topget( ictxt,
'Broadcast',
'Columnwise', colbtop )
330 work( 1 ) = real( lwmin )