ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pcgeqpf.f
Go to the documentation of this file.
00001       SUBROUTINE PCGEQPF( M, N, A, IA, JA, DESCA, IPIV, TAU, WORK,
00002      $                    LWORK, RWORK, LRWORK, INFO )
00003 *
00004 *  -- ScaLAPACK routine (version 1.7) --
00005 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00006 *     and University of California, Berkeley.
00007 *     March 14, 2000
00008 *
00009 *     .. Scalar Arguments ..
00010       INTEGER            IA, JA, INFO, LRWORK, LWORK, M, N
00011 *     ..
00012 *     .. Array Arguments ..
00013       INTEGER            DESCA( * ), IPIV( * )
00014       REAL               RWORK( * )
00015       COMPLEX            A( * ), TAU( * ), WORK( * )
00016 *     ..
00017 *
00018 *  Purpose
00019 *  =======
00020 *
00021 *  PCGEQPF computes a QR factorization with column pivoting of a
00022 *  M-by-N distributed matrix sub( A ) = A(IA:IA+M-1,JA:JA+N-1):
00023 *
00024 *                         sub( A ) * P = Q * R.
00025 *
00026 *  Notes
00027 *  =====
00028 *
00029 *  Each global data object is described by an associated description
00030 *  vector.  This vector stores the information required to establish
00031 *  the mapping between an object element and its corresponding process
00032 *  and memory location.
00033 *
00034 *  Let A be a generic term for any 2D block cyclicly distributed array.
00035 *  Such a global array has an associated description vector DESCA.
00036 *  In the following comments, the character _ should be read as
00037 *  "of the global array".
00038 *
00039 *  NOTATION        STORED IN      EXPLANATION
00040 *  --------------- -------------- --------------------------------------
00041 *  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
00042 *                                 DTYPE_A = 1.
00043 *  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
00044 *                                 the BLACS process grid A is distribu-
00045 *                                 ted over. The context itself is glo-
00046 *                                 bal, but the handle (the integer
00047 *                                 value) may vary.
00048 *  M_A    (global) DESCA( M_ )    The number of rows in the global
00049 *                                 array A.
00050 *  N_A    (global) DESCA( N_ )    The number of columns in the global
00051 *                                 array A.
00052 *  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
00053 *                                 the rows of the array.
00054 *  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
00055 *                                 the columns of the array.
00056 *  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
00057 *                                 row of the array A is distributed.
00058 *  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
00059 *                                 first column of the array A is
00060 *                                 distributed.
00061 *  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
00062 *                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
00063 *
00064 *  Let K be the number of rows or columns of a distributed matrix,
00065 *  and assume that its process grid has dimension p x q.
00066 *  LOCr( K ) denotes the number of elements of K that a process
00067 *  would receive if K were distributed over the p processes of its
00068 *  process column.
00069 *  Similarly, LOCc( K ) denotes the number of elements of K that a
00070 *  process would receive if K were distributed over the q processes of
00071 *  its process row.
00072 *  The values of LOCr() and LOCc() may be determined via a call to the
00073 *  ScaLAPACK tool function, NUMROC:
00074 *          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
00075 *          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
00076 *  An upper bound for these quantities may be computed by:
00077 *          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
00078 *          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
00079 *
00080 *  Arguments
00081 *  =========
00082 *
00083 *  M       (global input) INTEGER
00084 *          The number of rows to be operated on, i.e. the number of rows
00085 *          of the distributed submatrix sub( A ). M >= 0.
00086 *
00087 *  N       (global input) INTEGER
00088 *          The number of columns to be operated on, i.e. the number of
00089 *          columns of the distributed submatrix sub( A ). N >= 0.
00090 *
00091 *  A       (local input/local output) COMPLEX pointer into the
00092 *          local memory to an array of dimension (LLD_A, LOCc(JA+N-1)).
00093 *          On entry, the local pieces of the M-by-N distributed matrix
00094 *          sub( A ) which is to be factored. On exit, the elements on
00095 *          and above the diagonal of sub( A ) contain the min(M,N) by N
00096 *          upper trapezoidal matrix R (R is upper triangular if M >= N);
00097 *          the elements below the diagonal, with the array TAU, repre-
00098 *          sent the unitary matrix Q as a product of elementary
00099 *          reflectors (see Further Details).
00100 *
00101 *  IA      (global input) INTEGER
00102 *          The row index in the global array A indicating the first
00103 *          row of sub( A ).
00104 *
00105 *  JA      (global input) INTEGER
00106 *          The column index in the global array A indicating the
00107 *          first column of sub( A ).
00108 *
00109 *  DESCA   (global and local input) INTEGER array of dimension DLEN_.
00110 *          The array descriptor for the distributed matrix A.
00111 *
00112 *  IPIV    (local output) INTEGER array, dimension LOCc(JA+N-1).
00113 *          On exit, if IPIV(I) = K, the local i-th column of sub( A )*P
00114 *          was the global K-th column of sub( A ). IPIV is tied to the
00115 *          distributed matrix A.
00116 *
00117 *  TAU     (local output) COMPLEX, array, dimension
00118 *          LOCc(JA+MIN(M,N)-1). This array contains the scalar factors
00119 *          TAU of the elementary reflectors. TAU is tied to the
00120 *          distributed matrix A.
00121 *
00122 *  WORK    (local workspace/local output) COMPLEX array,
00123 *                                                    dimension (LWORK)
00124 *          On exit, WORK(1) returns the minimal and optimal LWORK.
00125 *
00126 *  LWORK   (local or global input) INTEGER
00127 *          The dimension of the array WORK.
00128 *          LWORK is local input and must be at least
00129 *          LWORK >= MAX(3,Mp0 + Nq0).
00130 *
00131 *          If LWORK = -1, then LWORK is global input and a workspace
00132 *          query is assumed; the routine only calculates the minimum
00133 *          and optimal size for all work arrays. Each of these
00134 *          values is returned in the first entry of the corresponding
00135 *          work array, and no error message is issued by PXERBLA.
00136 *
00137 *  RWORK   (local workspace/local output) REAL array,
00138 *                                                 dimension (LRWORK)
00139 *          On exit, RWORK(1) returns the minimal and optimal LRWORK.
00140 *
00141 *  LRWORK  (local or global input) INTEGER
00142 *          The dimension of the array RWORK.
00143 *          LRWORK is local input and must be at least
00144 *          LRWORK >= LOCc(JA+N-1)+Nq0.
00145 *
00146 *          IROFF = MOD( IA-1, MB_A ), ICOFF = MOD( JA-1, NB_A ),
00147 *          IAROW = INDXG2P( IA, MB_A, MYROW, RSRC_A, NPROW ),
00148 *          IACOL = INDXG2P( JA, NB_A, MYCOL, CSRC_A, NPCOL ),
00149 *          Mp0   = NUMROC( M+IROFF, MB_A, MYROW, IAROW, NPROW ),
00150 *          Nq0   = NUMROC( N+ICOFF, NB_A, MYCOL, IACOL, NPCOL ),
00151 *          LOCc(JA+N-1) = NUMROC( JA+N-1, NB_A, MYCOL, CSRC_A, NPCOL )
00152 *
00153 *          and NUMROC, INDXG2P are ScaLAPACK tool functions;
00154 *          MYROW, MYCOL, NPROW and NPCOL can be determined by calling
00155 *          the subroutine BLACS_GRIDINFO.
00156 *
00157 *          If LRWORK = -1, then LRWORK is global input and a workspace
00158 *          query is assumed; the routine only calculates the minimum
00159 *          and optimal size for all work arrays. Each of these
00160 *          values is returned in the first entry of the corresponding
00161 *          work array, and no error message is issued by PXERBLA.
00162 *
00163 *
00164 *  INFO    (global output) INTEGER
00165 *          = 0:  successful exit
00166 *          < 0:  If the i-th argument is an array and the j-entry had
00167 *                an illegal value, then INFO = -(i*100+j), if the i-th
00168 *                argument is a scalar and had an illegal value, then
00169 *                INFO = -i.
00170 *
00171 *  Further Details
00172 *  ===============
00173 *
00174 *  The matrix Q is represented as a product of elementary reflectors
00175 *
00176 *     Q = H(1) H(2) . . . H(n)
00177 *
00178 *  Each H(i) has the form
00179 *
00180 *     H = I - tau * v * v'
00181 *
00182 *  where tau is a complex scalar, and v is a complex vector with
00183 *  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
00184 *  A(ia+i-1:ia+m-1,ja+i-1).
00185 *
00186 *  The matrix P is represented in jpvt as follows: If
00187 *     jpvt(j) = i
00188 *  then the jth column of P is the ith canonical unit vector.
00189 *
00190 *  =====================================================================
00191 *
00192 *     .. Parameters ..
00193       INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
00194      $                   LLD_, MB_, M_, NB_, N_, RSRC_
00195       PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
00196      $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
00197      $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
00198       REAL               ONE, ZERO
00199       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
00200 *     ..
00201 *     .. Local Scalars ..
00202       LOGICAL            LQUERY
00203       INTEGER            I, IACOL, IAROW, ICOFF, ICTXT, ICURROW,
00204      $                   ICURCOL, II, IIA, IOFFA, IPCOL, IROFF, ITEMP,
00205      $                   J, JB, JJ, JJA, JJPVT, JN, KB, K, KK, KSTART,
00206      $                   KSTEP, LDA, LL, LRWMIN, LWMIN, MN, MP, MYCOL,
00207      $                   MYROW, NPCOL, NPROW, NQ, NQ0, PVT
00208       REAL               TEMP, TEMP2
00209       COMPLEX            AJJ, ALPHA
00210 *     ..
00211 *     .. Local Arrays ..
00212       INTEGER            DESCN( DLEN_ ), IDUM1( 2 ), IDUM2( 2 )
00213 *     ..
00214 *     .. External Subroutines ..
00215       EXTERNAL           BLACS_GRIDINFO, CCOPY, CGEBR2D, CGEBS2D,
00216      $                   CGERV2D, CGESD2D, CHK1MAT, CLARFG,
00217      $                   CSWAP, DESCSET, IGERV2D, IGESD2D, INFOG1L,
00218      $                   INFOG2L, PCELSET, PCHK1MAT, PCLARFC,
00219      $                   PCLARFG, PSAMAX, PSCNRM2, PXERBLA
00220 *     ..
00221 *     .. External Functions ..
00222       INTEGER            ICEIL, INDXG2P, NUMROC
00223       EXTERNAL           ICEIL, INDXG2P, NUMROC
00224 *     ..
00225 *     .. Intrinsic Functions ..
00226       INTRINSIC          ABS, CMPLX, CONJG, IFIX, MAX, MIN, MOD, SQRT
00227 *     ..
00228 *     .. Executable Statements ..
00229 *
00230 *     Get grid parameters
00231 *
00232       ICTXT = DESCA( CTXT_ )
00233       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
00234 *
00235 *     Test the input parameters
00236 *
00237       INFO = 0
00238       IF( NPROW.EQ.-1 ) THEN
00239          INFO = -(600+CTXT_)
00240       ELSE
00241          CALL CHK1MAT( M, 1, N, 2, IA, JA, DESCA, 6, INFO )
00242          IF( INFO.EQ.0 ) THEN
00243             IROFF = MOD( IA-1, DESCA( MB_ ) )
00244             ICOFF = MOD( JA-1, DESCA( NB_ ) )
00245             IAROW = INDXG2P( IA, DESCA( MB_ ), MYROW, DESCA( RSRC_ ),
00246      $                       NPROW )
00247             IACOL = INDXG2P( JA, DESCA( NB_ ), MYCOL, DESCA( CSRC_ ),
00248      $                       NPCOL )
00249             MP = NUMROC( M+IROFF, DESCA( MB_ ), MYROW, IAROW, NPROW )
00250             NQ = NUMROC( N+ICOFF, DESCA( NB_ ), MYCOL, IACOL, NPCOL )
00251             NQ0 = NUMROC( JA+N-1, DESCA( NB_ ), MYCOL, DESCA( CSRC_ ),
00252      $                    NPCOL )
00253             LWMIN = MAX( 3, MP + NQ )
00254             LRWMIN = NQ0 + NQ
00255 *
00256             WORK( 1 ) = CMPLX( REAL( LWMIN ) )
00257             RWORK( 1 ) = REAL( LRWMIN )
00258             LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 )
00259             IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
00260                INFO = -10
00261             ELSE IF( LRWORK.LT.LRWMIN .AND. .NOT.LQUERY ) THEN
00262                INFO = -12
00263             END IF
00264          END IF
00265          IF( LWORK.EQ.-1 ) THEN
00266             IDUM1( 1 ) = -1
00267          ELSE
00268             IDUM1( 1 ) = 1
00269          END IF
00270          IDUM2( 1 ) = 10
00271          IF( LRWORK.EQ.-1 ) THEN
00272             IDUM1( 2 ) = -1
00273          ELSE
00274             IDUM1( 2 ) = 1
00275          END IF
00276          IDUM2( 2 ) = 12
00277          CALL PCHK1MAT( M, 1, N, 2, IA, JA, DESCA, 6, 2, IDUM1, IDUM2,
00278      $                  INFO )
00279       END IF
00280 *
00281       IF( INFO.NE.0 ) THEN
00282          CALL PXERBLA( ICTXT, 'PCGEQPF', -INFO )
00283          RETURN
00284       ELSE IF( LQUERY ) THEN
00285          RETURN
00286       END IF
00287 *
00288 *     Quick return if possible
00289 *
00290       IF( M.EQ.0 .OR. N.EQ.0 )
00291      $   RETURN
00292 *
00293       CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA, JJA,
00294      $              IAROW, IACOL )
00295       IF( MYROW.EQ.IAROW )
00296      $   MP = MP - IROFF
00297       IF( MYCOL.EQ.IACOL )
00298      $   NQ = NQ - ICOFF
00299       MN = MIN( M, N )
00300 *
00301 *     Initialize the array of pivots
00302 *
00303       LDA = DESCA( LLD_ )
00304       JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 )
00305       KSTEP  = NPCOL * DESCA( NB_ )
00306 *
00307       IF( MYCOL.EQ.IACOL ) THEN
00308 *
00309 *        Handle first block separately
00310 *
00311          JB = JN - JA + 1
00312          DO 10 LL = JJA, JJA+JB-1
00313             IPIV( LL ) = JA + LL - JJA
00314    10    CONTINUE
00315          KSTART = JN + KSTEP - DESCA( NB_ )
00316 *
00317 *        Loop over remaining block of columns
00318 *
00319          DO 30 KK = JJA+JB, JJA+NQ-1, DESCA( NB_ )
00320             KB = MIN( JJA+NQ-KK, DESCA( NB_ ) )
00321             DO 20 LL = KK, KK+KB-1
00322                IPIV( LL ) = KSTART+LL-KK+1
00323    20       CONTINUE
00324             KSTART = KSTART + KSTEP
00325    30    CONTINUE
00326       ELSE
00327          KSTART = JN + ( MOD( MYCOL-IACOL+NPCOL, NPCOL )-1 )*
00328      $                        DESCA( NB_ )
00329          DO 50 KK = JJA, JJA+NQ-1, DESCA( NB_ )
00330             KB = MIN( JJA+NQ-KK, DESCA( NB_ ) )
00331             DO 40 LL = KK, KK+KB-1
00332                IPIV( LL ) = KSTART+LL-KK+1
00333    40       CONTINUE
00334             KSTART = KSTART + KSTEP
00335    50    CONTINUE
00336       END IF
00337 *
00338 *     Initialize partial column norms, handle first block separately
00339 *
00340       CALL DESCSET( DESCN, 1, DESCA( N_ ), 1, DESCA( NB_ ), MYROW,
00341      $              DESCA( CSRC_ ), ICTXT, 1 )
00342 *
00343       JJ = JJA
00344       IF( MYCOL.EQ.IACOL ) THEN
00345          DO 60 KK = 0, JB-1
00346             CALL PSCNRM2( M, RWORK( JJ+KK ), A, IA, JA+KK, DESCA, 1 )
00347             RWORK( NQ+JJ+KK ) = RWORK( JJ+KK )
00348    60    CONTINUE
00349          JJ = JJ + JB
00350       END IF
00351       ICURCOL = MOD( IACOL+1, NPCOL )
00352 *
00353 *     Loop over the remaining blocks of columns
00354 *
00355       DO 80 J = JN+1, JA+N-1, DESCA( NB_ )
00356          JB = MIN( JA+N-J, DESCA( NB_ ) )
00357 *
00358          IF( MYCOL.EQ.ICURCOL ) THEN
00359             DO 70 KK = 0, JB-1
00360                CALL PSCNRM2( M, RWORK( JJ+KK ), A, IA, J+KK, DESCA, 1 )
00361                RWORK( NQ+JJ+KK ) = RWORK( JJ+KK )
00362    70       CONTINUE
00363             JJ = JJ + JB
00364          END IF
00365          ICURCOL = MOD( ICURCOL+1, NPCOL )
00366    80 CONTINUE
00367 *
00368 *     Compute factorization
00369 *
00370       DO 120 J = JA, JA+MN-1
00371          I = IA + J - JA
00372 *
00373          CALL INFOG1L( J, DESCA( NB_ ), NPCOL, MYCOL, DESCA( CSRC_ ),
00374      $                 JJ, ICURCOL )
00375          K = JA + N - J
00376          IF( K.GT.1 ) THEN
00377             CALL PSAMAX( K, TEMP, PVT, RWORK, 1, J, DESCN,
00378      $                   DESCN( M_ ) )
00379          ELSE
00380             PVT = J
00381          END IF
00382          IF( J.NE.PVT ) THEN
00383             CALL INFOG1L( PVT, DESCA( NB_ ), NPCOL, MYCOL,
00384      $                    DESCA( CSRC_ ), JJPVT, IPCOL )
00385             IF( ICURCOL.EQ.IPCOL ) THEN
00386                IF( MYCOL.EQ.ICURCOL ) THEN
00387                   CALL CSWAP( MP, A( IIA+(JJ-1)*LDA ), 1,
00388      $                        A( IIA+(JJPVT-1)*LDA ), 1 )
00389                   ITEMP = IPIV( JJPVT )
00390                   IPIV( JJPVT ) = IPIV( JJ )
00391                   IPIV( JJ ) = ITEMP
00392                   RWORK( JJPVT ) = RWORK( JJ )
00393                   RWORK( NQ+JJPVT ) = RWORK( NQ+JJ )
00394                END IF
00395             ELSE
00396                IF( MYCOL.EQ.ICURCOL ) THEN
00397 *
00398                   CALL CGESD2D( ICTXT, MP, 1, A( IIA+(JJ-1)*LDA ), LDA,
00399      $                          MYROW, IPCOL )
00400                   WORK( 1 ) = CMPLX( REAL( IPIV( JJ ) ) )
00401                   WORK( 2 ) = CMPLX( RWORK( JJ ) )
00402                   WORK( 3 ) = CMPLX( RWORK( JJ + NQ ) )
00403                   CALL CGESD2D( ICTXT, 3, 1, WORK, 3, MYROW, IPCOL )
00404 *
00405                   CALL CGERV2D( ICTXT, MP, 1, A( IIA+(JJ-1)*LDA ), LDA,
00406      $                          MYROW, IPCOL )
00407                   CALL IGERV2D( ICTXT, 1, 1, IPIV( JJ ), 1, MYROW,
00408      $                          IPCOL )
00409 *
00410                ELSE IF( MYCOL.EQ.IPCOL ) THEN
00411 *
00412                   CALL CGESD2D( ICTXT, MP, 1, A( IIA+(JJPVT-1)*LDA ),
00413      $                          LDA, MYROW, ICURCOL )
00414                   CALL IGESD2D( ICTXT, 1, 1, IPIV( JJPVT ), 1, MYROW,
00415      $                          ICURCOL )
00416 *
00417                   CALL CGERV2D( ICTXT, MP, 1, A( IIA+(JJPVT-1)*LDA ),
00418      $                          LDA, MYROW, ICURCOL )
00419                   CALL CGERV2D( ICTXT, 3, 1, WORK, 3, MYROW, ICURCOL )
00420                   IPIV( JJPVT ) = IFIX( REAL( WORK( 1 ) ) )
00421                   RWORK( JJPVT ) = REAL( WORK( 2 ) )
00422                   RWORK( JJPVT+NQ ) = REAL( WORK( 3 ) )
00423 *
00424                END IF
00425 *
00426             END IF
00427 *
00428          END IF
00429 *
00430 *        Generate elementary reflector H(i)
00431 *
00432          CALL INFOG1L( I, DESCA( MB_ ), NPROW, MYROW, DESCA( RSRC_ ),
00433      $                 II, ICURROW )
00434          IF( DESCA( M_ ).EQ.1 ) THEN
00435             IF( MYROW.EQ.ICURROW ) THEN
00436                IF( MYCOL.EQ.ICURCOL ) THEN
00437                   IOFFA = II+(JJ-1)*DESCA( LLD_ )
00438                   AJJ = A( IOFFA )
00439                   CALL CLARFG( 1, AJJ, A( IOFFA ), 1, TAU( JJ ) )
00440                   IF( N.GT.1 ) THEN
00441                      ALPHA = CMPLX( ONE ) - CONJG( TAU( JJ ) )
00442                      CALL CGEBS2D( ICTXT, 'Rowwise', ' ', 1, 1, ALPHA,
00443      $                                  1 )
00444                      CALL CSCAL( NQ-JJ, ALPHA, A( IOFFA+DESCA( LLD_ ) ),
00445      $                           DESCA( LLD_ ) )
00446                   END IF
00447                   CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, 1,
00448      $                          TAU( JJ ), 1 )
00449                   A( IOFFA ) = AJJ
00450                ELSE
00451                   IF( N.GT.1 ) THEN
00452                      CALL CGEBR2D( ICTXT, 'Rowwise', ' ', 1, 1, ALPHA,
00453      $                             1, ICURROW, ICURCOL )
00454                      CALL CSCAL( NQ-JJ+1, ALPHA, A( I ), DESCA( LLD_ ) )
00455                   END IF
00456                END IF
00457             ELSE IF( MYCOL.EQ.ICURCOL ) THEN
00458                CALL CGEBR2D( ICTXT, 'Columnwise', ' ', 1, 1, TAU( JJ ),
00459      $                       1, ICURROW, ICURCOL )
00460             END IF
00461 *
00462          ELSE
00463 *
00464             CALL PCLARFG( M-J+JA, AJJ, I, J, A, MIN( I+1, IA+M-1 ), J,
00465      $                    DESCA, 1, TAU )
00466             IF( J.LT.JA+N-1 ) THEN
00467 *
00468 *              Apply H(i) to A(ia+j-ja:ia+m-1,j+1:ja+n-1) from the left
00469 *
00470                CALL PCELSET( A, I, J, DESCA, CMPLX( ONE ) )
00471                CALL PCLARFC( 'Left', M-J+JA, JA+N-1-J, A, I, J, DESCA,
00472      $                       1, TAU, A, I, J+1, DESCA, WORK )
00473             END IF
00474             CALL PCELSET( A, I, J, DESCA, AJJ )
00475 *
00476          END IF
00477 *
00478 *        Update partial columns norms
00479 *
00480          IF( MYCOL.EQ.ICURCOL )
00481      $      JJ = JJ + 1
00482          IF( MOD( J, DESCA( NB_ ) ).EQ.0 )
00483      $      ICURCOL = MOD( ICURCOL+1, NPCOL )
00484          IF( (JJA+NQ-JJ).GT.0 ) THEN
00485             IF( MYROW.EQ.ICURROW ) THEN
00486                CALL CGEBS2D( ICTXT, 'Columnwise', ' ', 1, JJA+NQ-JJ,
00487      $                       A( II+( MIN( JJA+NQ-1, JJ )-1 )*LDA ),
00488      $                       LDA )
00489                CALL CCOPY( JJA+NQ-JJ, A( II+( MIN( JJA+NQ-1, JJ )
00490      $                     -1)*LDA ), LDA, WORK( MIN( JJA+NQ-1, JJ ) ),
00491      $                     1 )
00492             ELSE
00493                CALL CGEBR2D( ICTXT, 'Columnwise', ' ', JJA+NQ-JJ, 1,
00494      $                       WORK( MIN( JJA+NQ-1, JJ ) ), MAX( 1, NQ ),
00495      $                       ICURROW, MYCOL )
00496             END IF
00497          END IF
00498 *
00499          JN = MIN( ICEIL( J+1, DESCA( NB_ ) ) * DESCA( NB_ ),
00500      $                    JA + N - 1 )
00501          IF( MYCOL.EQ.ICURCOL ) THEN
00502             DO 90 LL = JJ, JJ + JN - J - 1
00503                IF( RWORK( LL ).NE.ZERO ) THEN
00504                   TEMP = ONE-( ABS( WORK( LL ) ) / RWORK( LL ) )**2
00505                   TEMP = MAX( TEMP, ZERO )
00506                   TEMP2 = ONE + 0.05E+0*TEMP*
00507      $                    ( RWORK( LL ) / RWORK( NQ+LL ) )**2
00508                   IF( TEMP2.EQ.ONE ) THEN
00509                      IF( IA+M-1.GT.I ) THEN
00510                         CALL PSCNRM2( IA+M-I-1, RWORK( LL ), A,
00511      $                                I+1, J+LL-JJ, DESCA, 1 )
00512                         RWORK( NQ+LL ) = RWORK( LL )
00513                      ELSE
00514                         RWORK( LL ) = ZERO
00515                         RWORK( NQ+LL ) = ZERO
00516                      END IF
00517                   ELSE
00518                      RWORK( LL ) = RWORK( LL ) * SQRT( TEMP )
00519                   END IF
00520                END IF
00521    90       CONTINUE
00522             JJ = JJ + JN - J
00523          END IF
00524          ICURCOL = MOD( ICURCOL+1, NPCOL )
00525 *
00526          DO 110 K = JN+1, JA+N-1, DESCA( NB_ )
00527             KB = MIN( JA+N-K, DESCA( NB_ ) )
00528 *
00529             IF( MYCOL.EQ.ICURCOL ) THEN
00530                DO 100 LL = JJ, JJ+KB-1
00531                   IF( RWORK(LL).NE.ZERO ) THEN
00532                      TEMP = ONE-( ABS( WORK( LL ) ) / RWORK( LL ) )**2
00533                      TEMP = MAX( TEMP, ZERO )
00534                      TEMP2 = ONE + 0.05E+0*TEMP*
00535      $                       ( RWORK( LL ) / RWORK( NQ+LL ) )**2
00536                      IF( TEMP2.EQ.ONE ) THEN
00537                         IF( IA+M-1.GT.I ) THEN
00538                            CALL PSCNRM2( IA+M-I-1, RWORK( LL ), A,
00539      $                                   I+1, K+LL-JJ, DESCA, 1 )
00540                            RWORK( NQ+LL ) = RWORK( LL )
00541                         ELSE
00542                            RWORK( LL ) = ZERO
00543                            RWORK( NQ+LL ) = ZERO
00544                         END IF
00545                      ELSE
00546                         RWORK( LL ) = RWORK( LL ) * SQRT( TEMP )
00547                      END IF
00548                   END IF
00549   100          CONTINUE
00550                JJ = JJ + KB
00551             END IF
00552             ICURCOL = MOD( ICURCOL+1, NPCOL )
00553 *
00554   110    CONTINUE
00555 *
00556   120 CONTINUE
00557 *
00558       WORK( 1 ) = CMPLX( REAL( LWMIN ) )
00559       RWORK( 1 ) = REAL( LRWMIN )
00560 *
00561       RETURN
00562 *
00563 *     End of PCGEQPF
00564 *
00565       END