SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ pdlasrt()

subroutine pdlasrt ( character  id,
integer  n,
double precision, dimension( * )  d,
double precision, dimension( * )  q,
integer  iq,
integer  jq,
integer, dimension( * )  descq,
double precision, dimension( * )  work,
integer  lwork,
integer, dimension( * )  iwork,
integer  liwork,
integer  info 
)

Definition at line 1 of file pdlasrt.f.

3*
4* -- ScaLAPACK auxiliary routine (version 2.0.2) --
5* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
6* May 1 2012
7*
8* .. Scalar Arguments ..
9 CHARACTER ID
10 INTEGER INFO, IQ, JQ, LIWORK, LWORK, N
11* ..
12* .. Array Arguments ..
13 INTEGER DESCQ( * ), IWORK( * )
14 DOUBLE PRECISION D( * ), Q( * ), WORK( * )
15* ..
16*
17* Purpose
18* =======
19*
20* PDLASRT Sort the numbers in D in increasing order and the
21* corresponding vectors in Q.
22*
23* Arguments
24* =========
25*
26* ID (global input) CHARACTER*1
27* = 'I': sort D in increasing order;
28* = 'D': sort D in decreasing order. (NOT IMPLEMENTED YET)
29*
30* N (global input) INTEGER
31* The number of columns to be operated on i.e the number of
32* columns of the distributed submatrix sub( Q ). N >= 0.
33*
34* D (global input/output) DOUBLE PRECISION array, dimmension (N)
35* On exit, the number in D are sorted in increasing order.
36*
37* Q (local input) DOUBLE PRECISION pointer into the local memory
38* to an array of dimension (LLD_Q, LOCc(JQ+N-1) ). This array
39* contains the local pieces of the distributed matrix sub( A )
40* to be copied from.
41*
42* IQ (global input) INTEGER
43* The row index in the global array A indicating the first
44* row of sub( Q ).
45*
46* JQ (global input) INTEGER
47* The column index in the global array A indicating the
48* first column of sub( Q ).
49*
50* DESCQ (global and local input) INTEGER array of dimension DLEN_.
51* The array descriptor for the distributed matrix A.
52*
53* WORK (local workspace/local output) DOUBLE PRECISION array,
54* dimension (LWORK)
55* LWORK (local or global input) INTEGER
56* The dimension of the array WORK.
57* LWORK = MAX( N, NP * ( NB + NQ ))
58* where
59* NP = NUMROC( N, NB, MYROW, IAROW, NPROW ),
60* NQ = NUMROC( N, NB, MYCOL, DESCQ( CSRC_ ), NPCOL )
61*
62* IWORK (local workspace/local output) INTEGER array,
63* dimension (LIWORK)
64*
65* LIWORK (local or global input) INTEGER
66* The dimension of the array IWORK.
67* LIWORK = N + 2*NB + 2*NPCOL
68*
69* INFO (global output) INTEGER
70* = 0: successful exit
71* < 0: If the i-th argument is an array and the j-entry had
72* an illegal value, then INFO = -(i*100+j), if the i-th
73* argument is a scalar and had an illegal value, then
74* INFO = -i.
75*
76* =====================================================================
77*
78* .. Parameters ..
79 INTEGER BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
80 $ MB_, NB_, RSRC_, CSRC_, LLD_
81 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
82 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
83 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
84* ..
85* .. Local Scalars ..
86 INTEGER CL, COL, DUMMY, I, ICTXT, IID, IIQ, INDCOL,
87 $ INDX, INDXC, INDXG, IPQ, IPQ2, IPW, IPWORK, J,
88 $ JJQ, K, L, LDQ, LEND, LIWMIN, LWMIN, MYCOL,
89 $ MYROW, NB, ND, NP, NPCOL, NPROW, NQ, PSQ, QCOL,
90 $ QTOT, SBUF
91* ..
92* .. External Functions ..
93 LOGICAL LSAME
94 INTEGER INDXG2L, INDXG2P, NUMROC
95 EXTERNAL indxg2l, indxg2p, lsame, numroc
96* ..
97* .. External Subroutines ..
98 EXTERNAL blacs_gridinfo, chk1mat, pxerbla, dcopy,
99 $ dgerv2d, dgesd2d, dlamov, dlapst
100* ..
101* .. Intrinsic Functions ..
102 INTRINSIC max, min, mod
103* ..
104* .. Executable Statements ..
105*
106* This is just to keep ftnchek and toolpack/1 happy
107 IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
108 $ rsrc_.LT.0 )RETURN
109*
110 IF( n.EQ.0 )
111 $ RETURN
112*
113 ictxt = descq( ctxt_ )
114 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
115*
116* Test the input parameters
117*
118 info = 0
119 IF( nprow.EQ.-1 ) THEN
120 info = -( 600+ctxt_ )
121 ELSE
122 CALL chk1mat( n, 1, n, 1, iq, jq, descq, 6, info )
123 IF( info.EQ.0 ) THEN
124 nb = descq( nb_ )
125 ldq = descq( lld_ )
126 np = numroc( n, nb, myrow, descq( rsrc_ ), nprow )
127 nq = numroc( n, nb, mycol, descq( csrc_ ), npcol )
128 lwmin = max( n, np*( nb+nq ) )
129 liwmin = n + 2*( nb+npcol )
130 IF( .NOT.lsame( id, 'I' ) ) THEN
131 info = -1
132 ELSE IF( n.LT.0 ) THEN
133 info = -2
134 ELSE IF( lwork.LT.lwmin ) THEN
135 info = -9
136 ELSE IF( liwork.LT.liwmin ) THEN
137 info = -11
138 END IF
139 END IF
140 END IF
141*
142 IF( info.NE.0 ) THEN
143 CALL pxerbla( ictxt, 'PDLASRT', -info )
144 RETURN
145 END IF
146*
147* Set Pointers
148*
149 indxc = 1
150 indx = indxc + n
151 indxg = indx
152 indcol = indxg + nb
153 qtot = indcol + nb
154 psq = qtot + npcol
155*
156 iid = 1
157 ipq2 = 1
158 ipw = ipq2 + np*nq
159*
160 dummy = 0
161 iiq = indxg2l( iq, nb, dummy, dummy, nprow )
162*
163* Sort the eigenvalues in D
164*
165 CALL dlapst( 'I', n, d, iwork( indx ), info )
166*
167 DO 10 l = 0, n - 1
168 work( iid+l ) = d( iwork( indx+l ) )
169 iwork( indxc-1+iwork( indx+l ) ) = iid + l
170 10 CONTINUE
171 CALL dcopy( n, work, 1, d, 1 )
172*
173 nd = 0
174 20 CONTINUE
175 IF( nd.LT.n ) THEN
176 lend = min( nb, n-nd )
177 j = jq + nd
178 qcol = indxg2p( j, nb, dummy, descq( csrc_ ), npcol )
179 k = 0
180 DO 30 l = 0, lend - 1
181 i = jq - 1 + iwork( indxc+nd+l )
182 cl = indxg2p( i, nb, dummy, descq( csrc_ ), npcol )
183 iwork( indcol+l ) = cl
184 IF( mycol.EQ.cl ) THEN
185 iwork( indxg+k ) = iwork( indxc+nd+l )
186 k = k + 1
187 END IF
188 30 CONTINUE
189*
190 IF( mycol.EQ.qcol ) THEN
191 DO 40 cl = 0, npcol - 1
192 iwork( qtot+cl ) = 0
193 40 CONTINUE
194 DO 50 l = 0, lend - 1
195 iwork( qtot+iwork( indcol+l ) ) = iwork( qtot+
196 $ iwork( indcol+l ) ) + 1
197 50 CONTINUE
198 iwork( psq ) = 1
199 DO 60 cl = 1, npcol - 1
200 iwork( psq+cl ) = iwork( psq+cl-1 ) + iwork( qtot+cl-1 )
201 60 CONTINUE
202 DO 70 l = 0, lend - 1
203 cl = iwork( indcol+l )
204 i = jq + nd + l
205 jjq = indxg2l( i, nb, dummy, dummy, npcol )
206 ipq = iiq + ( jjq-1 )*ldq
207 ipwork = ipw + ( iwork( psq+cl )-1 )*np
208 CALL dcopy( np, q( ipq ), 1, work( ipwork ), 1 )
209 iwork( psq+cl ) = iwork( psq+cl ) + 1
210 70 CONTINUE
211 iwork( psq ) = 1
212 DO 80 cl = 1, npcol - 1
213 iwork( psq+cl ) = iwork( psq+cl-1 ) + iwork( qtot+cl-1 )
214 80 CONTINUE
215 DO 90 l = 0, k - 1
216 i = iwork( indxg+l )
217 jjq = indxg2l( i, nb, dummy, dummy, npcol )
218 ipq = ipq2 + ( jjq-1 )*np
219 ipwork = ipw + ( iwork( psq+mycol )-1 )*np
220 CALL dcopy( np, work( ipwork ), 1, work( ipq ), 1 )
221 iwork( psq+mycol ) = iwork( psq+mycol ) + 1
222 90 CONTINUE
223 DO 100 cl = 1, npcol - 1
224 col = mod( mycol+cl, npcol )
225 sbuf = iwork( qtot+col )
226 IF( sbuf.NE.0 ) THEN
227 ipwork = ipw + ( iwork( psq+col )-1 )*np
228 CALL dgesd2d( descq( ctxt_ ), np, sbuf,
229 $ work( ipwork ), np, myrow, col )
230 END IF
231 100 CONTINUE
232*
233 ELSE
234*
235 IF( k.NE.0 ) THEN
236 CALL dgerv2d( descq( ctxt_ ), np, k, work( ipw ), np,
237 $ myrow, qcol )
238 DO 110 l = 0, k - 1
239 i = jq - 1 + iwork( indxg+l )
240 jjq = indxg2l( i, nb, dummy, dummy, npcol )
241 ipq = 1 + ( jjq-1 )*np
242 ipwork = ipw + l*np
243 CALL dcopy( np, work( ipwork ), 1, work( ipq ), 1 )
244 110 CONTINUE
245 END IF
246 END IF
247 nd = nd + nb
248 GO TO 20
249 END IF
250 CALL dlamov( 'Full', np, nq, work, np, q( iiq ), ldq )
251*
252* End of PDLASRT
253*
chk1mat
subroutine chk1mat(ma, mapos0, na, napos0, ia, ja, desca, descapos0, info)
Definition chk1mat.f:3
dlapst
subroutine dlapst(id, n, d, indx, info)
Definition dlapst.f:2
indxg2l
integer function indxg2l(indxglob, nb, iproc, isrcproc, nprocs)
Definition indxg2l.f:2
indxg2p
integer function indxg2p(indxglob, nb, iproc, isrcproc, nprocs)
Definition indxg2p.f:2
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition numroc.f:2
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pxerbla
subroutine pxerbla(ictxt, srname, info)
Definition pxerbla.f:2
lsame
logical function lsame(ca, cb)
Definition tools.f:1724
Here is the call graph for this function:
Here is the caller graph for this function: