SRC\pdlamr1d.f
#lines: 144   size: 4 Kb   creation: 18/01/2006 23:36:04   last modification: 08/05/2008 18:37:54   attribute: ARCH    Find   Reload   
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
 
      SUBROUTINE PDLAMR1D( N, A, IA, JA, DESCA, B, IB, JB, DESCB )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     October 15, 1999
*
*     .. Scalar Arguments ..
      INTEGER            IA, IB, JA, JB, N
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCB( * )
      DOUBLE PRECISION   A( * ), B( * )
*     ..
*
*  Bugs
*  ====
*
*  I am not sure that this works correctly when IB and JB are not equal
*  to 1.  Indeed, I suspect that IB should always be set to 1 or ignored
*  with 1 used in its place.
*
*  PDLAMR1D has not been tested except withint the contect of
*  PDSYPTRD, the prototype reduction to tridiagonal form code.
*
*  Purpose
*
*  =======
*
*  PDLAMR1D redistributes a one-dimensional row vector from one data
*  decomposition to another.
*
*  This is an auxiliary routine called by PDSYTRD to redistribute D, E
*  and TAU.
*
*  Notes
*  =====
*
*  Although all processes call PDGEMR2D, only the processes that own
*  the first column of A send data and only processes that own the
*  first column of B receive data.  The calls to DGEBS2D/DGEBR2D
*  spread the data down.
*
*  Arguments
*  =========
*
*  N       (global input) INTEGER
*          The size of the matrix to be transposed.
*
*  A       (local output) COMPLEX*16 pointer into the
*          local memory to an array of dimension (LOCc(JA+N-1)).
*          On output, A is replicated across all processes in
*          this processor column.
*
*  IA      (global input) INTEGER
*          A's global row index, which points to the beginning of
*          the submatrix which is to be operated on.
*
*  JA      (global input) INTEGER
*          A's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  B       (local input/local output) COMPLEX*16 pointer into the
*          local memory to an array of dimension (LOCc(JB+N-1)).
*
*  IB      (global input) INTEGER
*          B's global row index,  NOT USED
*
*  JB      (global input) INTEGER
*          B's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*
*  DESCB   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix B.
*
*  WORK    (local workspace) COMPLEX*16 array, dimension ( LWORK )
*
*  LWORK   (local input) INTEGER
*          The dimension of the array WORK.
*          LWORK is local input and must be at least
*          LWORK >= NB * NUMROC( N, 1, 0, 0, NPROW )
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                   CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                   RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICTXT, MYCOL, MYROW, NPCOL, NPROW, NQ
*     ..
*     .. Local Arrays ..
      INTEGER            DESCAA( DLEN_ ), DESCBB( DLEN_ )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DGEBR2D, DGEBS2D, PDGEMR2D
*     ..
*     .. External Functions ..
      INTEGER            NUMROC
      EXTERNAL           NUMROC
*     ..
*     .. Executable Statements ..
*       This is just to keep ftnchek and toolpack/1 happy
      IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
     $    RSRC_.LT.0 )RETURN
*
*     Quick return if possible
*
      IF( N.LE.0 )
     $   RETURN
*
      DO 10 I = 1, DLEN_
         DESCAA( I ) = DESCA( I )
         DESCBB( I ) = DESCB( I )
   10 CONTINUE
*
      DESCAA( M_ ) = 1
      DESCBB( M_ ) = 1
      DESCAA( LLD_ ) = 1
      DESCBB( LLD_ ) = 1
*
      ICTXT = DESCB( CTXT_ )
      CALL PDGEMR2D( 1, N, A, IA, JA, DESCAA, B, IB, JB, DESCBB, ICTXT )
*
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
      NQ = NUMROC( N, DESCB( NB_ ), MYCOL, 0, NPCOL )
*
      IF( MYROW.EQ.0 ) THEN
         CALL DGEBS2D( ICTXT, 'C', ' ', NQ, 1, B, NQ )
      ELSE
         CALL DGEBR2D( ICTXT, 'C', ' ', NQ, 1, B, NQ, 0, MYCOL )
      END IF
*
      RETURN
*
*     End of PDLAMR1D
*
      END