Routine: PSORMR2()  File: SRC\psormr2.f

 
 
# lines: 381
  # code: 381
  # comment: 0
  # blank:0
# Variables:57
# Callers:1
# Callings:1
# Words:195
# Keywords:132
 

 

..
     .. Array Arguments ..
     ..
  Purpose
  =======
  PSORMR2 overwrites the general real M-by-N distributed matrix
  sub( C ) = C(IC:IC+M-1,JC:JC+N-1) with
                       SIDE = 'L'          SIDE = 'R'
  TRANS = 'N':      Q * sub( C )         sub(  C ) * Q
  TRANS = 'T':      Q**T * sub( C )      sub( C ) * Q**T
  where Q is a real orthogonal distributed matrix defined as the
  product of K elementary reflectors
        Q = H(1) H(2) . . . H(k)
  as returned by PSGERQF. Q is of order M if SIDE = 'L' and of order N
  if SIDE = 'R'.
  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**T from the Left;
          = 'R': apply Q or Q**T from the Right.
  TRANS   (global input) CHARACTER
          = 'N':  No transpose, apply Q;
          = 'T':  Transpose, apply Q**T.
  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 number of elementary reflectors whose product defines the
          matrix Q.  If SIDE = 'L', M >= K >= 0, if SIDE = 'R',
          N >= K >= 0.
  A       (local input) REAL pointer into the local memory
          to an array of dimension (LLD_A,LOCc(JA+M-1)) if SIDE='L',
          and (LLD_A,LOCc(JA+N-1)) if SIDE='R', where
          LLD_A >= MAX(1,LOCr(IA+K-1)); On entry, the i-th row must
          contain the vector which defines the elementary reflector
          H(i), IA <= i <= IA+K-1, as returned by PSGERQF in the
          K rows of its distributed matrix argument A(IA:IA+K-1,JA:*).
          A(IA:IA+K-1,JA:*) is modified by the routine but restored on
          exit.
  IA      (global input) INTEGER
          The row index in the global array A indicating the first
          row of sub( A ).
  JA      (global input) INTEGER
          The column index in the global array A indicating the
          first column of sub( A ).
  DESCA   (global and local input) INTEGER array of dimension DLEN_.
          The array descriptor for the distributed matrix A.
  TAU     (local input) REAL, array, dimension LOCc(IA+K-1).
          This array contains the scalar factors TAU(i) of the
          elementary reflectors H(i) as returned by PSGERQF.
          TAU is tied to the distributed matrix A.
  C       (local input/local output) REAL pointer into the
          local memory to an array of dimension (LLD_C,LOCc(JC+N-1)).
          On entry, the local pieces of the 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/local output) REAL array,
                                                      dimension (LWORK)
          On exit, WORK(1) returns the minimal and optimal LWORK.
  LWORK   (local or global input) INTEGER
          The dimension of the array WORK.
          LWORK is local input and must be at least
          If SIDE = 'L', LWORK >= MpC0 + MAX( MAX( 1, NqC0 ), NUMROC(
                  NUMROC( M+IROFFC,MB_A,0,0,NPROW ),MB_A,0,0,LCMP ) );
          if SIDE = 'R', LWORK >= NqC0 + MAX( 1, MpC0 );
          where LCMP = LCM / NPROW with LCM = ICLM( NPROW, NPCOL ),
          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 ),
          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.
          If LWORK = -1, then LWORK is global input and a workspace
          query is assumed; the routine only calculates the minimum
          and optimal size for all work arrays. Each of these
          values is returned in the first entry of the corresponding
          work array, and no error message is issued by PXERBLA.
  INFO    (local output) INTEGER
          = 0:  successful exit
          < 0:  If the i-th argument is an array and the j-entry had
                an illegal value, then INFO = -(i*100+j), if the i-th
                argument is a scalar and had an illegal value, then
                INFO = -i.
  Alignment requirements
  ======================
  The distributed submatrices A(IA:*, JA:*) and C(IC:IC+M-1,JC:JC+N-1)
  must verify some alignment properties, namely the following
  expressions should be true:
  If SIDE = 'L',
    ( NB_A.EQ.MB_C .AND. ICOFFA.EQ.IROFFC )
  If SIDE = 'R',
    ( NB_A.EQ.NB_C .AND. ICOFFA.EQ.ICOFFC .AND. IACOL.EQ.ICCOL )
  =====================================================================
     .. Parameters ..

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

 
001        SUBROUTINE PSORMR2( SIDE , TRANS , M , N , K , A , IA , JA , DESCA , TAU ,
002       $C , IC , JC , DESCC , WORK , LWORK , INFO )
003  
004  *     -- ScaLAPACK routine(version 1.7) --
005  *     University of Tennessee , Knoxville , Oak Ridge National Laboratory ,
006  *     and University of California , Berkeley.
007  *     May 25 , 2001
008  
009  *     .. Scalar Arguments ..
010        CHARACTER SIDE , TRANS
011        INTEGER IA , IC , INFO , JA , JC , K , LWORK , M , N
012        INTEGER BLOCK_CYCLIC_2D , CSRC_ , CTXT_ , DLEN_ , DTYPE_ ,
013       $LLD_ , MB_ , M_ , NB_ , N_ , RSRC_
014        PARAMETER( BLOCK_CYCLIC_2D = 1 , DLEN_ = 9 , DTYPE_ = 1 ,
015       $CTXT_ = 2 , M_ = 3 , N_ = 4 , MB_ = 5 , NB_ = 6 ,
016       $RSRC_ = 7 , CSRC_ = 8 , LLD_ = 9 )
017        REAL ONE
018        PARAMETER( ONE = 1.0E + 0 )
019  *     ..
020  *     .. Local Scalars ..
021        LOGICAL LEFT , LQUERY , NOTRAN
022        CHARACTER COLBTOP , ROWBTOP
023        INTEGER I , I1 , I2 , I3 , IACOL , ICCOL , ICOFFA , ICOFFC ,
024       $ICROW , ICTXT , IROFFC , LCM , LCMP , LWMIN , MI ,
025       $MPC0 , MYCOL , MYROW , NI , NPCOL , NPROW , NQ , NQC0
026        REAL AII
027  *     ..
028  *     .. External Subroutines ..
029        EXTERNAL BLACS_ABORT , BLACS_GRIDINFO , CHK1MAT , PSELSET ,
030       $PSELSET2 , PSLARF , PB_TOPGET , PB_TOPSET , PXERBLA
031  *     ..
032  *     .. External Functions ..
033        LOGICAL LSAME
034        INTEGER ILCM , INDXG2P , NUMROC
035        EXTERNAL ILCM , INDXG2P , LSAME , NUMROC
036  *     ..
037  *     .. Intrinsic Functions ..
038        INTRINSIC MAX , MOD , REAL
039  *     ..
040  *     .. Executable Statements ..
041  
042  *     Get grid parameters
043  
044        ICTXT = DESCA( CTXT_ )
045        CALL BLACS_GRIDINFO( ICTXT , NPROW , NPCOL , MYROW , MYCOL )
046  
047  *     Test the input parameters
048  
049        INFO = 0
050        IF( NPROW.EQ. - 1 ) THEN
051            INFO = - (900 + CTXT_)
052        ELSE
053            LEFT = LSAME( SIDE , 'L' )
054            NOTRAN = LSAME( TRANS , 'N' )
055  
056  *         NQ is the order of Q
057  
058            IF( LEFT ) THEN
059                NQ = M
060                CALL CHK1MAT( K , 5 , M , 3 , IA , JA , DESCA , 9 , INFO )
061            ELSE
062                NQ = N
063                CALL CHK1MAT( K , 5 , N , 4 , IA , JA , DESCA , 9 , INFO )
064            END IF
065            CALL CHK1MAT( M , 3 , N , 4 , IC , JC , DESCC , 14 , INFO )
066            IF( INFO.EQ.0 ) THEN
067                ICOFFA = MOD( JA - 1 , DESCA( NB_ ) )
068                IROFFC = MOD( IC - 1 , DESCC( MB_ ) )
069                ICOFFC = MOD( JC - 1 , DESCC( NB_ ) )
070                IACOL = INDXG2P( JA , DESCA( NB_ ) , MYCOL , DESCA( CSRC_ ) ,
071       $        NPCOL )
072                ICROW = INDXG2P( IC , DESCC( MB_ ) , MYROW , DESCC( RSRC_ ) ,
073       $        NPROW )
074                ICCOL = INDXG2P( JC , DESCC( NB_ ) , MYCOL , DESCC( CSRC_ ) ,
075       $        NPCOL )
076                MPC0 = NUMROC( M + IROFFC , DESCC( MB_ ) , MYROW , ICROW , NPROW )
077                NQC0 = NUMROC( N + ICOFFC , DESCC( NB_ ) , MYCOL , ICCOL , NPCOL )
078  
079                IF( LEFT ) THEN
080                    LCM = ILCM( NPROW , NPCOL )
081                    LCMP = LCM / NPROW
082                    LWMIN = MPC0 + MAX( MAX( 1 , NQC0 ) , NUMROC( NUMROC(
083       $            M + IROFFC , DESCA( MB_ ) , 0 , 0 , NPROW ) ,
084       $            DESCA( MB_ ) , 0 , 0 , LCMP ) )
085                ELSE
086                    LWMIN = NQC0 + MAX( 1 , MPC0 )
087                END IF
088  
089                WORK( 1 ) = REAL( LWMIN )
090                LQUERY =( LWORK.EQ. - 1 )
091                IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE , 'R' ) ) THEN
092                    INFO = - 1
093                ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS , 'T' ) ) THEN
094                    INFO = - 2
095                ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
096                    INFO = - 5
097                ELSE IF( LEFT .AND. DESCA( NB_ ).NE.DESCC( MB_ ) ) THEN
098                    INFO = - (900 + NB_)
099                ELSE IF( LEFT .AND. ICOFFA.NE.IROFFC ) THEN
100                    INFO = - 12
101                ELSE IF( .NOT.LEFT .AND. ICOFFA.NE.ICOFFC ) THEN
102                    INFO = - 13
103                ELSE IF( .NOT.LEFT .AND. IACOL.NE.ICCOL ) THEN
104                    INFO = - 13
105                ELSE IF( .NOT.LEFT .AND. DESCA( NB_ ).NE.DESCC( NB_ ) ) THEN
106                    INFO = - (1400 + NB_)
107                ELSE IF( ICTXT.NE.DESCC( CTXT_ ) ) THEN
108                    INFO = - (1400 + CTXT_)
109                ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
110                    INFO = - 16
111                END IF
112            END IF
113        END IF
114  
115        IF( INFO.NE.0 ) THEN
116            CALL PXERBLA( ICTXT , 'PSORMR2' , - INFO )
117            CALL BLACS_ABORT( ICTXT , 1 )
118            RETURN
119        ELSE IF( LQUERY ) THEN
120            RETURN
121        END IF
122  
123  *     Quick return if possible
124  
125        IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
126       $    RETURN
127  
128            CALL PB_TOPGET( ICTXT , 'Broadcast' , 'Rowwise' , ROWBTOP )
129            CALL PB_TOPGET( ICTXT , 'Broadcast' , 'Columnwise' , COLBTOP )
130  
131            IF(( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
132                I1 = IA
133                I2 = IA + K - 1
134                I3 = 1
135            ELSE
136                I1 = IA + K - 1
137                I2 = IA
138                I3 = - 1
139            END IF
140  
141            IF( LEFT ) THEN
142                NI = N
143            ELSE
144                MI = M
145                CALL PB_TOPSET( ICTXT , 'Broadcast' , 'Rowwise' , ' ' )
146                IF( NOTRAN ) THEN
147                    CALL PB_TOPSET( ICTXT , 'Broadcast' , 'Columnwise' , 'I - ring' )
148                ELSE
149                    CALL PB_TOPSET( ICTXT , 'Broadcast' , 'Columnwise' , 'D - ring' )
150                END IF
151            END IF
152  
153            DO 10 I = I1 , I2 , I3
154                IF( LEFT ) THEN
155  
156  *                 H(i) or H(i)' is applied to C(ic : ic + m - k + i - ia , jc : jc + n - 1)
157  
158                    MI = M - K + I - IA + 1
159                ELSE
160  
161  *                 H(i) or H(i)' is applied to C(ic : ic + m - 1 , jc : jc + n - k + i - ia + 1)
162  
163                    NI = N - K + I - IA + 1
164                END IF
165  
166  *             Apply H(i) or H(i)'
167  
168                CALL PSELSET2( AII , A , I , JA + NQ - K + I - IA , DESCA , ONE )
169                CALL PSLARF ( SIDE , MI , NI , A , I , JA , DESCA , DESCA( M_ ) ,
170       $        TAU , C , IC , JC , DESCC , WORK )
171                CALL PSELSET( A , I , JA + NQ - K + I - IA , DESCA , AII )
172  
173     10     CONTINUE
174  
175            CALL PB_TOPSET( ICTXT , 'Broadcast' , 'Rowwise' , ROWBTOP )
176            CALL PB_TOPSET( ICTXT , 'Broadcast' , 'Columnwise' , COLBTOP )
177  
178            WORK( 1 ) = REAL( LWMIN )
179  
180            RETURN
181  
182  *         End of PSORMR2
183  
184        END