Routine: PZLARFB()  File: SRC\pzlarfb.f

 
 
# lines: 889
  # code: 889
  # comment: 0
  # blank:0
# Variables:89
# Callers:13
# Callings:0
# Words:504
# Keywords:286
 

 

..
     .. Array Arguments ..
     ..
  Purpose
  =======
  PZLARFB applies a complex block reflector Q or its conjugate
  transpose Q**H to a complex M-by-N distributed matrix sub( C )
  denoting C(IC:IC+M-1,JC:JC+N-1), from the left or the right.
  Notes
  =====
  Each global data object is described by an associated description
  vector.  This vector stores the information required to establish
  the mapping between an object element and its corresponding process
  and memory location.
  Let A be a generic term for any 2D block cyclicly distributed array.
  Such a global array has an associated description vector DESCA.
  In the following comments, the character _ should be read as
  "of the global array".
  NOTATION        STORED IN      EXPLANATION
  --------------- -------------- --------------------------------------
  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
                                 DTYPE_A = 1.
  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
                                 the BLACS process grid A is distribu-
                                 ted over. The context itself is glo-
                                 bal, but the handle (the integer
                                 value) may vary.
  M_A    (global) DESCA( M_ )    The number of rows in the global
                                 array A.
  N_A    (global) DESCA( N_ )    The number of columns in the global
                                 array A.
  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
                                 the rows of the array.
  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
                                 the columns of the array.
  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
                                 row of the array A is distributed.
  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
                                 first column of the array A is
                                 distributed.
  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
  Let K be the number of rows or columns of a distributed matrix,
  and assume that its process grid has dimension p x q.
  LOCr( K ) denotes the number of elements of K that a process
  would receive if K were distributed over the p processes of its
  process column.
  Similarly, LOCc( K ) denotes the number of elements of K that a
  process would receive if K were distributed over the q processes of
  its process row.
  The values of LOCr() and LOCc() may be determined via a call to the
  ScaLAPACK tool function, NUMROC:
          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
  An upper bound for these quantities may be computed by:
          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
  Arguments
  =========
  SIDE    (global input) CHARACTER
          = 'L': apply Q or Q**H from the Left;
          = 'R': apply Q or Q**H from the Right.
  TRANS   (global input) CHARACTER
          = 'N':  No transpose, apply Q;
          = 'C':  Conjugate transpose, apply Q**H.
  DIRECT  (global input) CHARACTER
          Indicates how Q is formed from a product of elementary
          reflectors
          = 'F': Q = H(1) H(2) . . . H(k) (Forward)
          = 'B': Q = H(k) . . . H(2) H(1) (Backward)
  STOREV  (global input) CHARACTER
          Indicates how the vectors which define the elementary
          reflectors are stored:
          = 'C': Columnwise
          = 'R': Rowwise
  M       (global input) INTEGER
          The number of rows to be operated on i.e the number of rows
          of the distributed submatrix sub( C ). M >= 0.
  N       (global input) INTEGER
          The number of columns to be operated on i.e the number of
          columns of the distributed submatrix sub( C ). N >= 0.
  K       (global input) INTEGER
          The order of the matrix T (= the number of elementary
          reflectors whose product defines the block reflector).
  V       (local input) COMPLEX*16 pointer into the local memory
          to an array of dimension ( LLD_V, LOCc(JV+K-1) ) if
          STOREV = 'C', ( LLD_V, LOCc(JV+M-1)) if STOREV = 'R' and
          SIDE = 'L', ( LLD_V, LOCc(JV+N-1) ) if STOREV = 'R' and
          SIDE = 'R'. It contains the local pieces of the distributed
          vectors V representing the Householder transformation.
          See further details.
          If STOREV = 'C' and SIDE = 'L', LLD_V >= MAX(1,LOCr(IV+M-1));
          if STOREV = 'C' and SIDE = 'R', LLD_V >= MAX(1,LOCr(IV+N-1));
          if STOREV = 'R', LLD_V >= LOCr(IV+K-1).
  IV      (global input) INTEGER
          The row index in the global array V indicating the first
          row of sub( V ).
  JV      (global input) INTEGER
          The column index in the global array V indicating the
          first column of sub( V ).
  DESCV   (global and local input) INTEGER array of dimension DLEN_.
          The array descriptor for the distributed matrix V.
  T       (local input) COMPLEX*16 array, dimension MB_V by MB_V
          if STOREV = 'R' and NB_V by NB_V if STOREV = 'C'. The trian-
          gular matrix T in the representation of the block reflector.
  C       (local input/local output) COMPLEX*16 pointer into the
          local memory to an array of dimension (LLD_C,LOCc(JC+N-1)).
          On entry, the M-by-N distributed matrix sub( C ). On exit,
          sub( C ) is overwritten by Q*sub( C ) or Q'*sub( C ) or
          sub( C )*Q or sub( C )*Q'.
  IC      (global input) INTEGER
          The row index in the global array C indicating the first
          row of sub( C ).
  JC      (global input) INTEGER
          The column index in the global array C indicating the
          first column of sub( C ).
  DESCC   (global and local input) INTEGER array of dimension DLEN_.
          The array descriptor for the distributed matrix C.
  WORK    (local workspace) COMPLEX*16 array, dimension (LWORK)
          If STOREV = 'C',
            if SIDE = 'L',
              LWORK >= ( NqC0 + MpC0 ) * K
            else if SIDE = 'R',
              LWORK >= ( NqC0 + MAX( NpV0 + NUMROC( NUMROC( N+ICOFFC,
                         NB_V, 0, 0, NPCOL ), NB_V, 0, 0, LCMQ ),
                         MpC0 ) ) * K
            end if
          else if STOREV = 'R',
            if SIDE = 'L',
              LWORK >= ( MpC0 + MAX( MqV0 + NUMROC( NUMROC( M+IROFFC,
                         MB_V, 0, 0, NPROW ), MB_V, 0, 0, LCMP ),
                         NqC0 ) ) * K
            else if SIDE = 'R',
              LWORK >= ( MpC0 + NqC0 ) * K
            end if
          end if
          where LCMQ = LCM / NPCOL with LCM = ICLM( NPROW, NPCOL ),
          IROFFV = MOD( IV-1, MB_V ), ICOFFV = MOD( JV-1, NB_V ),
          IVROW = INDXG2P( IV, MB_V, MYROW, RSRC_V, NPROW ),
          IVCOL = INDXG2P( JV, NB_V, MYCOL, CSRC_V, NPCOL ),
          MqV0 = NUMROC( M+ICOFFV, NB_V, MYCOL, IVCOL, NPCOL ),
          NpV0 = NUMROC( N+IROFFV, MB_V, MYROW, IVROW, NPROW ),
          IROFFC = MOD( IC-1, MB_C ), ICOFFC = MOD( JC-1, NB_C ),
          ICROW = INDXG2P( IC, MB_C, MYROW, RSRC_C, NPROW ),
          ICCOL = INDXG2P( JC, NB_C, MYCOL, CSRC_C, NPCOL ),
          MpC0 = NUMROC( M+IROFFC, MB_C, MYROW, ICROW, NPROW ),
          NpC0 = NUMROC( N+ICOFFC, MB_C, MYROW, ICROW, NPROW ),
          NqC0 = NUMROC( N+ICOFFC, NB_C, MYCOL, ICCOL, NPCOL ),
          ILCM, INDXG2P and NUMROC are ScaLAPACK tool functions;
          MYROW, MYCOL, NPROW and NPCOL can be determined by calling
          the subroutine BLACS_GRIDINFO.
  Alignment requirements
  ======================
  The distributed submatrices V(IV:*, JV:*) and C(IC:IC+M-1,JC:JC+N-1)
  must verify some alignment properties, namely the following
  expressions should be true:
  If STOREV = 'Columnwise'
    If SIDE = 'Left',
      ( MB_V.EQ.MB_C .AND. IROFFV.EQ.IROFFC .AND. IVROW.EQ.ICROW )
    If SIDE = 'Right',
      ( MB_V.EQ.NB_C .AND. IROFFV.EQ.ICOFFC )
  else if STOREV = 'Rowwise'
    If SIDE = 'Left',
      ( NB_V.EQ.MB_C .AND. ICOFFV.EQ.IROFFC )
    If SIDE = 'Right',
      ( NB_V.EQ.NB_C .AND. ICOFFV.EQ.ICOFFC .AND. IVCOL.EQ.ICCOL )
  end if
  =====================================================================
     .. Parameters ..

 
Display dynamic version Find AutoScroll Reload FontSize: - + Hide Comments Hide Blanks Frame FullScreen MailPrint

 
001        SUBROUTINE PZLARFB( SIDE , TRANS , DIRECT , STOREV , M , N , K , V , IV ,
002       $JV , DESCV , T , C , IC , JC , DESCC , WORK )
003  
004  *     -- ScaLAPACK auxiliary routine(version 1.7) --
005  *     University of Tennessee , Knoxville , Oak Ridge National Laboratory ,
006  *     and University of California , Berkeley.
007  *     May 1 , 1997
008  
009  *     .. Scalar Arguments ..
010        CHARACTER SIDE , TRANS , DIRECT , STOREV
011        INTEGER IC , IV , JC , JV , K , M , N
012        INTEGER BLOCK_CYCLIC_2D , CSRC_ , CTXT_ , DLEN_ , DTYPE_ ,
013       $LLD_ , MB_ , M_ , NB_ , N_ , RSRC_
014        PARAMETER( BLOCK_CYCLIC_2D = 1 , DLEN_ = 9 , DTYPE_ = 1 ,
015       $CTXT_ = 2 , M_ = 3 , N_ = 4 , MB_ = 5 , NB_ = 6 ,
016       $RSRC_ = 7 , CSRC_ = 8 , LLD_ = 9 )
017        COMPLEX*16 ONE , ZERO
018        PARAMETER( ONE =( 1.0D + 0 , 0.0D + 0 ) ,
019       $ZERO =( 0.0D + 0 , 0.0D + 0 ) )
020  *     ..
021  *     .. Local Scalars ..
022        LOGICAL FORWARD
023        CHARACTER COLBTOP , ROWBTOP , TRANST , UPLO
024        INTEGER HEIGHT , IBASE , ICCOL , ICOFFC , ICOFFV , ICROW ,
025       $ICTXT , II , IIBEG , IIC , IIEND , IINXT , IIV ,
026       $ILASTCOL , ILASTROW , ILEFT , IOFF , IOFFC , IOFFV ,
027       $IPT , IPV , IPW , IPW1 , IRIGHT , IROFFC , IROFFV ,
028       $ITOP , IVCOL , IVROW , JJ , JJBEG , JJC , JJEND ,
029       $JJNXT , JJV , KP , KQ , LDC , LDV , LV , LW , MBV , MPC ,
030       $MPC0 , MQV , MQV0 , MYCOL , MYDIST , MYROW , NBV ,
031       $NPV , NPV0 , NPCOL , NPROW , NQC , NQC0 , WIDE
032  *     ..
033  *     .. External Subroutines ..
034        EXTERNAL BLACS_GRIDINFO , INFOG1L , INFOG2L , PB_TOPGET ,
035       $PBZTRAN , ZGEBR2D , ZGEBS2D , ZGEMM ,
036       $ZGSUM2D , ZLACPY , ZLASET , ZTRBR2D ,
037       $ZTRBS2D , ZTRMM
038  *     ..
039  *     .. Intrinsic Functions ..
040        INTRINSIC MAX , MIN , MOD
041  *     ..
042  *     .. External Functions ..
043        LOGICAL LSAME
044        INTEGER ICEIL , NUMROC
045        EXTERNAL ICEIL , LSAME , NUMROC
046  *     ..
047  *     .. Executable Statements ..
048  
049  *     Quick return if possible
050  
051        IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 )
052       $    RETURN
053  
054  *         Get grid parameters
055  
056            ICTXT = DESCC( CTXT_ )
057            CALL BLACS_GRIDINFO( ICTXT , NPROW , NPCOL , MYROW , MYCOL )
058  
059            IF( LSAME( TRANS , 'N' ) ) THEN
060                TRANST = 'C'
061            ELSE
062                TRANST = 'N'
063            END IF
064            FORWARD = LSAME( DIRECT , 'F' )
065            IF( FORWARD ) THEN
066                UPLO = 'U'
067            ELSE
068                UPLO = 'L'
069            END IF
070  
071            CALL INFOG2L( IV , JV , DESCV , NPROW , NPCOL , MYROW , MYCOL , IIV , JJV ,
072       $    IVROW , IVCOL )
073            CALL INFOG2L( IC , JC , DESCC , NPROW , NPCOL , MYROW , MYCOL , IIC , JJC ,
074       $    ICROW , ICCOL )
075            LDC = DESCC( LLD_ )
076            LDV = DESCV( LLD_ )
077            IIC = MIN( IIC , LDC )
078            IIV = MIN( IIV , LDV )
079            IROFFC = MOD( IC - 1 , DESCC( MB_ ) )
080            ICOFFC = MOD( JC - 1 , DESCC( NB_ ) )
081            MBV = DESCV( MB_ )
082            NBV = DESCV( NB_ )
083            IROFFV = MOD( IV - 1 , MBV )
084            ICOFFV = MOD( JV - 1 , NBV )
085            MPC = NUMROC( M + IROFFC , DESCC( MB_ ) , MYROW , ICROW , NPROW )
086            NQC = NUMROC( N + ICOFFC , DESCC( NB_ ) , MYCOL , ICCOL , NPCOL )
087            IF( MYCOL.EQ.ICCOL )
088       $        NQC = NQC - ICOFFC
089                IF( MYROW.EQ.ICROW )
090       $            MPC = MPC - IROFFC
091                    JJC = MIN( JJC , MAX( 1 , JJC + NQC - 1 ) )
092                    JJV = MIN( JJV , MAX( 1 , NUMROC( DESCV( N_ ) , NBV , MYCOL ,
093       $            DESCV( CSRC_ ) , NPCOL ) ) )
094                    IOFFC = IIC + ( JJC - 1 ) * LDC
095                    IOFFV = IIV + ( JJV - 1 ) * LDV
096  
097                    IF( LSAME( STOREV , 'C' ) ) THEN
098  
099  *                     V is stored columnwise
100  
101                        IF( LSAME( SIDE , 'L' ) ) THEN
102  
103  *                         Form Q*sub( C ) or Q'*sub( C )
104  
105  *                         Locally V( IOFFV ) is MPV x K , C( IOFFC ) is MPC x NQC
106  *                         WORK( IPV ) is MPC x K = V( IOFFV ) , MPC = MPV
107  *                         WORK( IPW ) is NQC x K = C( IOFFC )' * V( IOFFV )
108  
109                            IPV = 1
110                            IPW = IPV + MPC * K
111                            LV = MAX( 1 , MPC )
112                            LW = MAX( 1 , NQC )
113  
114  *                         Broadcast V to the other process columns.
115  
116                            CALL PB_TOPGET( ICTXT , 'Broadcast' , 'Rowwise' , ROWBTOP )
117                            IF( MYCOL.EQ.IVCOL ) THEN
118                                CALL ZGEBS2D( ICTXT , 'Rowwise' , ROWBTOP , MPC , K ,
119       $                        V( IOFFV ) , LDV )
120                                IF( MYROW.EQ.IVROW )
121       $                            CALL ZTRBS2D( ICTXT , 'Rowwise' , ROWBTOP , UPLO ,
122       $                            'Non unit' , K , K , T , NBV )
123                                    CALL ZLACPY( 'All' , MPC , K , V( IOFFV ) , LDV , WORK( IPV ) ,
124       $                            LV )
125                                ELSE
126                                    CALL ZGEBR2D( ICTXT , 'Rowwise' , ROWBTOP , MPC , K ,
127       $                            WORK( IPV ) , LV , MYROW , IVCOL )
128                                    IF( MYROW.EQ.IVROW )
129       $                                CALL ZTRBR2D( ICTXT , 'Rowwise' , ROWBTOP , UPLO ,
130       $                                'Non unit' , K , K , T , NBV , MYROW , IVCOL )
131                                    END IF
132  
133                                    IF( FORWARD ) THEN
134  
135  *                                     WORK(IPV) =( V1 ) where V1 is unit lower triangular ,
136  *                                     ( V2 ) zeroes upper triangular part of V1
137  
138                                        MYDIST = MOD( MYROW - IVROW + NPROW , NPROW )
139                                        ITOP = MAX( 0 , MYDIST*MBV - IROFFV )
140                                        IIBEG = IIV
141                                        IIEND = IIBEG + MPC - 1
142                                        IINXT = MIN( ICEIL( IIBEG , MBV )*MBV , IIEND )
143  
144     10 CONTINUE
145        IF( K - ITOP .GT.0 ) THEN
146            CALL ZLASET( 'Upper' , IINXT - IIBEG + 1 , K - ITOP , ZERO ,
147       $    ONE , WORK( IPV + IIBEG - IIV + ITOP*LV ) , LV )
148            MYDIST = MYDIST + NPROW
149            ITOP = MYDIST * MBV - IROFFV
150            IIBEG = IINXT + 1
151            IINXT = MIN( IINXT + MBV , IIEND )
152            GO TO 10
153        END IF
154  
155        ELSE
156  
157  *         WORK(IPV) =( V1 ) where V2 is unit upper triangular ,
158  *         ( V2 ) zeroes lower triangular part of V2
159  
160            JJ = JJV
161            IOFF = MOD( IV + M - K - 1 , MBV )
162            CALL INFOG1L( IV + M - K , MBV , NPROW , MYROW , DESCV( RSRC_ ) ,
163       $    II , ILASTROW )
164            KP = NUMROC( K + IOFF , MBV , MYROW , ILASTROW , NPROW )
165            IF( MYROW.EQ.ILASTROW )
166       $        KP = KP - IOFF
167                MYDIST = MOD( MYROW - ILASTROW + NPROW , NPROW )
168                ITOP = MYDIST * MBV - IOFF
169                IBASE = MIN( ITOP + MBV , K )
170                ITOP = MIN( MAX( 0 , ITOP ) , K )
171  
172     20 CONTINUE
173        IF( JJ.LE.( JJV + K - 1 ) ) THEN
174            HEIGHT = IBASE - ITOP
175            CALL ZLASET( 'All' , KP , ITOP - JJ + JJV , ZERO , ZERO ,
176       $    WORK( IPV + II - IIV + (JJ - JJV)*LV ) , LV )
177            CALL ZLASET( 'Lower' , KP , HEIGHT , ZERO , ONE ,
178       $    WORK( IPV + II - IIV + ITOP*LV ) , LV )
179            KP = MAX( 0 , KP - HEIGHT )
180            II = II + HEIGHT
181            JJ = JJV + IBASE
182            MYDIST = MYDIST + NPROW
183            ITOP = MYDIST * MBV - IOFF
184            IBASE = MIN( ITOP + MBV , K )
185            ITOP = MIN( ITOP , K )
186            GO TO 20
187        END IF
188  
189        END IF
190  
191  *     WORK( IPW ) = C( IOFFC )' * V(NQC x MPC x K) -> NQC x K
192  
193        IF( MPC.GT.0 ) THEN
194            CALL ZGEMM( 'Conjugate transpose' , 'No transpose' , NQC ,
195       $    K , MPC , ONE , C( IOFFC ) , LDC , WORK( IPV ) , LV ,
196       $    ZERO , WORK( IPW ) , LW )
197        ELSE
198            CALL ZLASET( 'All' , NQC , K , ZERO , ZERO , WORK( IPW ) , LW )
199        END IF
200  
201        CALL ZGSUM2D( ICTXT , 'Columnwise' , ' ' , NQC , K , WORK( IPW ) ,
202       $LW , IVROW , MYCOL )
203  
204        IF( MYROW.EQ.IVROW ) THEN
205  
206  *         WORK( IPW ) = WORK( IPW ) * T' or WORK( IPW ) * T
207  
208            CALL ZTRMM( 'Right' , UPLO , TRANST , 'Non unit' , NQC , K ,
209       $    ONE , T , NBV , WORK( IPW ) , LW )
210            CALL ZGEBS2D( ICTXT , 'Columnwise' , ' ' , NQC , K ,
211       $    WORK( IPW ) , LW )
212        ELSE
213            CALL ZGEBR2D( ICTXT , 'Columnwise' , ' ' , NQC , K ,
214       $    WORK( IPW ) , LW , IVROW , MYCOL )
215        END IF
216  
217  *     C C - V * W'
218  *     C( IOFFC ) = C( IOFFC ) - WORK( IPV ) * WORK( IPW )'
219  *     MPC x NQC MPC x K K x NQC
220  
221        CALL ZGEMM( 'No transpose' , 'Conjugate transpose' , MPC , NQC ,
222       $K , - ONE , WORK( IPV ) , LV , WORK( IPW ) , LW , ONE ,
223       $C( IOFFC ) , LDC )
224  
225        ELSE
226  
227  *         Form sub( C )*Q or sub( C )*Q'
228  
229  *         ICOFFC = IROFFV is required by the current transposition
230  *         routine PBZTRAN
231  
232            NPV0 = NUMROC( N + IROFFV , MBV , MYROW , IVROW , NPROW )
233            IF( MYROW.EQ.IVROW ) THEN
234                NPV = NPV0 - IROFFV
235            ELSE
236                NPV = NPV0
237            END IF
238            IF( MYCOL.EQ.ICCOL ) THEN
239                NQC0 = NQC + ICOFFC
240            ELSE
241                NQC0 = NQC
242            END IF
243  
244  *         Locally V( IOFFV ) is NPV x K C( IOFFC ) is MPC x NQC
245  *         WORK( IPV ) is K x NQC0 =[ . V( IOFFV ) ]'
246  *         WORK( IPW ) is NPV0 x K =[ . V( IOFFV )' ]'
247  *         WORK( IPT ) is the workspace for PBZTRAN
248  
249            IPV = 1
250            IPW = IPV + K * NQC0
251            IPT = IPW + NPV0 * K
252            LV = MAX( 1 , K )
253            LW = MAX( 1 , NPV0 )
254  
255            IF( MYCOL.EQ.IVCOL ) THEN
256                IF( MYROW.EQ.IVROW ) THEN
257                    CALL ZLASET( 'All' , IROFFV , K , ZERO , ZERO ,
258       $            WORK( IPW ) , LW )
259                    IPW1 = IPW + IROFFV
260                    CALL ZLACPY( 'All' , NPV , K , V( IOFFV ) , LDV ,
261       $            WORK( IPW1 ) , LW )
262                ELSE
263                    IPW1 = IPW
264                    CALL ZLACPY( 'All' , NPV , K , V( IOFFV ) , LDV ,
265       $            WORK( IPW1 ) , LW )
266                END IF
267  
268                IF( FORWARD ) THEN
269  
270  *                 WORK(IPW) =( . V1' V2' )' where V1 is unit lower
271  *                 triangular , zeroes upper triangular part of V1
272  
273                    MYDIST = MOD( MYROW - IVROW + NPROW , NPROW )
274                    ITOP = MAX( 0 , MYDIST*MBV - IROFFV )
275                    IIBEG = IIV
276                    IIEND = IIBEG + NPV - 1
277                    IINXT = MIN( ICEIL( IIBEG , MBV )*MBV , IIEND )
278  
279     30 CONTINUE
280        IF(( K - ITOP ).GT.0 ) THEN
281            CALL ZLASET( 'Upper' , IINXT - IIBEG + 1 , K - ITOP , ZERO ,
282       $    ONE , WORK( IPW1 + IIBEG - IIV + ITOP*LW ) ,
283       $    LW )
284            MYDIST = MYDIST + NPROW
285            ITOP = MYDIST * MBV - IROFFV
286            IIBEG = IINXT + 1
287            IINXT = MIN( IINXT + MBV , IIEND )
288            GO TO 30
289        END IF
290  
291        ELSE
292  
293  *         WORK( IPW ) =( . V1' V2' )' where V2 is unit upper
294  *         triangular , zeroes lower triangular part of V2.
295  
296            JJ = JJV
297            CALL INFOG1L( IV + N - K , MBV , NPROW , MYROW ,
298       $    DESCV( RSRC_ ) , II , ILASTROW )
299            IOFF = MOD( IV + N - K - 1 , MBV )
300            KP = NUMROC( K + IOFF , MBV , MYROW , ILASTROW , NPROW )
301            IF( MYROW.EQ.ILASTROW )
302       $        KP = KP - IOFF
303                MYDIST = MOD( MYROW - ILASTROW + NPROW , NPROW )
304                ITOP = MYDIST * MBV - IOFF
305                IBASE = MIN( ITOP + MBV , K )
306                ITOP = MIN( MAX( 0 , ITOP ) , K )
307  
308     40 CONTINUE
309        IF( JJ.LE.( JJV + K - 1 ) ) THEN
310            HEIGHT = IBASE - ITOP
311            CALL ZLASET( 'All' , KP , ITOP - JJ + JJV , ZERO , ZERO ,
312       $    WORK( IPW1 + II - IIV + (JJ - JJV)*LW ) , LW )
313            CALL ZLASET( 'Lower' , KP , HEIGHT , ZERO , ONE ,
314       $    WORK( IPW1 + II - IIV + ITOP*LW ) , LW )
315            KP = MAX( 0 , KP - HEIGHT )
316            II = II + HEIGHT
317            JJ = JJV + IBASE
318            MYDIST = MYDIST + NPROW
319            ITOP = MYDIST * MBV - IOFF
320            IBASE = MIN( ITOP + MBV , K )
321            ITOP = MIN( ITOP , K )
322            GO TO 40
323        END IF
324        END IF
325        END IF
326  
327        CALL PBZTRAN( ICTXT , 'Columnwise' , 'Conjugate transpose' ,
328       $N + IROFFV , K , MBV , WORK( IPW ) , LW , ZERO ,
329       $WORK( IPV ) , LV , IVROW , IVCOL , - 1 , ICCOL ,
330       $WORK( IPT ) )
331  
332  *     WORK( IPV ) =( . V' ) -> WORK( IPV ) = V' is K x NQC
333  
334        IF( MYCOL.EQ.ICCOL )
335       $    IPV = IPV + ICOFFC * LV
336  
337  *         WORK( IPW ) becomes MPC x K = C( IOFFC ) * V
338  *         WORK( IPW ) = C( IOFFC ) * V(MPC x NQC x K) -> MPC x K
339  
340            LW = MAX( 1 , MPC )
341  
342            IF( NQC.GT.0 ) THEN
343                CALL ZGEMM( 'No transpose' , 'Conjugate transpose' , MPC ,
344       $        K , NQC , ONE , C( IOFFC ) , LDC , WORK( IPV ) ,
345       $        LV , ZERO , WORK( IPW ) , LW )
346            ELSE
347                CALL ZLASET( 'All' , MPC , K , ZERO , ZERO , WORK( IPW ) , LW )
348            END IF
349  
350            CALL ZGSUM2D( ICTXT , 'Rowwise' , ' ' , MPC , K , WORK( IPW ) ,
351       $    LW , MYROW , IVCOL )
352  
353  *         WORK( IPW ) = WORK( IPW ) * T' or WORK( IPW ) * T
354  
355            IF( MYCOL.EQ.IVCOL ) THEN
356                IF( MYROW.EQ.IVROW ) THEN
357  
358  *                 Broadcast the block reflector to the other rows.
359  
360                    CALL ZTRBS2D( ICTXT , 'Columnwise' , ' ' , UPLO ,
361       $            'Non unit' , K , K , T , NBV )
362                ELSE
363                    CALL ZTRBR2D( ICTXT , 'Columnwise' , ' ' , UPLO ,
364       $            'Non unit' , K , K , T , NBV , IVROW , MYCOL )
365                END IF
366                CALL ZTRMM( 'Right' , UPLO , TRANS , 'Non unit' , MPC , K ,
367       $        ONE , T , NBV , WORK( IPW ) , LW )
368  
369                CALL ZGEBS2D( ICTXT , 'Rowwise' , ' ' , MPC , K , WORK( IPW ) ,
370       $        LW )
371            ELSE
372                CALL ZGEBR2D( ICTXT , 'Rowwise' , ' ' , MPC , K , WORK( IPW ) ,
373       $        LW , MYROW , IVCOL )
374            END IF
375  
376  *         C C - W * V'
377  *         C( IOFFC ) = C( IOFFC ) - WORK( IPW ) * WORK( IPV )
378  *         MPC x NQC MPC x K K x NQC
379  
380            CALL ZGEMM( 'No transpose' , 'No transpose' , MPC , NQC , K ,
381       $    - ONE , WORK( IPW ) , LW , WORK( IPV ) , LV , ONE ,
382       $    C( IOFFC ) , LDC )
383        END IF
384  
385        ELSE
386  
387  *         V is stored rowwise
388  
389            IF( LSAME( SIDE , 'L' ) ) THEN
390  
391  *             Form Q*sub( C ) or Q'*sub( C )
392  
393  *             IROFFC = ICOFFV is required by the current transposition
394  *             routine PBZTRAN
395  
396                MQV0 = NUMROC( M + ICOFFV , NBV , MYCOL , IVCOL , NPCOL )
397                IF( MYCOL.EQ.IVCOL ) THEN
398                    MQV = MQV0 - ICOFFV
399                ELSE
400                    MQV = MQV0
401                END IF
402                IF( MYROW.EQ.ICROW ) THEN
403                    MPC0 = MPC + IROFFC
404                ELSE
405                    MPC0 = MPC
406                END IF
407  
408  *             Locally V( IOFFV ) is K x MQV , C( IOFFC ) is MPC x NQC
409  *             WORK( IPV ) is MPC0 x K =[ . V( IOFFV ) ]'
410  *             WORK( IPW ) is K x MQV0 =[ . V( IOFFV ) ]
411  *             WORK( IPT ) is the workspace for PBZTRAN
412  
413                IPV = 1
414                IPW = IPV + MPC0 * K
415                IPT = IPW + K * MQV0
416                LV = MAX( 1 , MPC0 )
417                LW = MAX( 1 , K )
418  
419                IF( MYROW.EQ.IVROW ) THEN
420                    IF( MYCOL.EQ.IVCOL ) THEN
421                        CALL ZLASET( 'All' , K , ICOFFV , ZERO , ZERO ,
422       $                WORK( IPW ) , LW )
423                        IPW1 = IPW + ICOFFV * LW
424                        CALL ZLACPY( 'All' , K , MQV , V( IOFFV ) , LDV ,
425       $                WORK( IPW1 ) , LW )
426                    ELSE
427                        IPW1 = IPW
428                        CALL ZLACPY( 'All' , K , MQV , V( IOFFV ) , LDV ,
429       $                WORK( IPW1 ) , LW )
430                    END IF
431  
432                    IF( FORWARD ) THEN
433  
434  *                     WORK( IPW ) =( . V1 V2 ) where V1 is unit upper
435  *                     triangular , zeroes lower triangular part of V1
436  
437                        MYDIST = MOD( MYCOL - IVCOL + NPCOL , NPCOL )
438                        ILEFT = MAX( 0 , MYDIST * NBV - ICOFFV )
439                        JJBEG = JJV
440                        JJEND = JJV + MQV - 1
441                        JJNXT = MIN( ICEIL( JJBEG , NBV ) * NBV , JJEND )
442  
443     50 CONTINUE
444        IF(( K - ILEFT ).GT.0 ) THEN
445            CALL ZLASET( 'Lower' , K - ILEFT , JJNXT - JJBEG + 1 , ZERO ,
446       $    ONE ,
447       $    WORK( IPW1 + ILEFT + (JJBEG - JJV)*LW ) ,
448       $    LW )
449            MYDIST = MYDIST + NPCOL
450            ILEFT = MYDIST * NBV - ICOFFV
451            JJBEG = JJNXT + 1
452            JJNXT = MIN( JJNXT + NBV , JJEND )
453            GO TO 50
454        END IF
455  
456        ELSE
457  
458  *         WORK( IPW ) =( . V1 V2 ) where V2 is unit lower
459  *         triangular , zeroes upper triangular part of V2.
460  
461            II = IIV
462            CALL INFOG1L( JV + M - K , NBV , NPCOL , MYCOL ,
463       $    DESCV( CSRC_ ) , JJ , ILASTCOL )
464            IOFF = MOD( JV + M - K - 1 , NBV )
465            KQ = NUMROC( K + IOFF , NBV , MYCOL , ILASTCOL , NPCOL )
466            IF( MYCOL.EQ.ILASTCOL )
467       $        KQ = KQ - IOFF
468                MYDIST = MOD( MYCOL - ILASTCOL + NPCOL , NPCOL )
469                ILEFT = MYDIST * NBV - IOFF
470                IRIGHT = MIN( ILEFT + NBV , K )
471                ILEFT = MIN( MAX( 0 , ILEFT ) , K )
472  
473     60 CONTINUE
474        IF( II.LE.( IIV + K - 1 ) ) THEN
475            WIDE = IRIGHT - ILEFT
476            CALL ZLASET( 'All' , ILEFT - II + IIV , KQ , ZERO , ZERO ,
477       $    WORK( IPW1 + II - IIV + (JJ - JJV)*LW ) , LW )
478            CALL ZLASET( 'Upper' , WIDE , KQ , ZERO , ONE ,
479       $    WORK( IPW1 + ILEFT + (JJ - JJV)*LW ) , LW )
480            KQ = MAX( 0 , KQ - WIDE )
481            II = IIV + IRIGHT
482            JJ = JJ + WIDE
483            MYDIST = MYDIST + NPCOL
484            ILEFT = MYDIST * NBV - IOFF
485            IRIGHT = MIN( ILEFT + NBV , K )
486            ILEFT = MIN( ILEFT , K )
487            GO TO 60
488        END IF
489        END IF
490        END IF
491  
492  *     WORK( IPV ) = WORK( IPW )'(replicated) is MPC0 x K
493  
494        CALL PBZTRAN( ICTXT , 'Rowwise' , 'Conjugate transpose' , K ,
495       $M + ICOFFV , NBV , WORK( IPW ) , LW , ZERO ,
496       $WORK( IPV ) , LV , IVROW , IVCOL , ICROW , - 1 ,
497       $WORK( IPT ) )
498  
499  *     WORK( IPV ) =( . V )' -> WORK( IPV ) = V' is MPC x K
500  
501        IF( MYROW.EQ.ICROW )
502       $    IPV = IPV + IROFFC
503  
504  *         WORK( IPW ) becomes NQC x K = C( IOFFC )' * V'
505  *         WORK( IPW ) = C( IOFFC )' * V'(NQC x MPC x K) -> NQC x K
506  
507            LW = MAX( 1 , NQC )
508  
509            IF( MPC.GT.0 ) THEN
510                CALL ZGEMM( 'Conjugate transpose' , 'No transpose' , NQC ,
511       $        K , MPC , ONE , C( IOFFC ) , LDC , WORK( IPV ) ,
512       $        LV , ZERO , WORK( IPW ) , LW )
513            ELSE
514                CALL ZLASET( 'All' , NQC , K , ZERO , ZERO , WORK( IPW ) , LW )
515            END IF
516  
517            CALL ZGSUM2D( ICTXT , 'Columnwise' , ' ' , NQC , K , WORK( IPW ) ,
518       $    LW , IVROW , MYCOL )
519  
520  *         WORK( IPW ) = WORK( IPW ) * T' or WORK( IPW ) * T
521  
522            IF( MYROW.EQ.IVROW ) THEN
523                IF( MYCOL.EQ.IVCOL ) THEN
524  
525  *                 Broadcast the block reflector to the other columns.
526  
527                    CALL ZTRBS2D( ICTXT , 'Rowwise' , ' ' , UPLO , 'Non unit' ,
528       $            K , K , T , MBV )
529                ELSE
530                    CALL ZTRBR2D( ICTXT , 'Rowwise' , ' ' , UPLO , 'Non unit' ,
531       $            K , K , T , MBV , MYROW , IVCOL )
532                END IF
533                CALL ZTRMM( 'Right' , UPLO , TRANST , 'Non unit' , NQC , K ,
534       $        ONE , T , MBV , WORK( IPW ) , LW )
535  
536                CALL ZGEBS2D( ICTXT , 'Columnwise' , ' ' , NQC , K ,
537       $        WORK( IPW ) , LW )
538            ELSE
539                CALL ZGEBR2D( ICTXT , 'Columnwise' , ' ' , NQC , K ,
540       $        WORK( IPW ) , LW , IVROW , MYCOL )
541            END IF
542  
543  *         C C - V' * W'
544  *         C( IOFFC ) = C( IOFFC ) - WORK( IPV ) * WORK( IPW )'
545  *         MPC x NQC MPC x K K x NQC
546  
547            CALL ZGEMM( 'No transpose' , 'Conjugate transpose' , MPC , NQC ,
548       $    K , - ONE , WORK( IPV ) , LV , WORK( IPW ) , LW , ONE ,
549       $    C( IOFFC ) , LDC )
550  
551        ELSE
552  
553  *         Form Q*sub( C ) or Q'*sub( C )
554  
555  *         Locally V( IOFFV ) is K x NQV , C( IOFFC ) is MPC x NQC
556  *         WORK( IPV ) is K x NQV = V( IOFFV ) , NQV = NQC
557  *         WORK( IPW ) is MPC x K = C( IOFFC ) * V( IOFFV )'
558  
559            IPV = 1
560            IPW = IPV + K * NQC
561            LV = MAX( 1 , K )
562            LW = MAX( 1 , MPC )
563  
564  *         Broadcast V to the other process rows.
565  
566            CALL PB_TOPGET( ICTXT , 'Broadcast' , 'Columnwise' , COLBTOP )
567            IF( MYROW.EQ.IVROW ) THEN
568                CALL ZGEBS2D( ICTXT , 'Columnwise' , COLBTOP , K , NQC ,
569       $        V( IOFFV ) , LDV )
570                IF( MYCOL.EQ.IVCOL )
571       $            CALL ZTRBS2D( ICTXT , 'Columnwise' , COLBTOP , UPLO ,
572       $            'Non unit' , K , K , T , MBV )
573                    CALL ZLACPY( 'All' , K , NQC , V( IOFFV ) , LDV , WORK( IPV ) ,
574       $            LV )
575                ELSE
576                    CALL ZGEBR2D( ICTXT , 'Columnwise' , COLBTOP , K , NQC ,
577       $            WORK( IPV ) , LV , IVROW , MYCOL )
578                    IF( MYCOL.EQ.IVCOL )
579       $                CALL ZTRBR2D( ICTXT , 'Columnwise' , COLBTOP , UPLO ,
580       $                'Non unit' , K , K , T , MBV , IVROW , MYCOL )
581                    END IF
582  
583                    IF( FORWARD ) THEN
584  
585  *                     WORK(IPW) =( V1 V2 ) where V1 is unit upper
586  *                     triangular , zeroes lower triangular part of V1
587  
588                        MYDIST = MOD( MYCOL - IVCOL + NPCOL , NPCOL )
589                        ILEFT = MAX( 0 , MYDIST * NBV - ICOFFV )
590                        JJBEG = JJV
591                        JJEND = JJV + NQC - 1
592                        JJNXT = MIN( ICEIL( JJBEG , NBV ) * NBV , JJEND )
593  
594     70 CONTINUE
595        IF(( K - ILEFT ).GT.0 ) THEN
596            CALL ZLASET( 'Lower' , K - ILEFT , JJNXT - JJBEG + 1 , ZERO ,
597       $    ONE , WORK( IPV + ILEFT + (JJBEG - JJV)*LV ) ,
598       $    LV )
599            MYDIST = MYDIST + NPCOL
600            ILEFT = MYDIST * NBV - ICOFFV
601            JJBEG = JJNXT + 1
602            JJNXT = MIN( JJNXT + NBV , JJEND )
603            GO TO 70
604        END IF
605  
606        ELSE
607  
608  *         WORK( IPW ) =( . V1 V2 ) where V2 is unit lower
609  *         triangular , zeroes upper triangular part of V2.
610  
611            II = IIV
612            CALL INFOG1L( JV + N - K , NBV , NPCOL , MYCOL , DESCV( CSRC_ ) ,
613       $    JJ , ILASTCOL )
614            IOFF = MOD( JV + N - K - 1 , NBV )
615            KQ = NUMROC( K + IOFF , NBV , MYCOL , ILASTCOL , NPCOL )
616            IF( MYCOL.EQ.ILASTCOL )
617       $        KQ = KQ - IOFF
618                MYDIST = MOD( MYCOL - ILASTCOL + NPCOL , NPCOL )
619                ILEFT = MYDIST * NBV - IOFF
620                IRIGHT = MIN( ILEFT + NBV , K )
621                ILEFT = MIN( MAX( 0 , ILEFT ) , K )
622  
623     80 CONTINUE
624        IF( II.LE.( IIV + K - 1 ) ) THEN
625            WIDE = IRIGHT - ILEFT
626            CALL ZLASET( 'All' , ILEFT - II + IIV , KQ , ZERO , ZERO ,
627       $    WORK( IPV + II - IIV + (JJ - JJV)*LV ) , LV )
628            CALL ZLASET( 'Upper' , WIDE , KQ , ZERO , ONE ,
629       $    WORK( IPV + ILEFT + (JJ - JJV)*LV ) , LV )
630            KQ = MAX( 0 , KQ - WIDE )
631            II = IIV + IRIGHT
632            JJ = JJ + WIDE
633            MYDIST = MYDIST + NPCOL
634            ILEFT = MYDIST * NBV - IOFF
635            IRIGHT = MIN( ILEFT + NBV , K )
636            ILEFT = MIN( ILEFT , K )
637            GO TO 80
638        END IF
639  
640        END IF
641  
642  *     WORK( IPV ) is K x NQC = V = V( IOFFV )
643  *     WORK( IPW ) = C( IOFFC ) * V'(MPC x NQC x K) -> MPC x K
644  
645        IF( NQC.GT.0 ) THEN
646            CALL ZGEMM( 'No transpose' , 'Conjugate transpose' , MPC ,
647       $    K , NQC , ONE , C( IOFFC ) , LDC , WORK( IPV ) ,
648       $    LV , ZERO , WORK( IPW ) , LW )
649        ELSE
650            CALL ZLASET( 'All' , MPC , K , ZERO , ZERO , WORK( IPW ) , LW )
651        END IF
652  
653        CALL ZGSUM2D( ICTXT , 'Rowwise' , ' ' , MPC , K , WORK( IPW ) ,
654       $LW , MYROW , IVCOL )
655  
656  *     WORK( IPW ) = WORK( IPW ) * T' or WORK( IPW ) * T
657  
658        IF( MYCOL.EQ.IVCOL ) THEN
659            CALL ZTRMM( 'Right' , UPLO , TRANS , 'Non unit' , MPC , K ,
660       $    ONE , T , MBV , WORK( IPW ) , LW )
661            CALL ZGEBS2D( ICTXT , 'Rowwise' , ' ' , MPC , K , WORK( IPW ) ,
662       $    LW )
663        ELSE
664            CALL ZGEBR2D( ICTXT , 'Rowwise' , ' ' , MPC , K , WORK( IPW ) ,
665       $    LW , MYROW , IVCOL )
666        END IF
667  
668  *     C C - W * V
669  *     C( IOFFC ) = C( IOFFC ) - WORK( IPW ) * WORK( IPV )
670  *     MPC x NQC MPC x K K x NQC
671  
672        CALL ZGEMM( 'No transpose' , 'No transpose' , MPC , NQC , K ,
673       $- ONE , WORK( IPW ) , LW , WORK( IPV ) , LV , ONE ,
674       $C( IOFFC ) , LDC )
675  
676        END IF
677  
678        END IF
679  
680        RETURN
681  
682  *     End of PZLARFB
683  
684        END