pclarfb.f

Go to the documentation of this file.

      SUBROUTINE pclarfb( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, IV,
     $                    JV, DESCV, T, C, IC, JC, DESCC, WORK )
*
*  -- ScaLAPACK auxiliary routine (version 2.0.2) --
*     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
*     May 1 2012
*
*     .. Scalar Arguments ..
      CHARACTER          SIDE, TRANS, DIRECT, STOREV
      INTEGER            IC, IV, JC, JV, K, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            DESCC( * ), DESCV( * )
      COMPLEX            C( * ), T( * ), V( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PCLARFB 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 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 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 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 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 ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   lld_, mb_, m_, nb_, n_, rsrc_
      parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
     $                     ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
     $                     rsrc_ = 7, csrc_ = 8, lld_ = 9 )
      COMPLEX            ONE, ZERO
      parameter( one  = ( 1.0e+0, 0.0e+0 ),
     $                     zero = ( 0.0e+0, 0.0e+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            FORWARD
      CHARACTER          COLBTOP, ROWBTOP, TRANST, UPLO
      INTEGER            HEIGHT, IBASE, ICCOL, ICOFFC, ICOFFV, ICROW,
     $                   ictxt, ii, iibeg, iic, iiend, iinxt, iiv,
     $                   ilastcol, ilastrow, ileft, ioff, ioffc, ioffv,
     $                   ipt, ipv, ipw, ipw1, iright, iroffc, iroffv,
     $                   itop, ivcol, ivrow, jj, jjbeg, jjc, jjend,
     $                   jjnxt, jjv, kp, kq, ldc, ldv, lv, lw, mbv, mpc,
     $                   mpc0, mqv, mqv0, mycol, mydist, myrow, nbv,
     $                   npv, npv0, npcol, nprow, nqc, nqc0, wide
*     ..
*     .. External Subroutines ..
      EXTERNAL           blacs_gridinfo, cgebr2d, cgebs2d,cgemm,
     $                   cgsum2d, clamov, claset, ctrbr2d,
     $                   ctrbs2d, ctrmm, infog1l, infog2l, pb_topget,
     $                   pbctran
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max, min, mod
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ICEIL, NUMROC
      EXTERNAL           iceil, lsame, numroc
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( m.LE.0 .OR. n.LE.0 .OR. k.LE.0 )
     $   RETURN
*
*     Get grid parameters
*
      ictxt = descc( ctxt_ )
      CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
*
      IF( lsame( trans, 'N' ) ) THEN
          transt = 'c'
      ELSE
          TRANST = 'n'
      END IF
      FORWARD = LSAME( DIRECT, 'f' )
      IF( FORWARD ) THEN
         UPLO = 'u'
      ELSE
         UPLO = 'l'
      END IF
*
      CALL INFOG2L( IV, JV, DESCV, NPROW, NPCOL, MYROW, MYCOL, IIV, JJV,
     $              IVROW, IVCOL )
      CALL INFOG2L( IC, JC, DESCC, NPROW, NPCOL, MYROW, MYCOL, IIC, JJC,
     $              ICROW, ICCOL )
      LDC = DESCC( LLD_ )
      LDV = DESCV( LLD_ )
      IIC = MIN( IIC, LDC )
      IIV = MIN( IIV, LDV )
      IROFFC = MOD( IC-1, DESCC( MB_ ) )
      ICOFFC = MOD( JC-1, DESCC( NB_ ) )
      MBV = DESCV( MB_ )
      NBV = DESCV( NB_ )
      IROFFV = MOD( IV-1, MBV )
      ICOFFV = MOD( JV-1, NBV )
      MPC = NUMROC( M+IROFFC, DESCC( MB_ ), MYROW, ICROW, NPROW )
      NQC = NUMROC( N+ICOFFC, DESCC( NB_ ), MYCOL, ICCOL, NPCOL )
.EQ.      IF( MYCOLICCOL )
     $   NQC = NQC - ICOFFC
.EQ.      IF( MYROWICROW )
     $   MPC = MPC - IROFFC
      JJC = MIN( JJC, MAX( 1, JJC+NQC-1 ) )
      JJV = MIN( JJV, MAX( 1, NUMROC( DESCV( N_ ), NBV, MYCOL,
     $                                DESCV( CSRC_ ), NPCOL ) ) )
      IOFFC = IIC + ( JJC-1 ) * LDC
      IOFFV = IIV + ( JJV-1 ) * LDV
*
      IF( LSAME( STOREV, 'c' ) ) THEN
*
*        V is stored columnwise
*
         IF( LSAME( SIDE, 'l' ) ) THEN
*
*           Form  Q*sub( C )  or  Q'*sub( C  )
*
*           Locally V( IOFFV ) is MPV x K, C( IOFFC ) is MPC x NQC
*           WORK( IPV ) is MPC x K = V( IOFFV ), MPC = MPV
*           WORK( IPW ) is NQC x K = C( IOFFC )' * V( IOFFV )
*
            IPV = 1
            IPW = IPV + MPC * K
            LV = MAX( 1, MPC )
            LW = MAX( 1, NQC )
*
*           Broadcast V to the other process columns.
*
            CALL PB_TOPGET( ICTXT, 'broadcast', 'rowwise', ROWBTOP )
.EQ.            IF( MYCOLIVCOL ) THEN
               CALL CGEBS2D( ICTXT, 'rowwise', ROWBTOP, MPC, K,
     $                       V( IOFFV ), LDV )
.EQ.               IF( MYROWIVROW )
     $            CALL CTRBS2D( ICTXT, 'rowwise', ROWBTOP, UPLO,
     $                          'non unit', K, K, T, NBV )
               CALL CLAMOV( 'all', MPC, K, V( IOFFV ), LDV, WORK( IPV ),
     $                      LV )
            ELSE
               CALL CGEBR2D( ICTXT, 'rowwise', ROWBTOP, MPC, K,
     $                       WORK( IPV ), LV, MYROW, IVCOL )
.EQ.               IF( MYROWIVROW )
     $            CALL CTRBR2D( ICTXT, 'rowwise', ROWBTOP, UPLO,
     $                          'non unit', K, K, T, NBV, MYROW, IVCOL )
            END IF
*
            IF( FORWARD ) THEN
*
*              WORK(IPV) = ( V1 ) where V1 is unit lower triangular,
*                          ( V2 ) zeroes upper triangular part of V1
*
               MYDIST = MOD( MYROW-IVROW+NPROW, NPROW )
               ITOP = MAX( 0, MYDIST*MBV - IROFFV )
               IIBEG = IIV
               IIEND = IIBEG + MPC - 1
               IINXT = MIN( ICEIL( IIBEG, MBV )*MBV, IIEND )
*
   10          CONTINUE
.GT.               IF( K-ITOP 0 ) THEN
                  CALL CLASET( 'upper', IINXT-IIBEG+1, K-ITOP, ZERO,
     $                         ONE, WORK( IPV+IIBEG-IIV+ITOP*LV ), LV )
                  MYDIST = MYDIST + NPROW
                  ITOP = MYDIST * MBV - IROFFV
                  IIBEG = IINXT + 1
                  IINXT = MIN( IINXT+MBV, IIEND )
                  GO TO 10
               END IF
*
            ELSE
*
*              WORK(IPV) = ( V1 ) where V2 is unit upper triangular,
*                          ( V2 ) zeroes lower triangular part of V2
*
               JJ = JJV
               IOFF = MOD( IV+M-K-1, MBV )
               CALL INFOG1L( IV+M-K, MBV, NPROW, MYROW, DESCV( RSRC_ ),
     $                       II, ILASTROW )
               KP = NUMROC( K+IOFF, MBV, MYROW, ILASTROW, NPROW )
.EQ.               IF( MYROWILASTROW )
     $            KP = KP - IOFF
               MYDIST = MOD( MYROW-ILASTROW+NPROW, NPROW )
               ITOP = MYDIST * MBV - IOFF
               IBASE = MIN( ITOP+MBV, K )
               ITOP = MIN( MAX( 0, ITOP ), K )
*
   20          CONTINUE
.LE.               IF( JJ( JJV+K-1 ) ) THEN
                  HEIGHT = IBASE - ITOP
                  CALL CLASET( 'all', KP, ITOP-JJ+JJV, ZERO, ZERO,
     $                         WORK( IPV+II-IIV+(JJ-JJV)*LV ), LV )
                  CALL CLASET( 'lower', KP, HEIGHT, ZERO, ONE,
     $                         WORK( IPV+II-IIV+ITOP*LV ), LV )
                  KP = MAX( 0, KP - HEIGHT )
                  II = II + HEIGHT
                  JJ = JJV + IBASE
                  MYDIST = MYDIST + NPROW
                  ITOP = MYDIST * MBV - IOFF
                  IBASE = MIN( ITOP + MBV, K )
                  ITOP = MIN( ITOP, K )
                  GO TO 20
               END IF
*
            END IF
*
*           WORK( IPW ) = C( IOFFC )' * V  (NQC x MPC x K) -> NQC x K
*
.GT.            IF( MPC0 ) THEN
               CALL CGEMM( 'conjugate transpose', 'no transpose', NQC,
     $                    K, MPC, ONE, C( IOFFC ), LDC, WORK( IPV ), LV,
     $                    ZERO, WORK( IPW ), LW )
            ELSE
               CALL CLASET( 'all', NQC, K, ZERO, ZERO, WORK( IPW ), LW )
            END IF
*
            CALL CGSUM2D( ICTXT, 'columnwise', ' ', NQC, K, WORK( IPW ),
     $                    LW, IVROW, MYCOL )
*
.EQ.            IF( MYROWIVROW ) THEN
*
*              WORK( IPW ) = WORK( IPW ) * T' or WORK( IPW ) * T
*
               CALL CTRMM( 'right', UPLO, TRANST, 'non unit', NQC, K,
     $                     ONE, T, NBV, WORK( IPW ), LW )
               CALL CGEBS2D( ICTXT, 'columnwise', ' ', NQC, K,
     $                       WORK( IPW ), LW )
            ELSE
               CALL CGEBR2D( ICTXT, 'columnwise', ' ', nqc, k,
     $                       work( ipw ), lw, ivrow, mycol )
            END IF
*
*               C            C      -     V       *     W'
*           C( IOFFC ) = C( IOFFC ) - WORK( IPV ) * WORK( IPW )'
*                        MPC x NQC    MPC x K         K x NQC
*
            CALL cgemm( 'No transpose', 'Conjugate transpose', mpc, nqc,
     $                  k, -one, work( ipv ), lv, work( ipw ), lw, one,
     $                  c( ioffc ), ldc )
*
         ELSE
*
*           Form sub( C )*Q or sub( C )*Q'
*
*           ICOFFC = IROFFV is required by the current transposition
*           routine PBCTRAN
*
            npv0 = numroc( n+iroffv, mbv, myrow, ivrow, nprow )
            IF( myrow.EQ.ivrow ) THEN
               npv = npv0 - iroffv
            ELSE
               npv = npv0
            END IF
            IF( mycol.EQ.iccol ) THEN
               nqc0 = nqc + icoffc
            ELSE
               nqc0 = nqc
            END IF
*
*           Locally V( IOFFV ) is NPV x K C( IOFFC ) is MPC x NQC
*           WORK( IPV ) is K x NQC0 = [ . V( IOFFV ) ]'
*           WORK( IPW ) is NPV0 x K = [ . V( IOFFV )' ]'
*           WORK( IPT ) is the workspace for PBCTRAN
*
            ipv = 1
            ipw = ipv + k * nqc0
            ipt = ipw + npv0 * k
            lv = max( 1, k )
            lw = max( 1, npv0 )
*
            IF( mycol.EQ.ivcol ) THEN
               IF( myrow.EQ.ivrow ) THEN
                  CALL claset( 'All', iroffv, k, zero, zero,
     $                         work( ipw ), lw )
                  ipw1 = ipw + iroffv
                  CALL clamov( 'All', npv, k, v( ioffv ), ldv,
     $                         work( ipw1 ), lw )
               ELSE
                  ipw1 = ipw
                  CALL clamov( 'All', npv, k, v( ioffv ), ldv,
     $                         work( ipw1 ), lw )
               END IF
*
               IF( forward ) THEN
*
*                 WORK(IPW) = ( . V1' V2' )' where V1 is unit lower
*                 triangular, zeroes upper triangular part of V1
*
                  mydist = mod( myrow-ivrow+nprow, nprow )
                  itop = max( 0, mydist*mbv - iroffv )
                  iibeg = iiv
                  iiend = iibeg + npv - 1
                  iinxt = min( iceil( iibeg, mbv )*mbv, iiend )
*
   30             CONTINUE
                  IF( ( k-itop ).GT.0 ) THEN
                     CALL claset( 'Upper', iinxt-iibeg+1, k-itop, zero,
     $                            one, work( ipw1+iibeg-iiv+itop*lw ),
     $                            lw )
                     mydist = mydist + nprow
                     itop = mydist * mbv - iroffv
                     iibeg = iinxt + 1
                     iinxt = min( iinxt+mbv, iiend )
                     GO TO 30
                  END IF
*
               ELSE
*
*                 WORK( IPW ) = ( . V1' V2' )' where V2 is unit upper
*                 triangular, zeroes lower triangular part of V2.
*
                  jj = jjv
                  CALL infog1l( iv+n-k, mbv, nprow, myrow,
     $                          descv( rsrc_ ), ii, ilastrow )
                  ioff = mod( iv+n-k-1, mbv )
                  kp = numroc( k+ioff, mbv, myrow, ilastrow, nprow )
                  IF( myrow.EQ.ilastrow )
     $               kp = kp - ioff
                  mydist = mod( myrow-ilastrow+nprow, nprow )
                  itop = mydist * mbv - ioff
                  ibase = min( itop+mbv, k )
                  itop = min( max( 0, itop ), k )
*
   40             CONTINUE
                  IF( jj.LE.( jjv+k-1 ) ) THEN
                     height = ibase - itop
                     CALL claset( 'All', kp, itop-jj+jjv, zero, zero,
     $                            work( ipw1+ii-iiv+(jj-jjv)*lw ), lw )
                     CALL claset( 'Lower', kp, height, zero, one,
     $                            work( ipw1+ii-iiv+itop*lw ), lw )
                     kp = max( 0, kp - height )
                     ii = ii + height
                     jj = jjv + ibase
                     mydist = mydist + nprow
                     itop = mydist * mbv - ioff
                     ibase = min( itop + mbv, k )
                     itop = min( itop, k )
                     GO TO 40
                  END IF
               END IF
            END IF
*
            CALL pbctran( ictxt, 'Columnwise', 'Conjugate transpose',
     $                    n+iroffv, k, mbv, work( ipw ), lw, zero,
     $                    work( ipv ), lv, ivrow, ivcol, -1, iccol,
     $                    work( ipt ) )
*
*           WORK( IPV ) = ( . V' ) -> WORK( IPV ) = V' is K x NQC
*
            IF( mycol.EQ.iccol )
     $         ipv = ipv + icoffc * lv
*
*           WORK( IPW ) becomes MPC x K = C( IOFFC ) * V
*           WORK( IPW ) = C( IOFFC ) * V  (MPC x NQC x K) -> MPC x K
*
            lw = max( 1, mpc )
*
            IF( nqc.GT.0 ) THEN
               CALL cgemm( 'No transpose', 'Conjugate transpose', mpc,
     $                     k, nqc, one, c( ioffc ), ldc, work( ipv ),
     $                     lv, zero, work( ipw ), lw )
            ELSE
               CALL claset( 'All', mpc, k, zero, zero, work( ipw ), lw )
            END IF
*
            CALL cgsum2d( ictxt, 'Rowwise', ' ', mpc, k, work( ipw ),
     $                    lw, myrow, ivcol )
*
*           WORK( IPW ) = WORK( IPW ) * T' or WORK( IPW ) * T
*
            IF( mycol.EQ.ivcol ) THEN
               IF( myrow.EQ.ivrow ) THEN
*
*                 Broadcast the block reflector to the other rows.
*
                  CALL ctrbs2d( ictxt, 'Columnwise', ' ', uplo,
     $                          'Non unit', k, k, t, nbv )
               ELSE
                  CALL ctrbr2d( ictxt, 'Columnwise', ' ', uplo,
     $                          'Non unit', k, k, t, nbv, ivrow, mycol )
               END IF
               CALL ctrmm( 'right', UPLO, TRANS, 'non unit', MPC, K,
     $                     ONE, T, NBV, WORK( IPW ), LW )
*
               CALL CGEBS2D( ICTXT, 'rowwise', ' ', MPC, K, WORK( IPW ),
     $                       LW )
            ELSE
               CALL CGEBR2D( ICTXT, 'rowwise', ' ', MPC, K, WORK( IPW ),
     $                       LW, MYROW, IVCOL )
            END IF
*
*               C            C      -     W       *     V'
*           C( IOFFC ) = C( IOFFC ) - WORK( IPW ) * WORK( IPV )
*                        MPC x NQC    MPC x K         K x NQC
*
            CALL CGEMM( 'no transpose', 'no transpose', MPC, NQC, K,
     $                  -ONE, WORK( IPW ), LW, WORK( IPV ), LV, ONE,
     $                  C( IOFFC ), LDC )
         END IF
*
      ELSE
*
*        V is stored rowwise
*
         IF( LSAME( SIDE, 'l' ) ) THEN
*
*           Form Q*sub( C ) or Q'*sub( C )
*
*           IROFFC = ICOFFV is required by the current transposition
*           routine PBCTRAN
*
            MQV0 = NUMROC( M+ICOFFV, NBV, MYCOL, IVCOL, NPCOL )
.EQ.            IF( MYCOLIVCOL ) THEN
               MQV = MQV0 - ICOFFV
            ELSE
               MQV = MQV0
            END IF
.EQ.            IF( MYROWICROW ) THEN
               MPC0 = MPC + IROFFC
            ELSE
               MPC0 = MPC
            END IF
*
*           Locally V( IOFFV ) is K x MQV, C( IOFFC ) is MPC x NQC
*           WORK( IPV ) is MPC0 x K = [ . V( IOFFV ) ]'
*           WORK( IPW ) is K x MQV0 = [ . V( IOFFV ) ]
*           WORK( IPT ) is the workspace for PBCTRAN
*
            IPV = 1
            IPW = IPV + MPC0 * K
            IPT = IPW + K * MQV0
            LV = MAX( 1, MPC0 )
            LW = MAX( 1, K )
*
.EQ.            IF( MYROWIVROW ) THEN
.EQ.               IF( MYCOLIVCOL ) THEN
                  CALL CLASET( 'all', K, ICOFFV, ZERO, ZERO,
     $                         WORK( IPW ), LW )
                  IPW1 = IPW + ICOFFV * LW
                  CALL CLAMOV( 'all', K, MQV, V( IOFFV ), LDV,
     $                         WORK( IPW1 ), LW )
               ELSE
                  IPW1 = IPW
                  CALL CLAMOV( 'all', K, MQV, V( IOFFV ), LDV,
     $                         WORK( IPW1 ), LW )
               END IF
*
               IF( FORWARD ) THEN
*
*                 WORK( IPW ) = ( . V1 V2 ) where V1 is unit upper
*                 triangular, zeroes lower triangular part of V1
*
                  MYDIST = MOD( MYCOL-IVCOL+NPCOL, NPCOL )
                  ILEFT = MAX( 0, MYDIST * NBV - ICOFFV )
                  JJBEG = JJV
                  JJEND = JJV + MQV - 1
                  JJNXT = MIN( ICEIL( JJBEG, NBV ) * NBV, JJEND )
*
   50             CONTINUE
.GT.                  IF( ( K-ILEFT )0 ) THEN
                     CALL CLASET( 'lower', K-ILEFT, JJNXT-JJBEG+1, ZERO,
     $                            ONE,
     $                            WORK( IPW1+ILEFT+(JJBEG-JJV)*LW ),
     $                            LW )
                     MYDIST = MYDIST + NPCOL
                     ILEFT = MYDIST * NBV - ICOFFV
                     JJBEG = JJNXT + 1
                     JJNXT = MIN( JJNXT+NBV, JJEND )
                     GO TO 50
                  END IF
*
               ELSE
*
*                 WORK( IPW ) = ( . V1 V2 ) where V2 is unit lower
*                 triangular, zeroes upper triangular part of V2.
*
                  II = IIV
                  CALL INFOG1L( JV+M-K, NBV, NPCOL, MYCOL,
     $                          DESCV( CSRC_ ), JJ, ILASTCOL )
                  IOFF = MOD( JV+M-K-1, NBV )
                  KQ = NUMROC( K+IOFF, NBV, MYCOL, ILASTCOL, NPCOL )
.EQ.                  IF( MYCOLILASTCOL )
     $               KQ = KQ - IOFF
                  MYDIST = MOD( MYCOL-ILASTCOL+NPCOL, NPCOL )
                  ILEFT = MYDIST * NBV - IOFF
                  IRIGHT = MIN( ILEFT+NBV, K )
                  ILEFT = MIN( MAX( 0, ILEFT ), K )
*
   60             CONTINUE
.LE.                  IF( II( IIV+K-1 ) ) THEN
                     WIDE = IRIGHT - ILEFT
                     CALL CLASET( 'all', ILEFT-II+IIV, KQ, ZERO, ZERO,
     $                            WORK( IPW1+II-IIV+(JJ-JJV)*LW ), LW )
                     CALL CLASET( 'upper', WIDE, KQ, ZERO, ONE,
     $                            WORK( IPW1+ILEFT+(JJ-JJV)*LW ), LW )
                     KQ = MAX( 0, KQ - WIDE )
                     II = IIV + IRIGHT
                     JJ = JJ + WIDE
                     MYDIST = MYDIST + NPCOL
                     ILEFT = MYDIST * NBV - IOFF
                     IRIGHT = MIN( ILEFT + NBV, K )
                     ILEFT = MIN( ILEFT, K )
                     GO TO 60
                  END IF
               END IF
            END IF
*
*           WORK( IPV ) = WORK( IPW )' (replicated) is MPC0 x K
*
            CALL PBCTRAN( ICTXT, 'rowwise', 'conjugate transpose', K,
     $                    M+ICOFFV, NBV, WORK( IPW ), LW, ZERO,
     $                    WORK( IPV ), LV, IVROW, IVCOL, ICROW, -1,
     $                    WORK( IPT ) )
*
*           WORK( IPV ) = ( . V )' -> WORK( IPV ) = V' is MPC x K
*
.EQ.            IF( MYROWICROW )
     $         IPV = IPV + IROFFC
*
*           WORK( IPW ) becomes NQC x K = C( IOFFC )' * V'
*           WORK( IPW ) = C( IOFFC )' * V'  (NQC x MPC x K) -> NQC x K
*
            LW = MAX( 1, NQC )
*
.GT.            IF( MPC0 ) THEN
               CALL CGEMM( 'conjugate transpose', 'no transpose', NQC,
     $                     K, MPC, ONE, C( IOFFC ), LDC, WORK( IPV ),
     $                     LV, ZERO, WORK( IPW ), LW )
            ELSE
               CALL CLASET( 'all', NQC, K, ZERO, ZERO, WORK( IPW ), LW )
            END IF
*
            CALL CGSUM2D( ICTXT, 'columnwise', ' ', NQC, K, WORK( IPW ),
     $                    LW, IVROW, MYCOL )
*
*           WORK( IPW ) = WORK( IPW ) * T' or WORK( IPW ) * T
*
.EQ.            IF( MYROWIVROW ) THEN
.EQ.               IF( MYCOLIVCOL ) THEN
*
*                 Broadcast the block reflector to the other columns.
*
                  CALL CTRBS2D( ICTXT, 'rowwise', ' ', UPLO, 'non unit',
     $                          K, K, T, MBV )
               ELSE
                  CALL CTRBR2D( ICTXT, 'rowwise', ' ', UPLO, 'non unit',
     $                          K, K, T, MBV, MYROW, IVCOL )
               END IF
               CALL CTRMM( 'right', UPLO, TRANST, 'non unit', NQC, K,
     $                     ONE, T, MBV, WORK( IPW ), LW )
*
               CALL CGEBS2D( ICTXT, 'columnwise', ' ', NQC, K,
     $                       WORK( IPW ), LW )
            ELSE
               CALL CGEBR2D( ICTXT, 'columnwise', ' ', NQC, K,
     $                       WORK( IPW ), LW, IVROW, MYCOL )
            END IF
*
*               C            C      -     V'      *     W'
*           C( IOFFC ) = C( IOFFC ) - WORK( IPV ) * WORK( IPW )'
*                        MPC x NQC    MPC x K         K x NQC
*
            CALL CGEMM( 'no transpose', 'conjugate transpose', MPC, NQC,
     $                  K, -ONE, WORK( IPV ), LV, WORK( IPW ), LW, ONE,
     $                  C( IOFFC ), LDC )
*
         ELSE
*
*           Form Q*sub( C ) or Q'*sub( C )
*
*           Locally V( IOFFV ) is K x NQV, C( IOFFC ) is MPC x NQC
*           WORK( IPV ) is K x NQV = V( IOFFV ), NQV = NQC
*           WORK( IPW ) is MPC x K = C( IOFFC ) * V( IOFFV )'
*
            IPV = 1
            IPW = IPV + K * NQC
            LV = MAX( 1, K )
            LW = MAX( 1, MPC )
*
*           Broadcast V to the other process rows.
*
            CALL PB_TOPGET( ICTXT, 'broadcast', 'columnwise', COLBTOP )
.EQ.            IF( MYROWIVROW ) THEN
               CALL CGEBS2D( ICTXT, 'columnwise', COLBTOP, K, NQC,
     $                       V( IOFFV ), LDV )
.EQ.               IF( MYCOLIVCOL )
     $            CALL CTRBS2D( ICTXT, 'columnwise', COLBTOP, UPLO,
     $                          'non unit', K, K, T, MBV )
               CALL CLAMOV( 'all', K, NQC, V( IOFFV ), LDV, WORK( IPV ),
     $                      LV )
            ELSE
               CALL CGEBR2D( ICTXT, 'columnwise', COLBTOP, K, NQC,
     $                       WORK( IPV ), LV, IVROW, MYCOL )
.EQ.               IF( MYCOLIVCOL )
     $            CALL CTRBR2D( ICTXT, 'columnwise', COLBTOP, UPLO,
     $                          'non unit', K, K, T, MBV, IVROW, MYCOL )
            END IF
*
            IF( FORWARD ) THEN
*
*              WORK(IPW) = ( V1 V2 ) where V1 is unit upper
*              triangular, zeroes lower triangular part of V1
*
               MYDIST = MOD( MYCOL-IVCOL+NPCOL, NPCOL )
               ILEFT = MAX( 0, MYDIST * NBV - ICOFFV )
               JJBEG = JJV
               JJEND = JJV + NQC - 1
               JJNXT = MIN( ICEIL( JJBEG, NBV ) * NBV, JJEND )
*
   70          CONTINUE
.GT.               IF( ( K-ILEFT )0 ) THEN
                  CALL CLASET( 'lower', K-ILEFT, JJNXT-JJBEG+1, ZERO,
     $                            ONE, WORK( IPV+ILEFT+(JJBEG-JJV)*LV ),
     $                            LV )
                  MYDIST = MYDIST + NPCOL
                  ILEFT = MYDIST * NBV - ICOFFV
                  JJBEG = JJNXT + 1
                  JJNXT = MIN( JJNXT+NBV, JJEND )
                  GO TO 70
               END IF
*
            ELSE
*
*              WORK( IPW ) = ( . V1 V2 ) where V2 is unit lower
*              triangular, zeroes upper triangular part of V2.
*
               II = IIV
               CALL INFOG1L( JV+N-K, NBV, NPCOL, MYCOL, DESCV( CSRC_ ),
     $                       JJ, ILASTCOL )
               IOFF = MOD( JV+N-K-1, NBV )
               KQ = NUMROC( K+IOFF, NBV, MYCOL, ILASTCOL, NPCOL )
.EQ.               IF( MYCOLILASTCOL )
     $            KQ = KQ - IOFF
               MYDIST = MOD( MYCOL-ILASTCOL+NPCOL, NPCOL )
               ILEFT = MYDIST * NBV - IOFF
               IRIGHT = MIN( ILEFT+NBV, K )
               ILEFT = MIN( MAX( 0, ILEFT ), K )
*
   80          CONTINUE
.LE.               IF( II( IIV+K-1 ) ) THEN
                  WIDE = IRIGHT - ILEFT
                  CALL CLASET( 'all', ILEFT-II+IIV, KQ, ZERO, ZERO,
     $                         WORK( IPV+II-IIV+(JJ-JJV)*LV ), LV )
                  CALL CLASET( 'upper', WIDE, KQ, ZERO, ONE,
     $                         WORK( IPV+ILEFT+(JJ-JJV)*LV ), LV )
                  KQ = MAX( 0, KQ - WIDE )
                  II = IIV + IRIGHT
                  JJ = JJ + WIDE
                  MYDIST = MYDIST + NPCOL
                  ILEFT = MYDIST * NBV - IOFF
                  IRIGHT = MIN( ILEFT + NBV, K )
                  ILEFT = MIN( ILEFT, K )
                  GO TO 80
               END IF
*
            END IF
*
*           WORK( IPV ) is K x NQC = V = V( IOFFV )
*           WORK( IPW ) = C( IOFFC ) * V'  (MPC x NQC x K) -> MPC x K
*
.GT.            IF( NQC0 ) THEN
               CALL CGEMM( 'no transpose', 'conjugate transpose', MPC,
     $                    K, NQC, ONE, C( IOFFC ), LDC, WORK( IPV ),
     $                    LV, ZERO, WORK( IPW ), LW )
            ELSE
               CALL CLASET( 'all', MPC, K, ZERO, ZERO, WORK( IPW ), LW )
            END IF
*
            CALL CGSUM2D( ICTXT, 'rowwise', ' ', MPC, K, WORK( IPW ),
     $                    LW, MYROW, IVCOL )
*
*           WORK( IPW ) = WORK( IPW ) * T' or WORK( IPW ) * T
*
.EQ.            IF( MYCOLIVCOL ) THEN
               CALL CTRMM( 'right', UPLO, TRANS, 'non unit', MPC, K,
     $                     ONE, T, MBV, WORK( IPW ), LW )
               CALL CGEBS2D( ICTXT, 'rowwise', ' ', MPC, K, WORK( IPW ),
     $                       LW )
            ELSE
               CALL CGEBR2D( ICTXT, 'rowwise', ' ', MPC, K, WORK( IPW ),
     $                       LW, MYROW, IVCOL )
            END IF
*
*               C            C      -     W       *     V
*           C( IOFFC ) = C( IOFFC ) - WORK( IPW ) * WORK( IPV )
*                        MPC x NQC    MPC x K         K x NQC
*
            CALL CGEMM( 'no transpose', 'no transpose', MPC, NQC, K,
     $                  -ONE, WORK( IPW ), LW, WORK( IPV ), LV, ONE,
     $                  C( IOFFC ), LDC )
*
         END IF
*
      END IF
*
      RETURN
*
*     End of PCLARFB
*
      END