Routine: PSLACP2()  File: SRC\pslacp2.f

 
 
# lines: 406
  # code: 406
  # comment: 0
  # blank:0
# Variables:64
# Callers:1
# Callings:0
# Words:147
# Keywords:86
 

 

..
     .. Array Arguments ..
     ..
  Purpose
  =======
  PSLACP2 copies all or part of a distributed matrix A to another
  distributed matrix B.  No communication is performed, PSLACP2
  performs a local copy sub( A ) := sub( B ), where sub( A ) denotes
  A(IA:IA+M-1,JA:JA+N-1) and sub( B ) denotes B(IB:IB+M-1,JB:JB+N-1).
  PSLACP2 requires that only dimension of the matrix operands is
  distributed.
  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
  =========
  UPLO    (global input) CHARACTER
          Specifies the part of the distributed matrix sub( A ) to be
          copied:
          = 'U':   Upper triangular part is copied; the strictly
                   lower triangular part of sub( A ) is not referenced;
          = 'L':   Lower triangular part is copied; the strictly
                   upper triangular part of sub( A ) is not referenced;
          Otherwise:  All of the matrix sub( A ) is copied.
  M       (global input) INTEGER
          The number of rows to be operated on i.e the number of rows
          of the distributed submatrix sub( A ). 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( A ). N >= 0.
  A       (local input) REAL pointer into the local memory
          to an array of dimension (LLD_A, LOCc(JA+N-1) ). This array
          contains the local pieces of the distributed matrix sub( A )
          to be copied from.
  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.
  B       (local output) REAL pointer into the local memory
          to an array of dimension (LLD_B, LOCc(JB+N-1) ). This array
          contains on exit the local pieces of the distributed matrix
          sub( B ) set as follows:
          if UPLO = 'U', B(IB+i-1,JB+j-1) = A(IA+i-1,JA+j-1),
                         1<=i<=j, 1<=j<=N;
          if UPLO = 'L', B(IB+i-1,JB+j-1) = A(IA+i-1,JA+j-1),
                         j<=i<=M, 1<=j<=N;
          otherwise,     B(IB+i-1,JB+j-1) = A(IA+i-1,JA+j-1),
                         1<=i<=M, 1<=j<=N.
  IB      (global input) INTEGER
          The row index in the global array B indicating the first
          row of sub( B ).
  JB      (global input) INTEGER
          The column index in the global array B indicating the
          first column of sub( B ).
  DESCB   (global and local input) INTEGER array of dimension DLEN_.
          The array descriptor for the distributed matrix B.
  =====================================================================
     .. Parameters ..

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

 
001        SUBROUTINE PSLACP2( UPLO , M , N , A , IA , JA , DESCA , B , IB , JB ,
002       $DESCB )
003  
004  *     -- ScaLAPACK auxiliary routine(version 1.7) --
005  *     University of Tennessee , Knoxville , Oak Ridge National Laboratory ,
006  *     and University of California , Berkeley.
007  *     November 15 , 1997
008  
009  *     .. Scalar Arguments ..
010        CHARACTER UPLO
011        INTEGER IA , IB , JA , JB , 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  *     ..
018  *     .. Local Scalars ..
019        INTEGER HEIGHT , IACOL , IAROW , IBASE , IBCOL , IBROW ,
020       $ICOFFA , IIA , IIAA , IIB , IIBB , IIBEGA , IIBEGB ,
021       $IIENDA , IINXTA , IINXTB , ILEFT , IRIGHT , IROFFA ,
022       $ITOP , JJA , JJAA , JJB , JJBB , JJBEGA , JJBEGB ,
023       $JJENDA , JJNXTA , JJNXTB , LDA , LDB , MBA , MP ,
024       $MPAA , MYCOL , MYDIST , MYROW , NBA , NPCOL , NPROW ,
025       $NQ , NQAA , WIDE
026  *     ..
027  *     .. External Subroutines ..
028        EXTERNAL BLACS_GRIDINFO , INFOG2L , SLACPY
029  *     ..
030  *     .. External Functions ..
031        LOGICAL LSAME
032        INTEGER ICEIL , NUMROC
033        EXTERNAL ICEIL , LSAME , NUMROC
034  *     ..
035  *     .. Intrinsic Functions ..
036        INTRINSIC MAX , MIN , MOD
037  *     ..
038  *     .. Executable Statements ..
039  
040        IF( M.EQ.0 .OR. N.EQ.0 )
041       $    RETURN
042  
043  *         Get grid parameters
044  
045            CALL BLACS_GRIDINFO( DESCA( CTXT_ ) , NPROW , NPCOL , MYROW , MYCOL )
046  
047            CALL INFOG2L( IA , JA , DESCA , NPROW , NPCOL , MYROW , MYCOL , IIA , JJA ,
048       $    IAROW , IACOL )
049            CALL INFOG2L( IB , JB , DESCB , NPROW , NPCOL , MYROW , MYCOL , IIB , JJB ,
050       $    IBROW , IBCOL )
051  
052            MBA = DESCA( MB_ )
053            NBA = DESCA( NB_ )
054            LDA = DESCA( LLD_ )
055            IROFFA = MOD( IA - 1 , MBA )
056            ICOFFA = MOD( JA - 1 , NBA )
057            LDB = DESCB( LLD_ )
058  
059            IF( N.LE.( NBA - ICOFFA ) ) THEN
060  
061  *             It is assumed that the local columns JJA : JJA + N - 1 of the matrix
062  *             A are in the same process column(IACOL).
063  
064  *             N
065  *             JJA JJA + N - 1
066  *             / --------------------- \
067  *             IROFFA| | | |
068  *             \ |...................| |( IAROW )
069  *             IIA |x | | MBA = DESCA( MB_ )
070  *             | x | |
071  *             | -- x ---------------- | /
072  *             | x |
073  *             | x | ITOP
074  *             | x | |
075  *             | x | /------- \
076  *             | ------- x ----------- | | ------- x ----------- |
077  *             | x | | x |
078  *             | x | | x |
079  *             | x | | x |
080  *             | x | | x |
081  *             | ------------ x ------ | | ------------ x ------ |
082  *             | x | \____________ /
083  *             | x | |
084  *             | x | IBASE
085  *             | x |
086  *             | ----------------- x - | Local picture
087  *             | x|
088  *             | |
089  *             | |
090  *             | |
091  *             | ------------------- |
092  *             | |
093  *             . .
094  *             . .
095  *             .(IACOL) .
096  
097                IF( MYCOL.EQ.IACOL ) THEN
098  
099                    MP = NUMROC( M + IROFFA , MBA , MYROW , IAROW , NPROW )
100                    IF( MP.LE.0 )
101       $                RETURN
102                        IF( MYROW.EQ.IAROW )
103       $                    MP = MP - IROFFA
104                            MYDIST = MOD( MYROW - IAROW + NPROW , NPROW )
105                            ITOP = MYDIST * MBA - IROFFA
106  
107                            IF( LSAME( UPLO , 'U' ) ) THEN
108  
109                                ITOP = MAX( 0 , ITOP )
110                                IIBEGA = IIA
111                                IIENDA = IIA + MP - 1
112                                IINXTA = MIN( ICEIL( IIBEGA , MBA ) * MBA , IIENDA )
113                                IIBEGB = IIB
114                                IINXTB = IIBEGB + IINXTA - IIBEGA
115  
116     10 CONTINUE
117        IF(( N - ITOP ).GT.0 ) THEN
118            CALL SLACPY( UPLO , IINXTA - IIBEGA + 1 , N - ITOP ,
119       $    A( IIBEGA + (JJA + ITOP - 1)*LDA ) , LDA ,
120       $    B( IIBEGB + (JJB + ITOP - 1)*LDB ) , LDB )
121            MYDIST = MYDIST + NPROW
122            ITOP = MYDIST * MBA - IROFFA
123            IIBEGA = IINXTA + 1
124            IINXTA = MIN( IINXTA + MBA , IIENDA )
125            IIBEGB = IINXTB + 1
126            IINXTB = IIBEGB + IINXTA - IIBEGA
127            GO TO 10
128        END IF
129  
130        ELSE IF( LSAME( UPLO , 'L' ) ) THEN
131  
132            MPAA = MP
133            IIAA = IIA
134            JJAA = JJA
135            IIBB = IIB
136            JJBB = JJB
137            IBASE = MIN( ITOP + MBA , N )
138            ITOP = MIN( MAX( 0 , ITOP ) , N )
139  
140     20 CONTINUE
141        IF( JJAA.LE.( JJA + N - 1 ) ) THEN
142            HEIGHT = IBASE - ITOP
143            CALL SLACPY( 'All' , MPAA , ITOP - JJAA + JJA ,
144       $    A( IIAA + (JJAA - 1)*LDA ) , LDA ,
145       $    B( IIBB + (JJBB - 1)*LDB ) , LDB )
146            CALL SLACPY( UPLO , MPAA , HEIGHT ,
147       $    A( IIAA + (JJA + ITOP - 1)*LDA ) , LDA ,
148       $    B( IIBB + (JJB + ITOP - 1)*LDB ) , LDB )
149            MPAA = MAX( 0 , MPAA - HEIGHT )
150            IIAA = IIAA + HEIGHT
151            JJAA = JJA + IBASE
152            IIBB = IIBB + HEIGHT
153            JJBB = JJB + IBASE
154            MYDIST = MYDIST + NPROW
155            ITOP = MYDIST * MBA - IROFFA
156            IBASE = MIN( ITOP + MBA , N )
157            ITOP = MIN( ITOP , N )
158            GO TO 20
159        END IF
160  
161        ELSE
162  
163            CALL SLACPY( 'All' , MP , N , A( IIA + (JJA - 1)*LDA ) ,
164       $    LDA , B( IIB + (JJB - 1)*LDB ) , LDB )
165  
166        END IF
167  
168        END IF
169  
170        ELSE IF( M.LE.( MBA - IROFFA ) ) THEN
171  
172  *         It is assumed that the local rows IIA : IIA + M - 1 of the matrix A
173  *         are in the same process row(IAROW).
174  
175  *         ICOFFA
176  *         / \JJA
177  *         IIA ------------------ .... --------
178  *         | .x | | | / | | \
179  *         | . x | | | ILEFT| | | |
180  *         | . x | | | | | |
181  *         | . x | | \ x | |
182  *         | . |x | | |x | | IRIGHT
183  *         | . | x | | | x | |
184  *         (IAROW) | . | x | | | x | |
185  *         | . | x| | | x| |
186  *         | . | x | | x /
187  *         | . | |x | | |
188  *         | . | | x | | |
189  *         | . | | x | | |
190  *         | . | | x| | |
191  *         IIA + M - 1 ------------------ .... -------
192  *         NB_A
193  *         (IACOL) Local picture
194  
195            IF( MYROW.EQ.IAROW ) THEN
196  
197                NQ = NUMROC( N + ICOFFA , NBA , MYCOL , IACOL , NPCOL )
198                IF( NQ.LE.0 )
199       $            RETURN
200                    IF( MYCOL.EQ.IACOL )
201       $                NQ = NQ - ICOFFA
202                        MYDIST = MOD( MYCOL - IACOL + NPCOL , NPCOL )
203                        ILEFT = MYDIST * NBA - ICOFFA
204  
205                        IF( LSAME( UPLO , 'L' ) ) THEN
206  
207                            ILEFT = MAX( 0 , ILEFT )
208                            JJBEGA = JJA
209                            JJENDA = JJA + NQ - 1
210                            JJNXTA = MIN( ICEIL( JJBEGA , NBA ) * NBA , JJENDA )
211                            JJBEGB = JJB
212                            JJNXTB = JJBEGB + JJNXTA - JJBEGA
213  
214     30 CONTINUE
215        IF(( M - ILEFT ).GT.0 ) THEN
216            CALL SLACPY( UPLO , M - ILEFT , JJNXTA - JJBEGA + 1 ,
217       $    A( IIA + ILEFT + (JJBEGA - 1)*LDA ) , LDA ,
218       $    B( IIB + ILEFT + (JJBEGB - 1)*LDB ) , LDB )
219            MYDIST = MYDIST + NPCOL
220            ILEFT = MYDIST * NBA - ICOFFA
221            JJBEGA = JJNXTA + 1
222            JJNXTA = MIN( JJNXTA + NBA , JJENDA )
223            JJBEGB = JJNXTB + 1
224            JJNXTB = JJBEGB + JJNXTA - JJBEGA
225            GO TO 30
226        END IF
227  
228        ELSE IF( LSAME( UPLO , 'U' ) ) THEN
229  
230            NQAA = NQ
231            IIAA = IIA
232            JJAA = JJA
233            IIBB = IIB
234            JJBB = JJB
235            IRIGHT = MIN( ILEFT + NBA , M )
236            ILEFT = MIN( MAX( 0 , ILEFT ) , M )
237  
238     40 CONTINUE
239        IF( IIAA.LE.( IIA + M - 1 ) ) THEN
240            WIDE = IRIGHT - ILEFT
241            CALL SLACPY( 'All' , ILEFT - IIAA + IIA , NQAA ,
242       $    A( IIAA + (JJAA - 1)*LDA ) , LDA ,
243       $    B( IIBB + (JJBB - 1)*LDB ) , LDB )
244            CALL SLACPY( UPLO , WIDE , NQAA ,
245       $    A( IIA + ILEFT + (JJAA - 1)*LDA ) , LDA ,
246       $    B( IIB + ILEFT + (JJBB - 1)*LDB ) , LDB )
247            NQAA = MAX( 0 , NQAA - WIDE )
248            IIAA = IIA + IRIGHT
249            JJAA = JJAA + WIDE
250            IIBB = IIB + IRIGHT
251            JJBB = JJBB + WIDE
252            MYDIST = MYDIST + NPCOL
253            ILEFT = MYDIST * NBA - ICOFFA
254            IRIGHT = MIN( ILEFT + NBA , M )
255            ILEFT = MIN( ILEFT , M )
256            GO TO 40
257        END IF
258  
259        ELSE
260  
261            CALL SLACPY( 'All' , M , NQ , A( IIA + (JJA - 1)*LDA ) ,
262       $    LDA , B( IIB + (JJB - 1)*LDB ) , LDB )
263  
264        END IF
265  
266        END IF
267  
268        END IF
269  
270        RETURN
271  
272  *     End of PSLACP2
273  
274        END