ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pslasrt.f
Go to the documentation of this file.
1  SUBROUTINE pslasrt( ID, N, D, Q, IQ, JQ, DESCQ, WORK, LWORK,
2  $ IWORK, LIWORK, INFO )
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  REAL D( * ), Q( * ), WORK( * )
15 * ..
16 *
17 * Purpose
18 * =======
19 *
20 * PSLASRT 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) REAL array, dimmension (N)
35 * On exit, the number in D are sorted in increasing order.
36 *
37 * Q (local input) REAL 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) REAL 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, scopy,
99  $ sgerv2d, sgesd2d, slamov, slapst
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, 'PSLASRT', -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 slapst( '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 scopy( 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 scopy( 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 scopy( 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 sgesd2d( 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 sgerv2d( 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 scopy( 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 slamov( 'Full', np, nq, work, np, q( iiq ), ldq )
251 *
252 * End of PSLASRT
253 *
254  END
max
#define max(A, B)
Definition: pcgemr.c:180
slapst
subroutine slapst(ID, N, D, INDX, INFO)
Definition: slapst.f:2
chk1mat
subroutine chk1mat(MA, MAPOS0, NA, NAPOS0, IA, JA, DESCA, DESCAPOS0, INFO)
Definition: chk1mat.f:3
pxerbla
subroutine pxerbla(ICTXT, SRNAME, INFO)
Definition: pxerbla.f:2
pslasrt
subroutine pslasrt(ID, N, D, Q, IQ, JQ, DESCQ, WORK, LWORK, IWORK, LIWORK, INFO)
Definition: pslasrt.f:3
min
#define min(A, B)
Definition: pcgemr.c:181