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