ScaLAPACK  2.0.2
ScaLAPACK: Scalable Linear Algebra PACKage
pdormhr.f
Go to the documentation of this file.
00001       SUBROUTINE PDORMHR( SIDE, TRANS, M, N, ILO, IHI, A, IA, JA, DESCA,
00002      $                    TAU, C, IC, JC, DESCC, WORK, LWORK, INFO )
00003 *
00004 *  -- ScaLAPACK routine (version 1.7) --
00005 *     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
00006 *     and University of California, Berkeley.
00007 *     May 1, 1997
00008 *
00009 *     .. Scalar Arguments ..
00010       CHARACTER          SIDE, TRANS
00011       INTEGER            IA, IC, IHI, ILO, INFO, JA, JC, LWORK, M, N
00012 *     ..
00013 *     .. Array Arguments ..
00014       INTEGER            DESCA( * ), DESCC( * )
00015       DOUBLE PRECISION   A( * ), C( * ), TAU( * ), WORK( * )
00016 *     ..
00017 *
00018 *  Purpose
00019 *  =======
00020 *
00021 *  PDORMHR overwrites the general real M-by-N distributed matrix
00022 *  sub( C ) = C(IC:IC+M-1,JC:JC+N-1) with
00023 *
00024 *                       SIDE = 'L'           SIDE = 'R'
00025 *  TRANS = 'N':      Q * sub( C )          sub( C ) * Q
00026 *  TRANS = 'T':      Q**T * sub( C )       sub( C ) * Q**T
00027 *
00028 *  where Q is a real orthogonal distributed matrix of order nq, with
00029 *  nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the
00030 *  product of IHI-ILO elementary reflectors, as returned by PDGEHRD:
00031 *
00032 *  Q = H(ilo) H(ilo+1) . . . H(ihi-1).
00033 *
00034 *  Notes
00035 *  =====
00036 *
00037 *  Each global data object is described by an associated description
00038 *  vector.  This vector stores the information required to establish
00039 *  the mapping between an object element and its corresponding process
00040 *  and memory location.
00041 *
00042 *  Let A be a generic term for any 2D block cyclicly distributed array.
00043 *  Such a global array has an associated description vector DESCA.
00044 *  In the following comments, the character _ should be read as
00045 *  "of the global array".
00046 *
00047 *  NOTATION        STORED IN      EXPLANATION
00048 *  --------------- -------------- --------------------------------------
00049 *  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
00050 *                                 DTYPE_A = 1.
00051 *  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
00052 *                                 the BLACS process grid A is distribu-
00053 *                                 ted over. The context itself is glo-
00054 *                                 bal, but the handle (the integer
00055 *                                 value) may vary.
00056 *  M_A    (global) DESCA( M_ )    The number of rows in the global
00057 *                                 array A.
00058 *  N_A    (global) DESCA( N_ )    The number of columns in the global
00059 *                                 array A.
00060 *  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
00061 *                                 the rows of the array.
00062 *  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
00063 *                                 the columns of the array.
00064 *  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
00065 *                                 row of the array A is distributed.
00066 *  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
00067 *                                 first column of the array A is
00068 *                                 distributed.
00069 *  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
00070 *                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
00071 *
00072 *  Let K be the number of rows or columns of a distributed matrix,
00073 *  and assume that its process grid has dimension p x q.
00074 *  LOCr( K ) denotes the number of elements of K that a process
00075 *  would receive if K were distributed over the p processes of its
00076 *  process column.
00077 *  Similarly, LOCc( K ) denotes the number of elements of K that a
00078 *  process would receive if K were distributed over the q processes of
00079 *  its process row.
00080 *  The values of LOCr() and LOCc() may be determined via a call to the
00081 *  ScaLAPACK tool function, NUMROC:
00082 *          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
00083 *          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
00084 *  An upper bound for these quantities may be computed by:
00085 *          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
00086 *          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
00087 *
00088 *  Arguments
00089 *  =========
00090 *
00091 *  SIDE    (global input) CHARACTER
00092 *          = 'L': apply Q or Q**T from the Left;
00093 *          = 'R': apply Q or Q**T from the Right.
00094 *
00095 *  TRANS   (global input) CHARACTER
00096 *          = 'N':  No transpose, apply Q;
00097 *          = 'T':  Transpose, apply Q**T.
00098 *
00099 *  M       (global input) INTEGER
00100 *          The number of rows to be operated on i.e the number of rows
00101 *          of the distributed submatrix sub( C ). M >= 0.
00102 *
00103 *  N       (global input) INTEGER
00104 *          The number of columns to be operated on i.e the number of
00105 *          columns of the distributed submatrix sub( C ). N >= 0.
00106 *
00107 *  ILO     (global input) INTEGER
00108 *  IHI     (global input) INTEGER
00109 *          ILO and IHI must have the same values as in the previous call
00110 *          of PDGEHRD. Q is equal to the unit matrix except in the
00111 *          distributed submatrix Q(ia+ilo:ia+ihi-1,ia+ilo:ja+ihi-1).
00112 *          If SIDE = 'L', 1 <= ILO <= IHI <= max(1,M);
00113 *          if SIDE = 'R', 1 <= ILO <= IHI <= max(1,N);
00114 *          ILO and IHI are relative indexes.
00115 *
00116 *  A       (local input) DOUBLE PRECISION pointer into the local memory
00117 *          to an array of dimension (LLD_A,LOCc(JA+M-1)) if SIDE='L',
00118 *          and (LLD_A,LOCc(JA+N-1)) if SIDE = 'R'. The vectors which
00119 *          define the elementary reflectors, as returned by PDGEHRD.
00120 *
00121 *  IA      (global input) INTEGER
00122 *          The row index in the global array A indicating the first
00123 *          row of sub( A ).
00124 *
00125 *  JA      (global input) INTEGER
00126 *          The column index in the global array A indicating the
00127 *          first column of sub( A ).
00128 *
00129 *  DESCA   (global and local input) INTEGER array of dimension DLEN_.
00130 *          The array descriptor for the distributed matrix A.
00131 *
00132 *  TAU     (local input) DOUBLE PRECISION array, dimension LOCc(JA+M-2)
00133 *          if SIDE = 'L', and LOCc(JA+N-2) if SIDE = 'R'. This array
00134 *          contains the scalar factors TAU(j) of the elementary
00135 *          reflectors H(j) as returned by PDGEHRD. TAU is tied to
00136 *          the distributed matrix A.
00137 *
00138 *  C       (local input/local output) DOUBLE PRECISION pointer into the
00139 *          local memory to an array of dimension (LLD_C,LOCc(JC+N-1)).
00140 *          On entry, the local pieces of the distributed matrix sub(C).
00141 *          On exit, sub( C ) is overwritten by Q*sub( C ) or Q'*sub( C )
00142 *          or sub( C )*Q' or sub( C )*Q.
00143 *
00144 *  IC      (global input) INTEGER
00145 *          The row index in the global array C indicating the first
00146 *          row of sub( C ).
00147 *
00148 *  JC      (global input) INTEGER
00149 *          The column index in the global array C indicating the
00150 *          first column of sub( C ).
00151 *
00152 *  DESCC   (global and local input) INTEGER array of dimension DLEN_.
00153 *          The array descriptor for the distributed matrix C.
00154 *
00155 *  WORK    (local workspace/local output) DOUBLE PRECISION array,
00156 *                                                     dimension (LWORK)
00157 *          On exit, WORK(1) returns the minimal and optimal LWORK.
00158 *
00159 *  LWORK   (local or global input) INTEGER
00160 *          The dimension of the array WORK.
00161 *          LWORK is local input and must be at least
00162 *
00163 *          IAA = IA + ILO; JAA = JA+ILO-1;
00164 *          If SIDE = 'L',
00165 *            MI = IHI-ILO; NI = N; ICC = IC + ILO; JCC = JC;
00166 *            LWORK >= MAX( (NB_A*(NB_A-1))/2, (NqC0 + MpC0)*NB_A ) +
00167 *                     NB_A * NB_A
00168 *          else if SIDE = 'R',
00169 *            MI = M; NI = IHI-ILO; ICC = IC; JCC = JC + ILO;
00170 *            LWORK >= MAX( (NB_A*(NB_A-1))/2, ( NqC0 + MAX( NpA0 +
00171 *                     NUMROC( NUMROC( NI+ICOFFC, NB_A, 0, 0, NPCOL ),
00172 *                             NB_A, 0, 0, LCMQ ), MpC0 ) )*NB_A ) +
00173 *                     NB_A * NB_A
00174 *          end if
00175 *
00176 *          where LCMQ = LCM / NPCOL with LCM = ICLM( NPROW, NPCOL ),
00177 *
00178 *          IROFFA = MOD( IAA-1, MB_A ), ICOFFA = MOD( JAA-1, NB_A ),
00179 *          IAROW = INDXG2P( IAA, MB_A, MYROW, RSRC_A, NPROW ),
00180 *          NpA0 = NUMROC( NI+IROFFA, MB_A, MYROW, IAROW, NPROW ),
00181 *
00182 *          IROFFC = MOD( ICC-1, MB_C ), ICOFFC = MOD( JCC-1, NB_C ),
00183 *          ICROW = INDXG2P( ICC, MB_C, MYROW, RSRC_C, NPROW ),
00184 *          ICCOL = INDXG2P( JCC, NB_C, MYCOL, CSRC_C, NPCOL ),
00185 *          MpC0 = NUMROC( MI+IROFFC, MB_C, MYROW, ICROW, NPROW ),
00186 *          NqC0 = NUMROC( NI+ICOFFC, NB_C, MYCOL, ICCOL, NPCOL ),
00187 *
00188 *          ILCM, INDXG2P and NUMROC are ScaLAPACK tool functions;
00189 *          MYROW, MYCOL, NPROW and NPCOL can be determined by calling
00190 *          the subroutine BLACS_GRIDINFO.
00191 *
00192 *          If LWORK = -1, then LWORK is global input and a workspace
00193 *          query is assumed; the routine only calculates the minimum
00194 *          and optimal size for all work arrays. Each of these
00195 *          values is returned in the first entry of the corresponding
00196 *          work array, and no error message is issued by PXERBLA.
00197 *
00198 *
00199 *  INFO    (global output) INTEGER
00200 *          = 0:  successful exit
00201 *          < 0:  If the i-th argument is an array and the j-entry had
00202 *                an illegal value, then INFO = -(i*100+j), if the i-th
00203 *                argument is a scalar and had an illegal value, then
00204 *                INFO = -i.
00205 *
00206 *  Alignment requirements
00207 *  ======================
00208 *
00209 *  The distributed submatrices A(IA:*, JA:*) and C(IC:IC+M-1,JC:JC+N-1)
00210 *  must verify some alignment properties, namely the following
00211 *  expressions should be true:
00212 *
00213 *  If SIDE = 'L',
00214 *    ( MB_A.EQ.MB_C .AND. IROFFA.EQ.IROFFC .AND. IAROW.EQ.ICROW )
00215 *  If SIDE = 'R',
00216 *    ( MB_A.EQ.NB_C .AND. IROFFA.EQ.ICOFFC )
00217 *
00218 *  =====================================================================
00219 *
00220 *     .. Parameters ..
00221       INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
00222      $                   LLD_, MB_, M_, NB_, N_, RSRC_
00223       PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
00224      $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
00225      $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
00226 *     ..
00227 *     .. Local Scalars ..
00228       LOGICAL            LEFT, LQUERY, NOTRAN
00229       INTEGER            IAA, IAROW, ICC, ICCOL, ICOFFC, ICROW, ICTXT,
00230      $                   IINFO, IROFFA, IROFFC, JAA, JCC, LCM, LCMQ,
00231      $                   LWMIN, MI, MPC0, MYCOL, MYROW, NH, NI, NPA0,
00232      $                   NPCOL, NPROW, NQ, NQC0
00233 *     ..
00234 *     .. Local Arrays ..
00235       INTEGER            IDUM1( 5 ), IDUM2( 5 )
00236 *     ..
00237 *     .. External Subroutines ..
00238       EXTERNAL           BLACS_GRIDINFO, CHK1MAT, PCHK2MAT, PDORMQR,
00239      $                   PXERBLA
00240 *     ..
00241 *     .. External Functions ..
00242       LOGICAL            LSAME
00243       INTEGER            ILCM, INDXG2P, NUMROC
00244       EXTERNAL           ILCM, INDXG2P, LSAME, NUMROC
00245 *     ..
00246 *     .. Intrinsic Functions ..
00247       INTRINSIC          DBLE, ICHAR, MAX, MIN, MOD
00248 *     ..
00249 *     .. Executable Statements ..
00250 *
00251 *     Get grid parameters
00252 *
00253       ICTXT = DESCA( CTXT_ )
00254       CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
00255 *
00256 *     Test the input parameters
00257 *
00258       INFO = 0
00259       NH = IHI - ILO
00260       IF( NPROW.EQ.-1 ) THEN
00261          INFO = -(1000+CTXT_)
00262       ELSE
00263          LEFT = LSAME( SIDE, 'L' )
00264          NOTRAN = LSAME( TRANS, 'N' )
00265          IAA = IA + ILO
00266          JAA = JA + ILO - 1
00267 *
00268 *        NQ is the order of Q
00269 *
00270          IF( LEFT ) THEN
00271             NQ = M
00272             MI = NH
00273             NI = N
00274             ICC = IC + ILO
00275             JCC = JC
00276             CALL CHK1MAT( M, 3, M, 3, IA, JA, DESCA, 10, INFO )
00277          ELSE
00278             NQ = N
00279             MI = M
00280             NI = NH
00281             ICC = IC
00282             JCC = JC + ILO
00283             CALL CHK1MAT( N, 4, N, 4, IA, JA, DESCA, 10, INFO )
00284          END IF
00285          CALL CHK1MAT( M, 3, N, 4, IC, JC, DESCC, 15, INFO )
00286          IF( INFO.EQ.0 ) THEN
00287             IROFFA = MOD( IAA-1, DESCA( MB_ ) )
00288             IROFFC = MOD( ICC-1, DESCC( MB_ ) )
00289             ICOFFC = MOD( JCC-1, DESCC( NB_ ) )
00290             IAROW = INDXG2P( IAA, DESCA( MB_ ), MYROW, DESCA( RSRC_ ),
00291      $                       NPROW )
00292             ICROW = INDXG2P( ICC, DESCC( MB_ ), MYROW, DESCC( RSRC_ ),
00293      $                       NPROW )
00294             ICCOL = INDXG2P( JCC, DESCC( NB_ ), MYCOL, DESCC( CSRC_ ),
00295      $                       NPCOL )
00296             MPC0 = NUMROC( MI+IROFFC, DESCC( MB_ ), MYROW, ICROW,
00297      $                     NPROW )
00298             NQC0 = NUMROC( NI+ICOFFC, DESCC( NB_ ), MYCOL, ICCOL,
00299      $                     NPCOL )
00300 *
00301             IF( LEFT ) THEN
00302                LWMIN = MAX( ( DESCA( NB_ ) * ( DESCA( NB_ ) - 1 ) ) / 2,
00303      $                      ( MPC0 + NQC0 ) * DESCA( NB_ ) ) +
00304      $                 DESCA( NB_ ) * DESCA( NB_ )
00305             ELSE
00306                NPA0 = NUMROC( NI+IROFFA, DESCA( MB_ ), MYROW, IAROW,
00307      $                        NPROW )
00308                LCM = ILCM( NPROW, NPCOL )
00309                LCMQ = LCM / NPCOL
00310                LWMIN =  MAX( ( DESCA( NB_ ) * ( DESCA( NB_ ) - 1 ) )
00311      $                  / 2, ( NQC0 + MAX( NPA0 + NUMROC( NUMROC(
00312      $                  NI+ICOFFC, DESCA( NB_ ), 0, 0, NPCOL ),
00313      $                  DESCA( NB_ ), 0, 0, LCMQ ), MPC0 ) ) *
00314      $                  DESCA( NB_ ) ) + DESCA( NB_ ) * DESCA( NB_ )
00315             END IF
00316 *
00317             WORK( 1 ) = DBLE( LWMIN )
00318             LQUERY = ( LWORK.EQ.-1 )
00319             IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
00320                INFO = -1
00321             ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND.
00322      $         .NOT.LSAME( TRANS, 'T' ) ) THEN
00323                INFO = -2
00324             ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
00325                INFO = -5
00326             ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
00327                INFO = -6
00328             ELSE IF( .NOT.LEFT .AND. DESCA( MB_ ).NE.DESCC( NB_ ) ) THEN
00329                INFO = -(1000+NB_)
00330             ELSE IF( LEFT .AND. IROFFA.NE.IROFFC ) THEN
00331                INFO = -13
00332             ELSE IF( LEFT .AND. IAROW.NE.ICROW ) THEN
00333                INFO = -13
00334             ELSE IF( .NOT.LEFT .AND. IROFFA.NE.ICOFFC ) THEN
00335                INFO = -14
00336             ELSE IF( LEFT .AND. DESCA( MB_ ).NE.DESCC( MB_ ) ) THEN
00337                INFO = -(1500+MB_)
00338             ELSE IF( ICTXT.NE.DESCC( CTXT_ ) ) THEN
00339                INFO = -(1500+CTXT_)
00340             ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
00341                INFO = -17
00342             END IF
00343          END IF
00344 *
00345          IF( LEFT ) THEN
00346             IDUM1( 1 ) = ICHAR( 'L' )
00347          ELSE
00348             IDUM1( 1 ) = ICHAR( 'R' )
00349          END IF
00350          IDUM2( 1 ) = 1
00351          IF( NOTRAN ) THEN
00352             IDUM1( 2 ) = ICHAR( 'N' )
00353          ELSE
00354             IDUM1( 2 ) = ICHAR( 'T' )
00355          END IF
00356          IDUM2( 2 ) = 2
00357          IDUM1( 3 ) = ILO
00358          IDUM2( 3 ) = 5
00359          IDUM1( 4 ) = IHI
00360          IDUM2( 4 ) = 6
00361          IF( LWORK.EQ.-1 ) THEN
00362             IDUM1( 5 ) = -1
00363          ELSE
00364             IDUM1( 5 ) = 1
00365          END IF
00366          IDUM2( 5 ) = 17
00367          IF( LEFT ) THEN
00368             CALL PCHK2MAT( M, 3, M, 3, IA, JA, DESCA, 10, M, 3, N, 4,
00369      $                     IC, JC, DESCC, 15, 5, IDUM1, IDUM2, INFO )
00370          ELSE
00371             CALL PCHK2MAT( N, 4, N, 4, IA, JA, DESCA, 10, M, 3, N, 4,
00372      $                     IC, JC, DESCC, 15, 5, IDUM1, IDUM2, INFO )
00373          END IF
00374       END IF
00375 *
00376       IF( INFO.NE.0 ) THEN
00377          CALL PXERBLA( ICTXT, 'PDORMHR', -INFO )
00378          RETURN
00379       ELSE IF( LQUERY ) THEN
00380          RETURN
00381       END IF
00382 *
00383 *     Quick return if possible
00384 *
00385       IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 )
00386      $   RETURN
00387 *
00388       CALL PDORMQR( SIDE, TRANS, MI, NI, NH, A, IAA, JAA, DESCA, TAU,
00389      $              C, ICC, JCC, DESCC, WORK, LWORK, IINFO )
00390 *
00391       WORK( 1 ) = DBLE( LWMIN )
00392 *
00393       RETURN
00394 *
00395 *     End of PDORMHR
00396 *
00397       END