ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pslaedz.f
Go to the documentation of this file.
1  SUBROUTINE pslaedz( N, N1, ID, Q, IQ, JQ, LDQ, DESCQ, Z, WORK )
2 *
3 * -- ScaLAPACK auxiliary routine (version 1.7) --
4 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
5 * and University of California, Berkeley.
6 * December 31, 1998
7 *
8 * .. Scalar Arguments ..
9  INTEGER ID, IQ, JQ, LDQ, N, N1
10 * ..
11 * .. Array Arguments ..
12  INTEGER DESCQ( * )
13  REAL Q( LDQ, * ), WORK( * ), Z( * )
14 * ..
15 *
16 * Purpose
17 * =======
18 *
19 * PSLAEDZ Form the z-vector which consists of the last row of Q_1
20 * and the first row of Q_2.
21 * =====================================================================
22 *
23 * .. Parameters ..
24 *
25  INTEGER BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
26  $ MB_, NB_, RSRC_, CSRC_, LLD_
27  parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
28  $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
29  $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
30 * ..
31 * .. Local Scalars ..
32 *
33  INTEGER COL, I, IBUF, ICTXT, IIQ, IIZ1, IIZ2, IQCOL,
34  $ IQROW, IZ, IZ1, IZ1COL, IZ1ROW, IZ2, IZ2COL,
35  $ IZ2ROW, J, JJQ, JJZ1, JJZ2, MYCOL, MYROW, N2,
36  $ NB, NBLOC, NPCOL, NPROW, NQ1, NQ2, ZSIZ
37 * ..
38 * .. Intrinsic Functions ..
39  INTRINSIC min, mod
40 * ..
41 * .. External Subroutines ..
42  EXTERNAL blacs_gridinfo, infog2l, scopy, sgebr2d,
43  $ sgebs2d, sgerv2d, sgesd2d
44 * ..
45 * .. External Functions ..
46  INTEGER NUMROC
47  EXTERNAL numroc
48 * ..
49 * .. Executable Statements ..
50 *
51 * This is just to keep ftnchek and toolpack/1 happy
52  IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
53  $ rsrc_.LT.0 )RETURN
54 *
55  ictxt = descq( ctxt_ )
56  nb = descq( nb_ )
57  CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
58  CALL infog2l( id, id, descq, nprow, npcol, myrow, mycol, iiq, jjq,
59  $ iqrow, iqcol )
60  n2 = n - n1
61 *
62 * Form z1 which consist of the last row of Q1
63 *
64  CALL infog2l( iq-1+( id+n1-1 ), jq-1+id, descq, nprow, npcol,
65  $ myrow, mycol, iiz1, jjz1, iz1row, iz1col )
66  nq1 = numroc( n1, nb, mycol, iz1col, npcol )
67  IF( ( myrow.EQ.iz1row ) .AND. ( nq1.NE.0 ) ) THEN
68  CALL scopy( nq1, q( iiz1, jjz1 ), ldq, work, 1 )
69  IF( myrow.NE.iqrow .OR. mycol.NE.iqcol )
70  $ CALL sgesd2d( ictxt, nq1, 1, work, nq1, iqrow, iqcol )
71  END IF
72 *
73 * Proc (IQROW, IQCOL) receive the parts of z1
74 *
75  IF( myrow.EQ.iqrow .AND. mycol.EQ.iqcol ) THEN
76  col = iz1col
77  DO 20 i = 0, npcol - 1
78  nq1 = numroc( n1, nb, col, iz1col, npcol )
79  IF( nq1.GT.0 ) THEN
80  IF( iz1row.NE.iqrow .OR. col.NE.iqcol ) THEN
81  ibuf = n1 + 1
82  CALL sgerv2d( ictxt, nq1, 1, work( ibuf ), nq1,
83  $ iz1row, col )
84  ELSE
85  ibuf = 1
86  END IF
87  iz1 = 0
88  iz = i*nb + 1
89  nbloc = ( nq1-1 ) / nb + 1
90  DO 10 j = 1, nbloc
91  zsiz = min( nb, nq1-iz1 )
92  CALL scopy( zsiz, work( ibuf+iz1 ), 1, z( iz ), 1 )
93  iz1 = iz1 + nb
94  iz = iz + nb*npcol
95  10 CONTINUE
96  END IF
97  col = mod( col+1, npcol )
98  20 CONTINUE
99  END IF
100 *
101 * Form z2 which consist of the first row of Q2
102 *
103  CALL infog2l( iq-1+( id+n1 ), jq-1+( id+n1 ), descq, nprow, npcol,
104  $ myrow, mycol, iiz2, jjz2, iz2row, iz2col )
105  nq2 = numroc( n2, nb, mycol, iz2col, npcol )
106  IF( ( myrow.EQ.iz2row ) .AND. ( nq2.NE.0 ) ) THEN
107  CALL scopy( nq2, q( iiz2, jjz2 ), ldq, work, 1 )
108  IF( myrow.NE.iqrow .OR. mycol.NE.iqcol )
109  $ CALL sgesd2d( ictxt, nq2, 1, work, nq2, iqrow, iqcol )
110  END IF
111 *
112 * Proc (IQROW, IQCOL) receive the parts of z2
113 *
114  IF( myrow.EQ.iqrow .AND. mycol.EQ.iqcol ) THEN
115  col = iz2col
116  DO 40 i = 0, npcol - 1
117  nq2 = numroc( n2, nb, col, iz2col, npcol )
118  IF( nq2.GT.0 ) THEN
119  IF( iqrow.NE.iz2row .OR. iqcol.NE.col ) THEN
120  ibuf = 1 + n2
121  CALL sgerv2d( ictxt, nq2, 1, work( ibuf ), nq2,
122  $ iz2row, col )
123  ELSE
124  ibuf = 1
125  END IF
126  iz2 = 0
127  iz = nb*i + n1 + 1
128  nbloc = ( nq2-1 ) / nb + 1
129  DO 30 j = 1, nbloc
130  zsiz = min( nb, nq2-iz2 )
131  CALL scopy( zsiz, work( ibuf+iz2 ), 1, z( iz ), 1 )
132  iz2 = iz2 + nb
133  iz = iz + nb*npcol
134  30 CONTINUE
135  END IF
136  col = mod( col+1, npcol )
137  40 CONTINUE
138  END IF
139 *
140 * proc(IQROW,IQCOL) broadcast Z=(Z1,Z2)
141 *
142  IF( myrow.EQ.iqrow .AND. mycol.EQ.iqcol ) THEN
143  CALL sgebs2d( ictxt, 'All', ' ', n, 1, z, n )
144  ELSE
145  CALL sgebr2d( ictxt, 'All', ' ', n, 1, z, n, iqrow, iqcol )
146  END IF
147 *
148  RETURN
149 *
150 * End of PSLAEDZ
151 *
152 *
153  END
infog2l
subroutine infog2l(GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
Definition: infog2l.f:3
pslaedz
subroutine pslaedz(N, N1, ID, Q, IQ, JQ, LDQ, DESCQ, Z, WORK)
Definition: pslaedz.f:2
min
#define min(A, B)
Definition: pcgemr.c:181