OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pclarzc.f
Go to the documentation of this file.
1 SUBROUTINE pclarzc( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C,
2 $ IC, JC, DESCC, WORK )
3*
4* -- ScaLAPACK auxiliary routine (version 1.7) --
5* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6* and University of California, Berkeley.
7* May 25, 2001
8*
9* .. Scalar Arguments ..
10 CHARACTER SIDE
11 INTEGER IC, INCV, IV, JC, JV, L, M, N
12* ..
13* .. Array Arguments ..
14 INTEGER DESCC( * ), DESCV( * )
15 COMPLEX C( * ), TAU( * ), V( * ), WORK( * )
16* ..
17*
18* Purpose
19* =======
20*
21* PCLARZC applies a complex elementary reflector Q**H to a
22* complex M-by-N distributed matrix sub( C ) = C(IC:IC+M-1,JC:JC+N-1),
23* from either the left or the right. Q is represented in the form
24*
25* Q = I - tau * v * v'
26*
27* where tau is a complex scalar and v is a complex vector.
28*
29* If tau = 0, then Q is taken to be the unit matrix.
30*
31* Q is a product of k elementary reflectors as returned by PCTZRZF.
32*
33* Notes
34* =====
35*
36* Each global data object is described by an associated description
37* vector. This vector stores the information required to establish
38* the mapping between an object element and its corresponding process
39* and memory location.
40*
41* Let A be a generic term for any 2D block cyclicly distributed array.
42* Such a global array has an associated description vector DESCA.
43* In the following comments, the character _ should be read as
44* "of the global array".
45*
46* NOTATION STORED IN EXPLANATION
47* --------------- -------------- --------------------------------------
48* DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
49* DTYPE_A = 1.
50* CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
51* the BLACS process grid A is distribu-
52* ted over. The context itself is glo-
53* bal, but the handle (the integer
54* value) may vary.
55* M_A (global) DESCA( M_ ) The number of rows in the global
56* array A.
57* N_A (global) DESCA( N_ ) The number of columns in the global
58* array A.
59* MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
60* the rows of the array.
61* NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
62* the columns of the array.
63* RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
64* row of the array A is distributed.
65* CSRC_A (global) DESCA( CSRC_ ) The process column over which the
66* first column of the array A is
67* distributed.
68* LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
69* array. LLD_A >= MAX(1,LOCr(M_A)).
70*
71* Let K be the number of rows or columns of a distributed matrix,
72* and assume that its process grid has dimension p x q.
73* LOCr( K ) denotes the number of elements of K that a process
74* would receive if K were distributed over the p processes of its
75* process column.
76* Similarly, LOCc( K ) denotes the number of elements of K that a
77* process would receive if K were distributed over the q processes of
78* its process row.
79* The values of LOCr() and LOCc() may be determined via a call to the
80* ScaLAPACK tool function, NUMROC:
81* LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
82* LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
83* An upper bound for these quantities may be computed by:
84* LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
85* LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
86*
87* Because vectors may be viewed as a subclass of matrices, a
88* distributed vector is considered to be a distributed matrix.
89*
90* Restrictions
91* ============
92*
93* If SIDE = 'Left' and INCV = 1, then the row process having the first
94* entry V(IV,JV) must also own C(IC+M-L,JC:JC+N-1). Moreover,
95* MOD(IV-1,MB_V) must be equal to MOD(IC+N-L-1,MB_C), if INCV=M_V, only
96* the last equality must be satisfied.
97*
98* If SIDE = 'Right' and INCV = M_V then the column process having the
99* first entry V(IV,JV) must also own C(IC:IC+M-1,JC+N-L) and
100* MOD(JV-1,NB_V) must be equal to MOD(JC+N-L-1,NB_C), if INCV = 1 only
101* the last equality must be satisfied.
102*
103* Arguments
104* =========
105*
106* SIDE (global input) CHARACTER
107* = 'L': form Q**H * sub( C ),
108* = 'R': form sub( C ) * Q**H.
109*
110* M (global input) INTEGER
111* The number of rows to be operated on i.e the number of rows
112* of the distributed submatrix sub( C ). M >= 0.
113*
114* N (global input) INTEGER
115* The number of columns to be operated on i.e the number of
116* columns of the distributed submatrix sub( C ). N >= 0.
117*
118* L (global input) INTEGER
119* The columns of the distributed submatrix sub( A ) containing
120* the meaningful part of the Householder reflectors.
121* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
122*
123* V (local input) COMPLEX pointer into the local memory
124* to an array of dimension (LLD_V,*) containing the local
125* pieces of the distributed vectors V representing the
126* Householder transformation Q,
127* V(IV:IV+L-1,JV) if SIDE = 'L' and INCV = 1,
128* V(IV,JV:JV+L-1) if SIDE = 'L' and INCV = M_V,
129* V(IV:IV+L-1,JV) if SIDE = 'R' and INCV = 1,
130* V(IV,JV:JV+L-1) if SIDE = 'R' and INCV = M_V,
131*
132* The vector v in the representation of Q. V is not used if
133* TAU = 0.
134*
135* IV (global input) INTEGER
136* The row index in the global array V indicating the first
137* row of sub( V ).
138*
139* JV (global input) INTEGER
140* The column index in the global array V indicating the
141* first column of sub( V ).
142*
143* DESCV (global and local input) INTEGER array of dimension DLEN_.
144* The array descriptor for the distributed matrix V.
145*
146* INCV (global input) INTEGER
147* The global increment for the elements of V. Only two values
148* of INCV are supported in this version, namely 1 and M_V.
149* INCV must not be zero.
150*
151* TAU (local input) COMPLEX, array, dimension LOCc(JV) if
152* INCV = 1, and LOCr(IV) otherwise. This array contains the
153* Householder scalars related to the Householder vectors.
154* TAU is tied to the distributed matrix V.
155*
156* C (local input/local output) COMPLEX pointer into the
157* local memory to an array of dimension (LLD_C, LOCc(JC+N-1) ),
158* containing the local pieces of sub( C ). On exit, sub( C )
159* is overwritten by the Q**H * sub( C ) if SIDE = 'L', or
160* sub( C ) * Q**H if SIDE = 'R'.
161*
162* IC (global input) INTEGER
163* The row index in the global array C indicating the first
164* row of sub( C ).
165*
166* JC (global input) INTEGER
167* The column index in the global array C indicating the
168* first column of sub( C ).
169*
170* DESCC (global and local input) INTEGER array of dimension DLEN_.
171* The array descriptor for the distributed matrix C.
172*
173* WORK (local workspace) COMPLEX array, dimension (LWORK)
174* If INCV = 1,
175* if SIDE = 'L',
176* if IVCOL = ICCOL,
177* LWORK >= NqC0
178* else
179* LWORK >= MpC0 + MAX( 1, NqC0 )
180* end if
181* else if SIDE = 'R',
182* LWORK >= NqC0 + MAX( MAX( 1, MpC0 ), NUMROC( NUMROC(
183* N+ICOFFC,NB_V,0,0,NPCOL ),NB_V,0,0,LCMQ ) )
184* end if
185* else if INCV = M_V,
186* if SIDE = 'L',
187* LWORK >= MpC0 + MAX( MAX( 1, NqC0 ), NUMROC( NUMROC(
188* M+IROFFC,MB_V,0,0,NPROW ),MB_V,0,0,LCMP ) )
189* else if SIDE = 'R',
190* if IVROW = ICROW,
191* LWORK >= MpC0
192* else
193* LWORK >= NqC0 + MAX( 1, MpC0 )
194* end if
195* end if
196* end if
197*
198* where LCM is the least common multiple of NPROW and NPCOL and
199* LCM = ILCM( NPROW, NPCOL ), LCMP = LCM / NPROW,
200* LCMQ = LCM / NPCOL,
201*
202* IROFFC = MOD( IC-1, MB_C ), ICOFFC = MOD( JC-1, NB_C ),
203* ICROW = INDXG2P( IC, MB_C, MYROW, RSRC_C, NPROW ),
204* ICCOL = INDXG2P( JC, NB_C, MYCOL, CSRC_C, NPCOL ),
205* MpC0 = NUMROC( M+IROFFC, MB_C, MYROW, ICROW, NPROW ),
206* NqC0 = NUMROC( N+ICOFFC, NB_C, MYCOL, ICCOL, NPCOL ),
207*
208* ILCM, INDXG2P and NUMROC are ScaLAPACK tool functions;
209* MYROW, MYCOL, NPROW and NPCOL can be determined by calling
210* the subroutine BLACS_GRIDINFO.
211*
212* Alignment requirements
213* ======================
214*
215* The distributed submatrices V(IV:*, JV:*) and C(IC:IC+M-1,JC:JC+N-1)
216* must verify some alignment properties, namely the following
217* expressions should be true:
218*
219* MB_V = NB_V,
220*
221* If INCV = 1,
222* If SIDE = 'Left',
223* ( MB_V.EQ.MB_C .AND. IROFFV.EQ.IROFFC .AND. IVROW.EQ.ICROW )
224* If SIDE = 'Right',
225* ( MB_V.EQ.NB_A .AND. MB_V.EQ.NB_C .AND. IROFFV.EQ.ICOFFC )
226* else if INCV = M_V,
227* If SIDE = 'Left',
228* ( MB_V.EQ.NB_V .AND. MB_V.EQ.MB_C .AND. ICOFFV.EQ.IROFFC )
229* If SIDE = 'Right',
230* ( NB_V.EQ.NB_C .AND. ICOFFV.EQ.ICOFFC .AND. IVCOL.EQ.ICCOL )
231* end if
232*
233* =====================================================================
234*
235* .. Parameters ..
236 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
237 $ lld_, mb_, m_, nb_, n_, rsrc_
238 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
239 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
240 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
241 COMPLEX ONE, ZERO
242 parameter( one = ( 1.0e+0, 0.0e+0 ),
243 $ zero = ( 0.0e+0, 0.0e+0 ) )
244* ..
245* .. Local Scalars ..
246 LOGICAL CCBLCK, CRBLCK, LEFT
247 CHARACTER COLBTOP, ROWBTOP
248 INTEGER ICCOL1, ICCOL2, ICOFFC1, ICOFFC2, ICOFFV,
249 $ icrow1, icrow2, ictxt, iic1, iic2, iiv, ioffc1,
250 $ ioffc2, ioffv, ipw, iroffc1, iroffc2, iroffv,
251 $ ivcol, ivrow, jjc1, jjc2, jjv, ldc, ldv, mpc2,
252 $ mpv, mycol, myrow, ncc, ncv, npcol, nprow,
253 $ nqc2, nqv, rdest
254 COMPLEX TAULOC( 1 )
255* ..
256* .. External Subroutines ..
257 EXTERNAL blacs_gridinfo, caxpy, ccopy, cgebr2d,
258 $ cgebs2d, cgemv, cgerc, cgerv2d,
259 $ cgesd2d, cgsum2d, claset, infog2l,
260 $ pb_topget, pbctrnv
261* ..
262* .. External Functions ..
263 LOGICAL LSAME
264 INTEGER NUMROC
265 EXTERNAL lsame, numroc
266* ..
267* .. Intrinsic Functions ..
268 INTRINSIC min, mod
269* ..
270* .. Executable Statements ..
271*
272* Quick return if possible
273*
274 IF( m.LE.0 .OR. n.LE.0 )
275 $ RETURN
276*
277* Get grid parameters.
278*
279 ictxt = descc( ctxt_ )
280 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
281*
282* Figure local indexes
283*
284 left = lsame( side, 'L' )
285 CALL infog2l( iv, jv, descv, nprow, npcol, myrow, mycol, iiv, jjv,
286 $ ivrow, ivcol )
287 iroffv = mod( iv-1, descv( nb_ ) )
288 mpv = numroc( l+iroffv, descv( mb_ ), myrow, ivrow, nprow )
289 IF( myrow.EQ.ivrow )
290 $ mpv = mpv - iroffv
291 icoffv = mod( jv-1, descv( nb_ ) )
292 nqv = numroc( l+icoffv, descv( nb_ ), mycol, ivcol, npcol )
293 IF( mycol.EQ.ivcol )
294 $ nqv = nqv - icoffv
295 ldv = descv( lld_ )
296 ncv = numroc( descv( n_ ), descv( nb_ ), mycol, descv( csrc_ ),
297 $ npcol )
298 ldv = descv( lld_ )
299 iiv = min( iiv, ldv )
300 jjv = min( jjv, ncv )
301 ioffv = iiv+(jjv-1)*ldv
302 ncc = numroc( descc( n_ ), descc( nb_ ), mycol, descc( csrc_ ),
303 $ npcol )
304 CALL infog2l( ic, jc, descc, nprow, npcol, myrow, mycol,
305 $ iic1, jjc1, icrow1, iccol1 )
306 iroffc1 = mod( ic-1, descc( mb_ ) )
307 icoffc1 = mod( jc-1, descc( nb_ ) )
308 ldc = descc( lld_ )
309 iic1 = min( iic1, ldc )
310 jjc1 = min( jjc1, max( 1, ncc ) )
311 ioffc1 = iic1 + ( jjc1-1 ) * ldc
312*
313 IF( left ) THEN
314 CALL infog2l( ic+m-l, jc, descc, nprow, npcol, myrow, mycol,
315 $ iic2, jjc2, icrow2, iccol2 )
316 iroffc2 = mod( ic+m-l-1, descc( mb_ ) )
317 icoffc2 = mod( jc-1, descc( nb_ ) )
318 nqc2 = numroc( n+icoffc2, descc( nb_ ), mycol, iccol2, npcol )
319 IF( mycol.EQ.iccol2 )
320 $ nqc2 = nqc2 - icoffc2
321 ELSE
322 CALL infog2l( ic, jc+n-l, descc, nprow, npcol, myrow, mycol,
323 $ iic2, jjc2, icrow2, iccol2 )
324 iroffc2 = mod( ic-1, descc( mb_ ) )
325 mpc2 = numroc( m+iroffc2, descc( mb_ ), myrow, icrow2, nprow )
326 IF( myrow.EQ.icrow2 )
327 $ mpc2 = mpc2 - iroffc2
328 icoffc2 = mod( jc+n-l-1, descc( nb_ ) )
329 END IF
330 iic2 = min( iic2, ldc )
331 jjc2 = min( jjc2, ncc )
332 ioffc2 = iic2 + ( jjc2-1 ) * ldc
333*
334* Is sub( C ) only distributed over a process row ?
335*
336 crblck = ( m.LE.(descc( mb_ )-iroffc1) )
337*
338* Is sub( C ) only distributed over a process column ?
339*
340 ccblck = ( n.LE.(descc( nb_ )-icoffc1) )
341*
342 IF( left ) THEN
343*
344 IF( crblck ) THEN
345 rdest = icrow2
346 ELSE
347 rdest = -1
348 END IF
349*
350 IF( ccblck ) THEN
351*
352* sub( C ) is distributed over a process column
353*
354 IF( descv( m_ ).EQ.incv ) THEN
355*
356* Transpose row vector V (ICOFFV = IROFFC2)
357*
358 ipw = mpv+1
359 CALL pbctrnv( ictxt, 'Rowwise', 'transpose', M,
360 $ DESCV( NB_ ), IROFFC2, V( IOFFV ), LDV,
361 $ ZERO,
362 $ WORK, 1, IVROW, IVCOL, ICROW2, ICCOL2,
363 $ WORK( IPW ) )
364*
365* Perform the local computation within a process column
366*
367.EQ. IF( MYCOLICCOL2 ) THEN
368*
369.EQ. IF( MYROWIVROW ) THEN
370*
371 CALL CGEBS2D( ICTXT, 'columnwise', ' ', 1, 1,
372 $ TAU( IIV ), 1 )
373 TAULOC( 1 ) = CONJG( TAU( IIV ) )
374*
375 ELSE
376*
377 CALL CGEBR2D( ICTXT, 'columnwise', ' ', 1, 1,
378 $ TAULOC, 1, IVROW, MYCOL )
379 TAULOC( 1 ) = CONJG( TAULOC( 1 ) )
380*
381 END IF
382*
383.NE. IF( TAULOC( 1 )ZERO ) THEN
384*
385* w := sub( C )' * v
386*
387.GT. IF( MPV0 ) THEN
388 CALL CGEMV( 'conjugate transpose', MPV, NQC2,
389 $ ONE, C( IOFFC2 ), LDC, WORK, 1,
390 $ ZERO, WORK( IPW ), 1 )
391 ELSE
392 CALL CLASET( 'all', NQC2, 1, ZERO, ZERO,
393 $ WORK( IPW ), MAX( 1, NQC2 ) )
394 END IF
395.EQ. IF( MYROWICROW1 )
396 $ CALL CAXPY( NQC2, ONE, C( IOFFC1 ), LDC,
397 $ WORK( IPW ), MAX( 1, NQC2 ) )
398*
399 CALL CGSUM2D( ICTXT, 'columnwise', ' ', NQC2, 1,
400 $ WORK( IPW ), MAX( 1, NQC2 ), RDEST,
401 $ MYCOL )
402*
403* sub( C ) := sub( C ) - v * w'
404*
405.EQ. IF( MYROWICROW1 )
406 $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ),
407 $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC )
408 CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1,
409 $ WORK( IPW ), 1, C( IOFFC2 ), LDC )
410 END IF
411*
412 END IF
413*
414 ELSE
415*
416* V is a column vector
417*
418.EQ. IF( IVCOLICCOL2 ) THEN
419*
420* Perform the local computation within a process column
421*
422.EQ. IF( MYCOLICCOL2 ) THEN
423*
424 TAULOC( 1 ) = CONJG( TAU( JJV ) )
425*
426.NE. IF( TAULOC( 1 )ZERO ) THEN
427*
428* w := sub( C )' * v
429*
430.GT. IF( MPV0 ) THEN
431 CALL CGEMV( 'conjugate transpose', MPV, NQC2,
432 $ ONE, C( IOFFC2 ), LDC, V( IOFFV ),
433 $ 1, ZERO, WORK, 1 )
434 ELSE
435 CALL CLASET( 'all', NQC2, 1, ZERO, ZERO,
436 $ WORK, MAX( 1, NQC2 ) )
437 END IF
438.EQ. IF( MYROWICROW1 )
439 $ CALL CAXPY( NQC2, ONE, C( IOFFC1 ), LDC,
440 $ WORK, MAX( 1, NQC2 ) )
441*
442 CALL CGSUM2D( ICTXT, 'columnwise', ' ', NQC2, 1,
443 $ WORK, MAX( 1, NQC2 ), RDEST,
444 $ MYCOL )
445*
446* sub( C ) := sub( C ) - v * w'
447*
448.EQ. IF( MYROWICROW1 )
449 $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK,
450 $ MAX( 1, NQC2 ), C( IOFFC1 ),
451 $ LDC )
452 CALL CGERC( MPV, NQC2, -TAULOC( 1 ), V( IOFFV ),
453 $ 1, WORK, 1, C( IOFFC2 ), LDC )
454 END IF
455*
456 END IF
457*
458 ELSE
459*
460* Send V and TAU to the process column ICCOL2
461*
462.EQ. IF( MYCOLIVCOL ) THEN
463*
464 IPW = MPV+1
465 CALL CCOPY( MPV, V( IOFFV ), 1, WORK, 1 )
466 WORK( IPW ) = TAU( JJV )
467 CALL CGESD2D( ICTXT, IPW, 1, WORK, IPW, MYROW,
468 $ ICCOL2 )
469*
470.EQ. ELSE IF( MYCOLICCOL2 ) THEN
471*
472 IPW = MPV+1
473 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, MYROW,
474 $ IVCOL )
475 TAULOC( 1 ) = CONJG( WORK( IPW ) )
476*
477.NE. IF( TAULOC( 1 )ZERO ) THEN
478*
479* w := sub( C )' * v
480*
481.GT. IF( MPV0 ) THEN
482 CALL CGEMV( 'conjugate transpose', MPV, NQC2,
483 $ ONE, C( IOFFC2 ), LDC, WORK, 1,
484 $ ZERO, WORK( IPW ), 1 )
485 ELSE
486 CALL CLASET( 'all', NQC2, 1, ZERO, ZERO,
487 $ WORK( IPW ), MAX( 1, NQC2 ) )
488 END IF
489.EQ. IF( MYROWICROW1 )
490 $ CALL CAXPY( NQC2, ONE, C( IOFFC1 ), LDC,
491 $ WORK( IPW ), MAX( 1, NQC2 ) )
492*
493 CALL CGSUM2D( ICTXT, 'columnwise', ' ', NQC2, 1,
494 $ WORK( IPW ), MAX( 1, NQC2 ),
495 $ RDEST, MYCOL )
496*
497* sub( C ) := sub( C ) - v * w'
498*
499.EQ. IF( MYROWICROW1 )
500 $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ),
501 $ MAX( 1, NQC2 ), C( IOFFC1 ),
502 $ LDC )
503 CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1,
504 $ WORK( IPW ), 1, C( IOFFC2 ), LDC )
505 END IF
506*
507 END IF
508*
509 END IF
510*
511 END IF
512*
513 ELSE
514*
515* sub( C ) is a proper distributed matrix
516*
517.EQ. IF( DESCV( M_ )INCV ) THEN
518*
519* Transpose and broadcast row vector V (ICOFFV=IROFFC2)
520*
521 IPW = MPV+1
522 CALL PBCTRNV( ICTXT, 'rowwise', 'transpose', M,
523 $ DESCV( NB_ ), IROFFC2, V( IOFFV ), LDV,
524 $ ZERO,
525 $ WORK, 1, IVROW, IVCOL, ICROW2, -1,
526 $ WORK( IPW ) )
527*
528* Perform the local computation within a process column
529*
530.EQ. IF( MYROWIVROW ) THEN
531*
532 CALL CGEBS2D( ICTXT, 'columnwise', ' ', 1, 1,
533 $ TAU( IIV ), 1 )
534 TAULOC( 1 ) = CONJG( TAU( IIV ) )
535*
536 ELSE
537*
538 CALL CGEBR2D( ICTXT, 'columnwise', ' ', 1, 1, TAULOC,
539 $ 1, IVROW, MYCOL )
540 TAULOC( 1 ) = CONJG( TAULOC( 1 ) )
541*
542 END IF
543*
544.NE. IF( TAULOC( 1 )ZERO ) THEN
545*
546* w := sub( C )' * v
547*
548.GT. IF( MPV0 ) THEN
549 CALL CGEMV( 'conjugate transpose', MPV, NQC2, ONE,
550 $ C( IOFFC2 ), LDC, WORK, 1, ZERO,
551 $ WORK( IPW ), 1 )
552 ELSE
553 CALL CLASET( 'all', NQC2, 1, ZERO, ZERO,
554 $ WORK( IPW ), MAX( 1, NQC2 ) )
555 END IF
556.EQ. IF( MYROWICROW1 )
557 $ CALL CAXPY( NQC2, ONE, C( IOFFC1 ), LDC,
558 $ WORK( IPW ), MAX( 1, NQC2 ) )
559*
560 CALL CGSUM2D( ICTXT, 'columnwise', ' ', NQC2, 1,
561 $ WORK( IPW ), MAX( 1, NQC2 ), RDEST,
562 $ MYCOL )
563*
564* sub( C ) := sub( C ) - v * w'
565*
566.EQ. IF( MYROWICROW1 )
567 $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ),
568 $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC )
569 CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1,
570 $ WORK( IPW ), 1, C( IOFFC2 ), LDC )
571 END IF
572*
573 ELSE
574*
575* Broadcast column vector V
576*
577 CALL PB_TOPGET( ICTXT, 'broadcast', 'rowwise', ROWBTOP )
578.EQ. IF( MYCOLIVCOL ) THEN
579*
580 IPW = MPV+1
581 CALL CCOPY( MPV, V( IOFFV ), 1, WORK, 1 )
582 WORK( IPW ) = TAU( JJV )
583 CALL CGEBS2D( ICTXT, 'rowwise', ROWBTOP, IPW, 1,
584 $ WORK, IPW )
585 TAULOC( 1 ) = CONJG( TAU( JJV ) )
586*
587 ELSE
588*
589 IPW = MPV+1
590 CALL CGEBR2D( ICTXT, 'rowwise', ROWBTOP, IPW, 1, WORK,
591 $ IPW, MYROW, IVCOL )
592 TAULOC( 1 ) = CONJG( WORK( IPW ) )
593*
594 END IF
595*
596.NE. IF( TAULOC( 1 )ZERO ) THEN
597*
598* w := sub( C )' * v
599*
600.GT. IF( MPV0 ) THEN
601 CALL CGEMV( 'conjugate transpose', MPV, NQC2, ONE,
602 $ C( IOFFC2 ), LDC, WORK, 1, ZERO,
603 $ WORK( IPW ), 1 )
604 ELSE
605 CALL CLASET( 'all', NQC2, 1, ZERO, ZERO,
606 $ WORK( IPW ), MAX( 1, NQC2 ) )
607 END IF
608.EQ. IF( MYROWICROW1 )
609 $ CALL CAXPY( NQC2, ONE, C( IOFFC1 ), LDC,
610 $ WORK( IPW ), MAX( 1, NQC2 ) )
611*
612 CALL CGSUM2D( ICTXT, 'columnwise', ' ', NQC2, 1,
613 $ WORK( IPW ), MAX( 1, NQC2 ), RDEST,
614 $ MYCOL )
615*
616* sub( C ) := sub( C ) - v * w'
617*
618.EQ. IF( MYROWICROW1 )
619 $ CALL CAXPY( NQC2, -TAULOC( 1 ), WORK( IPW ),
620 $ MAX( 1, NQC2 ), C( IOFFC1 ), LDC )
621 CALL CGERC( MPV, NQC2, -TAULOC( 1 ), WORK, 1,
622 $ WORK( IPW ), 1, C( IOFFC2 ), LDC )
623 END IF
624*
625 END IF
626*
627 END IF
628*
629 ELSE
630*
631 IF( CCBLCK ) THEN
632 RDEST = MYROW
633 ELSE
634 RDEST = -1
635 END IF
636*
637 IF( CRBLCK ) THEN
638*
639* sub( C ) is distributed over a process row
640*
641.EQ. IF( DESCV( M_ )INCV ) THEN
642*
643* V is a row vector
644*
645.EQ. IF( IVROWICROW2 ) THEN
646*
647* Perform the local computation within a process row
648*
649.EQ. IF( MYROWICROW2 ) THEN
650*
651 TAULOC( 1 ) = CONJG( TAU( IIV ) )
652*
653.NE. IF( TAULOC( 1 )ZERO ) THEN
654*
655* w := sub( C ) * v
656*
657.GT. IF( NQV0 ) THEN
658 CALL CGEMV( 'no transpose', MPC2, NQV, ONE,
659 $ C( IOFFC2 ), LDC, V( IOFFV ),
660 $ LDV, ZERO, WORK, 1 )
661 ELSE
662 CALL CLASET( 'all', MPC2, 1, ZERO, ZERO,
663 $ WORK, MAX( 1, MPC2 ) )
664 END IF
665.EQ. IF( MYCOLICCOL1 )
666 $ CALL CAXPY( MPC2, ONE, C( IOFFC1 ), 1,
667 $ WORK, 1 )
668*
669 CALL CGSUM2D( ICTXT, 'rowwise', ' ', MPC2, 1,
670 $ WORK, MAX( 1, MPC2 ), RDEST,
671 $ ICCOL2 )
672*
673.EQ. IF( MYCOLICCOL1 )
674 $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK, 1,
675 $ C( IOFFC1 ), 1 )
676*
677* sub( C ) := sub( C ) - w * v'
678*
679 CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK, 1,
680 $ V( IOFFV ), LDV, C( IOFFC2 ), LDC )
681 END IF
682*
683 END IF
684*
685 ELSE
686*
687* Send V and TAU to the process row ICROW2
688*
689.EQ. IF( MYROWIVROW ) THEN
690*
691 IPW = NQV+1
692 CALL CCOPY( NQV, V( IOFFV ), LDV, WORK, 1 )
693 WORK( IPW ) = TAU( IIV )
694 CALL CGESD2D( ICTXT, IPW, 1, WORK, IPW, ICROW2,
695 $ MYCOL )
696*
697.EQ. ELSE IF( MYROWICROW2 ) THEN
698*
699 IPW = NQV+1
700 CALL CGERV2D( ICTXT, IPW, 1, WORK, IPW, IVROW,
701 $ MYCOL )
702 TAULOC( 1 ) = CONJG( WORK( IPW ) )
703*
704.NE. IF( TAULOC( 1 )ZERO ) THEN
705*
706* w := sub( C ) * v
707*
708.GT. IF( NQV0 ) THEN
709 CALL CGEMV( 'no transpose', MPC2, NQV, ONE,
710 $ C( IOFFC2 ), LDC, WORK, 1, ZERO,
711 $ WORK( IPW ), 1 )
712 ELSE
713 CALL CLASET( 'all', MPC2, 1, ZERO, ZERO,
714 $ WORK( IPW ), MAX( 1, MPC2 ) )
715 END IF
716.EQ. IF( MYCOLICCOL1 )
717 $ CALL CAXPY( MPC2, ONE, C( IOFFC1 ), 1,
718 $ WORK( IPW ), 1 )
719 CALL CGSUM2D( ICTXT, 'rowwise', ' ', MPC2, 1,
720 $ WORK( IPW ), MAX( 1, MPC2 ),
721 $ RDEST, ICCOL2 )
722.EQ. IF( MYCOLICCOL1 )
723 $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ),
724 $ 1, C( IOFFC1 ), 1 )
725*
726* sub( C ) := sub( C ) - w * v'
727*
728 CALL CGERC( MPC2, NQV, -TAULOC( 1 ),
729 $ WORK( IPW ), 1, WORK, 1,
730 $ C( IOFFC2 ), LDC )
731 END IF
732*
733 END IF
734*
735 END IF
736*
737 ELSE
738*
739* Transpose column vector V (IROFFV = ICOFFC2)
740*
741 IPW = NQV+1
742 CALL PBCTRNV( ICTXT, 'columnwise', 'transpose', N,
743 $ DESCV( MB_ ), ICOFFC2, V( IOFFV ), 1, ZERO,
744 $ WORK, 1, IVROW, IVCOL, ICROW2, ICCOL2,
745 $ WORK( IPW ) )
746*
747* Perform the local computation within a process column
748*
749.EQ. IF( MYROWICROW2 ) THEN
750*
751.EQ. IF( MYCOLIVCOL ) THEN
752*
753 CALL CGEBS2D( ICTXT, 'rowwise', ' ', 1, 1,
754 $ TAU( JJV ), 1 )
755 TAULOC( 1 ) = CONJG( TAU( JJV ) )
756*
757 ELSE
758*
759 CALL CGEBR2D( ICTXT, 'rowwise', ' ', 1, 1, TAULOC,
760 $ 1, MYROW, IVCOL )
761 TAULOC( 1 ) = CONJG( TAULOC( 1 ) )
762*
763 END IF
764*
765.NE. IF( TAULOC( 1 )ZERO ) THEN
766*
767* w := sub( C ) * v
768*
769.GT. IF( NQV0 ) THEN
770 CALL CGEMV( 'no transpose', MPC2, NQV, ONE,
771 $ C( IOFFC2 ), LDC, WORK, 1, ZERO,
772 $ WORK( IPW ), 1 )
773 ELSE
774 CALL CLASET( 'all', MPC2, 1, ZERO, ZERO,
775 $ WORK( IPW ), MAX( 1, MPC2 ) )
776 END IF
777.EQ. IF( MYCOLICCOL1 )
778 $ CALL CAXPY( MPC2, ONE, C( IOFFC1 ), 1,
779 $ WORK( IPW ), 1 )
780 CALL CGSUM2D( ICTXT, 'rowwise', ' ', MPC2, 1,
781 $ WORK( IPW ), MAX( 1, MPC2 ), RDEST,
782 $ ICCOL2 )
783.EQ. IF( MYCOLICCOL1 )
784 $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1,
785 $ C( IOFFC1 ), 1 )
786*
787* sub( C ) := sub( C ) - w * v'
788*
789 CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ),
790 $ 1, WORK, 1, C( IOFFC2 ), LDC )
791 END IF
792*
793 END IF
794*
795 END IF
796*
797 ELSE
798*
799* sub( C ) is a proper distributed matrix
800*
801.EQ. IF( DESCV( M_ )INCV ) THEN
802*
803* Broadcast row vector V
804*
805 CALL PB_TOPGET( ICTXT, 'broadcast', 'columnwise',
806 $ COLBTOP )
807.EQ. IF( MYROWIVROW ) THEN
808*
809 IPW = NQV+1
810 CALL CCOPY( NQV, V( IOFFV ), LDV, WORK, 1 )
811 WORK( IPW ) = TAU( IIV )
812 CALL CGEBS2D( ICTXT, 'columnwise', COLBTOP, IPW, 1,
813 $ WORK, IPW )
814 TAULOC( 1 ) = CONJG( TAU( IIV ) )
815*
816 ELSE
817*
818 IPW = NQV+1
819 CALL CGEBR2D( ICTXT, 'columnwise', COLBTOP, IPW, 1,
820 $ WORK, IPW, IVROW, MYCOL )
821 TAULOC( 1 ) = CONJG( WORK( IPW ) )
822*
823 END IF
824*
825.NE. IF( TAULOC( 1 )ZERO ) THEN
826*
827* w := sub( C ) * v
828*
829.GT. IF( NQV0 ) THEN
830 CALL CGEMV( 'no transpose', MPC2, NQV, ONE,
831 $ C( IOFFC2 ), LDC, WORK, 1, ZERO,
832 $ WORK( IPW ), 1 )
833 ELSE
834 CALL CLASET( 'all', MPC2, 1, ZERO, ZERO,
835 $ WORK( IPW ), MAX( 1, MPC2 ) )
836 END IF
837.EQ. IF( MYCOLICCOL1 )
838 $ CALL CAXPY( MPC2, ONE, C( IOFFC1 ), 1,
839 $ WORK( IPW ), 1 )
840*
841 CALL CGSUM2D( ICTXT, 'rowwise', ' ', MPC2, 1,
842 $ WORK( IPW ), MAX( 1, MPC2 ), RDEST,
843 $ ICCOL2 )
844.EQ. IF( MYCOLICCOL1 )
845 $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1,
846 $ C( IOFFC1 ), 1 )
847*
848* sub( C ) := sub( C ) - w * v'
849*
850 CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1,
851 $ WORK, 1, C( IOFFC2 ), LDC )
852 END IF
853*
854 ELSE
855*
856* Transpose and broadcast column vector V (ICOFFC2=IROFFV)
857*
858 IPW = NQV+1
859 CALL PBCTRNV( ICTXT, 'columnwise', 'transpose', N,
860 $ DESCV( MB_ ), ICOFFC2, V( IOFFV ), 1, ZERO,
861 $ WORK, 1, IVROW, IVCOL, -1, ICCOL2,
862 $ WORK( IPW ) )
863*
864* Perform the local computation within a process column
865*
866.EQ. IF( MYCOLIVCOL ) THEN
867*
868 CALL CGEBS2D( ICTXT, 'rowwise', ' ', 1, 1, TAU( JJV ),
869 $ 1 )
870 TAULOC( 1 ) = CONJG( TAU( JJV ) )
871*
872 ELSE
873*
874 CALL CGEBR2D( ICTXT, 'rowwise', ' ', 1, 1,
875 $ TAULOC( 1 ), 1, MYROW, IVCOL )
876 TAULOC( 1 ) = CONJG( TAULOC( 1 ) )
877*
878 END IF
879*
880.NE. IF( TAULOC( 1 )ZERO ) THEN
881*
882* w := sub( C ) * v
883*
884.GT. IF( NQV0 ) THEN
885 CALL CGEMV( 'no transpose', MPC2, NQV, ONE,
886 $ C( IOFFC2 ), LDC, WORK, 1, ZERO,
887 $ WORK( IPW ), 1 )
888 ELSE
889 CALL CLASET( 'all', MPC2, 1, ZERO, ZERO,
890 $ WORK( IPW ), MAX( 1, MPC2 ) )
891 END IF
892.EQ. IF( MYCOLICCOL1 )
893 $ CALL CAXPY( MPC2, ONE, C( IOFFC1 ), 1,
894 $ WORK( IPW ), 1 )
895 CALL CGSUM2D( ICTXT, 'rowwise', ' ', MPC2, 1,
896 $ WORK( IPW ), MAX( 1, MPC2 ), RDEST,
897 $ ICCOL2 )
898.EQ. IF( MYCOLICCOL1 )
899 $ CALL CAXPY( MPC2, -TAULOC( 1 ), WORK( IPW ), 1,
900 $ C( IOFFC1 ), 1 )
901*
902* sub( C ) := sub( C ) - w * v'
903*
904 CALL CGERC( MPC2, NQV, -TAULOC( 1 ), WORK( IPW ), 1,
905 $ WORK, 1, C( IOFFC2 ), LDC )
906 END IF
907*
908 END IF
909*
910 END IF
911*
912 END IF
913*
914 RETURN
915*
916* End of PCLARZC
917*
918 END
claset
subroutine claset(uplo, m, n, alpha, beta, a, lda)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition claset.f:106
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
cgemv
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
Definition cgemv.f:158
cgerc
subroutine cgerc(m, n, alpha, x, incx, y, incy, a, lda)
CGERC
Definition cgerc.f:130
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
cgebs2d
subroutine cgebs2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1062
cgebr2d
subroutine cgebr2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1103
infog2l
subroutine infog2l(grindx, gcindx, desc, nprow, npcol, myrow, mycol, lrindx, lcindx, rsrc, csrc)
Definition mpi.f:937
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition mpi.f:786
pbctrnv
subroutine pbctrnv(icontxt, xdist, trans, n, nb, nz, x, incx, beta, y, incy, ixrow, ixcol, iyrow, iycol, work)
Definition pbctrnv.f:4
pclarzc
subroutine pclarzc(side, m, n, l, v, iv, jv, descv, incv, tau, c, ic, jc, descc, work)
Definition pclarzc.f:3