SRC\pslaedz.f
#lines: 153   size: 5 Kb   creation: 18/01/2006 23:36:04   last modification: 08/05/2008 18:38:04   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:
145:
146:
147:
148:
149:
150:
151:
152:
153:
 
      SUBROUTINE PSLAEDZ( N, N1, ID, Q, IQ, JQ, LDQ, DESCQ, Z, WORK )
*
*  -- ScaLAPACK auxiliary routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     December 31, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ID, IQ, JQ, LDQ, N, N1
*     ..
*     .. Array Arguments ..
      INTEGER            DESCQ( * )
      REAL               Q( LDQ, * ), WORK( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  PSLAEDZ Form the z-vector which consists of the last row of Q_1
*  and the first row of Q_2.
*  =====================================================================
*
*     .. 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            COL, I, IBUF, ICTXT, IIQ, IIZ1, IIZ2, IQCOL,
     $                   IQROW, IZ, IZ1, IZ1COL, IZ1ROW, IZ2, IZ2COL,
     $                   IZ2ROW, J, JJQ, JJZ1, JJZ2, MYCOL, MYROW, N2,
     $                   NB, NBLOC, NPCOL, NPROW, NQ1, NQ2, ZSIZ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MIN, MOD
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, INFOG2L, SCOPY, SGEBR2D,
     $                   SGEBS2D, SGERV2D, SGESD2D
*     ..
*     .. 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
*
      ICTXT = DESCQ( CTXT_ )
      NB = DESCQ( NB_ )
      CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
      CALL INFOG2L( ID, ID, DESCQ, NPROW, NPCOL, MYROW, MYCOL, IIQ, JJQ,
     $              IQROW, IQCOL )
      N2 = N - N1
*
*     Form z1 which consist of the last row of Q1
*
      CALL INFOG2L( IQ-1+( ID+N1-1 ), JQ-1+ID, DESCQ, NPROW, NPCOL,
     $              MYROW, MYCOL, IIZ1, JJZ1, IZ1ROW, IZ1COL )
      NQ1 = NUMROC( N1, NB, MYCOL, IZ1COL, NPCOL )
      IF( ( MYROW.EQ.IZ1ROW ) .AND. ( NQ1.NE.0 ) ) THEN
         CALL SCOPY( NQ1, Q( IIZ1, JJZ1 ), LDQ, WORK, 1 )
         IF( MYROW.NE.IQROW .OR. MYCOL.NE.IQCOL )
     $      CALL SGESD2D( ICTXT, NQ1, 1, WORK, NQ1, IQROW, IQCOL )
      END IF
*
*     Proc (IQROW, IQCOL) receive the parts of z1
*
      IF( MYROW.EQ.IQROW .AND. MYCOL.EQ.IQCOL ) THEN
         COL = IZ1COL
         DO 20 I = 0, NPCOL - 1
            NQ1 = NUMROC( N1, NB, COL, IZ1COL, NPCOL )
            IF( NQ1.GT.0 ) THEN
               IF( IZ1ROW.NE.IQROW .OR. COL.NE.IQCOL ) THEN
                  IBUF = N1 + 1
                  CALL SGERV2D( ICTXT, NQ1, 1, WORK( IBUF ), NQ1,
     $                          IZ1ROW, COL )
               ELSE
                  IBUF = 1
               END IF
               IZ1 = 0
               IZ = I*NB + 1
               NBLOC = ( NQ1-1 ) / NB + 1
               DO 10 J = 1, NBLOC
                  ZSIZ = MIN( NB, NQ1-IZ1 )
                  CALL SCOPY( ZSIZ, WORK( IBUF+IZ1 ), 1, Z( IZ ), 1 )
                  IZ1 = IZ1 + NB
                  IZ = IZ + NB*NPCOL
   10          CONTINUE
            END IF
            COL = MOD( COL+1, NPCOL )
   20    CONTINUE
      END IF
*
*     Form z2 which consist of the first row of Q2
*
      CALL INFOG2L( IQ-1+( ID+N1 ), JQ-1+( ID+N1 ), DESCQ, NPROW, NPCOL,
     $              MYROW, MYCOL, IIZ2, JJZ2, IZ2ROW, IZ2COL )
      NQ2 = NUMROC( N2, NB, MYCOL, IZ2COL, NPCOL )
      IF( ( MYROW.EQ.IZ2ROW ) .AND. ( NQ2.NE.0 ) ) THEN
         CALL SCOPY( NQ2, Q( IIZ2, JJZ2 ), LDQ, WORK, 1 )
         IF( MYROW.NE.IQROW .OR. MYCOL.NE.IQCOL )
     $      CALL SGESD2D( ICTXT, NQ2, 1, WORK, NQ2, IQROW, IQCOL )
      END IF
*
*     Proc (IQROW, IQCOL) receive the parts of z2
*
      IF( MYROW.EQ.IQROW .AND. MYCOL.EQ.IQCOL ) THEN
         COL = IZ2COL
         DO 40 I = 0, NPCOL - 1
            NQ2 = NUMROC( N2, NB, COL, IZ2COL, NPCOL )
            IF( NQ2.GT.0 ) THEN
               IF( IQROW.NE.IZ2ROW .OR. IQCOL.NE.COL ) THEN
                  IBUF = 1 + N2
                  CALL SGERV2D( ICTXT, NQ2, 1, WORK( IBUF ), NQ2,
     $                          IZ2ROW, COL )
               ELSE
                  IBUF = 1
               END IF
               IZ2 = 0
               IZ = NB*I + N1 + 1
               NBLOC = ( NQ2-1 ) / NB + 1
               DO 30 J = 1, NBLOC
                  ZSIZ = MIN( NB, NQ2-IZ2 )
                  CALL SCOPY( ZSIZ, WORK( IBUF+IZ2 ), 1, Z( IZ ), 1 )
                  IZ2 = IZ2 + NB
                  IZ = IZ + NB*NPCOL
   30          CONTINUE
            END IF
            COL = MOD( COL+1, NPCOL )
   40    CONTINUE
      END IF
*
*     proc(IQROW,IQCOL) broadcast Z=(Z1,Z2)
*
      IF( MYROW.EQ.IQROW .AND. MYCOL.EQ.IQCOL ) THEN
         CALL SGEBS2D( ICTXT, 'All', ' ', N, 1, Z, N )
      ELSE
         CALL SGEBR2D( ICTXT, 'All', ' ', N, 1, Z, N, IQROW, IQCOL )
      END IF
*
      RETURN
*
*     End of PSLAEDZ
*
*
      END