1 SUBROUTINE pzungl2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK,
10 INTEGER IA, INFO, JA, K, LWORK, M, N
14 COMPLEX*16 A( * ), TAU( * ), WORK( * )
157 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
158 $ lld_, mb_, m_, nb_, n_, rsrc_
159 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
160 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
161 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
163 parameter( one = ( 1.0d+0, 0.0d+0 ),
164 $ zero = ( 0.0d+0, 0.0d+0 ) )
168 CHARACTER COLBTOP, ROWBTOP
169 INTEGER IACOL, IAROW, I, ICTXT, II, J, KP, LWMIN, MPA0,
170 $ mycol, myrow, npcol, nprow, nqa0
174 EXTERNAL blacs_abort, blacs_gridinfo,
chk1mat,
179 INTEGER INDXG2L, INDXG2P, NUMROC
180 EXTERNAL indxg2l, indxg2p, numroc
183 INTRINSIC dble, dcmplx, dconjg,
max,
min, mod
189 ictxt = desca( ctxt_ )
190 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
195 IF( nprow.EQ.-1 )
THEN
198 CALL chk1mat( m, 1, n, 2, ia, ja, desca, 7, info )
200 iarow = indxg2p( ia, desca( mb_ ), myrow, desca( rsrc_ ),
202 iacol = indxg2p( ja, desca( nb_ ), mycol, desca( csrc_ ),
204 mpa0 = numroc( m+mod( ia-1, desca( mb_ ) ), desca( mb_ ),
205 $ myrow, iarow, nprow )
206 nqa0 = numroc( n+mod( ja-1, desca( nb_ ) ), desca( nb_ ),
207 $ mycol, iacol, npcol )
208 lwmin = nqa0 +
max( 1, mpa0 )
210 work( 1 ) = dcmplx( dble( lwmin ) )
211 lquery = ( lwork.EQ.-1 )
214 ELSE IF( k.LT.0 .OR. k.GT.m )
THEN
216 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
222 CALL pxerbla( ictxt,
'PZUNGL2', -info )
223 CALL blacs_abort( ictxt, 1 )
225 ELSE IF( lquery )
THEN
234 CALL pb_topget( ictxt,
'Broadcast',
'Rowwise', rowbtop )
235 CALL pb_topget( ictxt,
'Broadcast',
'Columnwise', colbtop )
236 CALL pb_topset( ictxt,
'Broadcast',
'Rowwise',
' ' )
237 CALL pb_topset( ictxt,
'Broadcast',
'Columnwise',
'D-ring' )
243 CALL pzlaset(
'All', m-k, k, zero, zero, a, ia+k, ja, desca )
244 CALL pzlaset(
'All', m-k, n-k, zero, one, a, ia+k, ja+k,
250 kp = numroc( ia+k-1, desca( mb_ ), myrow, desca( rsrc_ ), nprow )
252 DO 10 i = ia+k-1, ia, -1
257 ii = indxg2l( i, desca( mb_ ), myrow, desca( rsrc_ ), nprow )
258 iarow = indxg2p( i, desca( mb_ ), myrow, desca( rsrc_ ),
261 $ taui = tau(
min( ii, kp ) )
262 IF( j.LT.ja+n-1 )
THEN
263 CALL pzlacgv( n-j+ja-1, a, i, j+1, desca, desca( m_ ) )
264 IF( i.LT.ia+m-1 )
THEN
265 CALL pzelset( a, i, j, desca, one )
266 CALL pzlarfc(
'Right', m-i+ia-1, n-j+ja, a, i, j, desca,
267 $ desca( m_ ), tau, a, i+1, j, desca, work )
269 CALL pzscal( n-j+ja-1, -taui, a, i, j+1, desca,
271 CALL pzlacgv( n-j+ja-1, a, i, j+1, desca, desca( m_ ) )
273 CALL pzelset( a, i, j, desca, one-dconjg( taui ) )
277 CALL pzlaset(
'All', 1, j-ja, zero, zero, a, i, ja, desca )
281 CALL pb_topset( ictxt,
'Broadcast',
'Rowwise', rowbtop )
282 CALL pb_topset( ictxt,
'Broadcast',
'Columnwise', colbtop )
284 work( 1 ) = dcmplx( dble( lwmin ) )