ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
pctrevc.f
Go to the documentation of this file.
1  SUBROUTINE pctrevc( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL,
2  $ VR, DESCVR, MM, M, WORK, RWORK, INFO )
3 *
4 * -- ScaLAPACK routine (version 1.7) --
5 * University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6 * and University of California, Berkeley.
7 * July 31, 2001
8 *
9 * .. Scalar Arguments ..
10  CHARACTER HOWMNY, SIDE
11  INTEGER INFO, M, MM, N
12 * ..
13 * .. Array Arguments ..
14  LOGICAL SELECT( * )
15  INTEGER DESCT( * ), DESCVL( * ), DESCVR( * )
16  REAL RWORK( * )
17  COMPLEX T( * ), VL( * ), VR( * ), WORK( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * PCTREVC computes some or all of the right and/or left eigenvectors of
24 * a complex upper triangular matrix T in parallel.
25 *
26 * The right eigenvector x and the left eigenvector y of T corresponding
27 * to an eigenvalue w are defined by:
28 *
29 * T*x = w*x, y'*T = w*y'
30 *
31 * where y' denotes the conjugate transpose of the vector y.
32 *
33 * If all eigenvectors are requested, the routine may either return the
34 * matrices X and/or Y of right or left eigenvectors of T, or the
35 * products Q*X and/or Q*Y, where Q is an input unitary
36 * matrix. If T was obtained from the Schur factorization of an
37 * original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of
38 * right or left eigenvectors of A.
39 *
40 * Notes
41 * =====
42 *
43 * Each global data object is described by an associated description
44 * vector. This vector stores the information required to establish
45 * the mapping between an object element and its corresponding process
46 * and memory location.
47 *
48 * Let A be a generic term for any 2D block cyclicly distributed array.
49 * Such a global array has an associated description vector DESCA.
50 * In the following comments, the character _ should be read as
51 * "of the global array".
52 *
53 * NOTATION STORED IN EXPLANATION
54 * --------------- -------------- --------------------------------------
55 * DTYPE_A(global) DESCA( DTYPE_ )The descriptor type. In this case,
56 * DTYPE_A = 1.
57 * CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
58 * the BLACS process grid A is distribu-
59 * ted over. The context itself is glo-
60 * bal, but the handle (the integer
61 * value) may vary.
62 * M_A (global) DESCA( M_ ) The number of rows in the global
63 * array A.
64 * N_A (global) DESCA( N_ ) The number of columns in the global
65 * array A.
66 * MB_A (global) DESCA( MB_ ) The blocking factor used to distribute
67 * the rows of the array.
68 * NB_A (global) DESCA( NB_ ) The blocking factor used to distribute
69 * the columns of the array.
70 * RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
71 * row of the array A is distributed.
72 * CSRC_A (global) DESCA( CSRC_ ) The process column over which the
73 * first column of the array A is
74 * distributed.
75 * LLD_A (local) DESCA( LLD_ ) The leading dimension of the local
76 * array. LLD_A >= MAX(1,LOCr(M_A)).
77 *
78 * Let K be the number of rows or columns of a distributed matrix,
79 * and assume that its process grid has dimension r x c.
80 * LOCr( K ) denotes the number of elements of K that a process
81 * would receive if K were distributed over the r processes of its
82 * process column.
83 * Similarly, LOCc( K ) denotes the number of elements of K that a
84 * process would receive if K were distributed over the c processes of
85 * its process row.
86 * The values of LOCr() and LOCc() may be determined via a call to the
87 * ScaLAPACK tool function, NUMROC:
88 * LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
89 * LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
90 * An upper bound for these quantities may be computed by:
91 * LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
92 * LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
93 *
94 * Arguments
95 * =========
96 *
97 * SIDE (global input) CHARACTER*1
98 * = 'R': compute right eigenvectors only;
99 * = 'L': compute left eigenvectors only;
100 * = 'B': compute both right and left eigenvectors.
101 *
102 * HOWMNY (global input) CHARACTER*1
103 * = 'A': compute all right and/or left eigenvectors;
104 * = 'B': compute all right and/or left eigenvectors,
105 * and backtransform them using the input matrices
106 * supplied in VR and/or VL;
107 * = 'S': compute selected right and/or left eigenvectors,
108 * specified by the logical array SELECT.
109 *
110 * SELECT (global input) LOGICAL array, dimension (N)
111 * If HOWMNY = 'S', SELECT specifies the eigenvectors to be
112 * computed.
113 * If HOWMNY = 'A' or 'B', SELECT is not referenced.
114 * To select the eigenvector corresponding to the j-th
115 * eigenvalue, SELECT(j) must be set to .TRUE..
116 *
117 * N (global input) INTEGER
118 * The order of the matrix T. N >= 0.
119 *
120 * T (global input/output) COMPLEX array, dimension
121 * (DESCT(LLD_),*)
122 * The upper triangular matrix T. T is modified, but restored
123 * on exit.
124 *
125 * DESCT (global and local input) INTEGER array of dimension DLEN_.
126 * The array descriptor for the distributed matrix T.
127 *
128 * VL (global input/output) COMPLEX array, dimension
129 * (DESCVL(LLD_),MM)
130 * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
131 * contain an N-by-N matrix Q (usually the unitary matrix Q of
132 * Schur vectors returned by CHSEQR).
133 * On exit, if SIDE = 'L' or 'B', VL contains:
134 * if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
135 * if HOWMNY = 'B', the matrix Q*Y;
136 * if HOWMNY = 'S', the left eigenvectors of T specified by
137 * SELECT, stored consecutively in the columns
138 * of VL, in the same order as their
139 * eigenvalues.
140 * If SIDE = 'R', VL is not referenced.
141 *
142 * DESCVL (global and local input) INTEGER array of dimension DLEN_.
143 * The array descriptor for the distributed matrix VL.
144 *
145 * VR (global input/output) COMPLEX array, dimension
146 * (DESCVR(LLD_),MM)
147 * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
148 * contain an N-by-N matrix Q (usually the unitary matrix Q of
149 * Schur vectors returned by CHSEQR).
150 * On exit, if SIDE = 'R' or 'B', VR contains:
151 * if HOWMNY = 'A', the matrix X of right eigenvectors of T;
152 * if HOWMNY = 'B', the matrix Q*X;
153 * if HOWMNY = 'S', the right eigenvectors of T specified by
154 * SELECT, stored consecutively in the columns
155 * of VR, in the same order as their
156 * eigenvalues.
157 * If SIDE = 'L', VR is not referenced.
158 *
159 * DESCVR (global and local input) INTEGER array of dimension DLEN_.
160 * The array descriptor for the distributed matrix VR.
161 *
162 * MM (global input) INTEGER
163 * The number of columns in the arrays VL and/or VR. MM >= M.
164 *
165 * M (global output) INTEGER
166 * The number of columns in the arrays VL and/or VR actually
167 * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
168 * is set to N. Each selected eigenvector occupies one
169 * column.
170 *
171 * WORK (local workspace) COMPLEX array,
172 * dimension ( 2*DESCT(LLD_) )
173 * Additional workspace may be required if PCLATTRS is updated
174 * to use WORK.
175 *
176 * RWORK (local workspace) REAL array,
177 * dimension ( DESCT(LLD_) )
178 *
179 * INFO (global output) INTEGER
180 * = 0: successful exit
181 * < 0: if INFO = -i, the i-th argument had an illegal value
182 *
183 * Further Details
184 * ===============
185 *
186 * The algorithm used in this program is basically backward (forward)
187 * substitution. It is the hope that scaling would be used to make the
188 * the code robust against possible overflow. But scaling has not yet
189 * been implemented in PCLATTRS which is called by this routine to solve
190 * the triangular systems. PCLATTRS just calls PCTRSV.
191 *
192 * Each eigenvector is normalized so that the element of largest
193 * magnitude has magnitude 1; here the magnitude of a complex number
194 * (x,y) is taken to be |x| + |y|.
195 *
196 * Further Details
197 * ===============
198 *
199 * Implemented by Mark R. Fahey, June, 2000
200 *
201 * =====================================================================
202 *
203 * .. Parameters ..
204  REAL ZERO, ONE
205  parameter( zero = 0.0e+0, one = 1.0e+0 )
206  COMPLEX CZERO, CONE
207  parameter( czero = ( 0.0e+0, 0.0e+0 ),
208  $ cone = ( 1.0e+0, 0.0e+0 ) )
209  INTEGER BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
210  $ mb_, nb_, rsrc_, csrc_, lld_
211  parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
212  $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
213  $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
214 * ..
215 * .. Local Scalars ..
216  LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
217  INTEGER CONTXT, CSRC, I, ICOL, II, IROW, IS, ITMP1,
218  $ itmp2, j, k, ki, ldt, ldvl, ldvr, ldw, mb,
219  $ mycol, myrow, nb, npcol, nprow, rsrc
220  REAL SELF
221  REAL OVFL, REMAXD, SCALE, SMIN, SMLNUM, ULP, UNFL
222  COMPLEX CDUM, REMAXC, SHIFT
223 * ..
224 * .. Local Arrays ..
225  INTEGER DESCW( DLEN_ )
226 * ..
227 * .. External Functions ..
228  LOGICAL LSAME
229  REAL PSLAMCH
230  EXTERNAL lsame, pslamch
231 * ..
232 * .. External Subroutines ..
233  EXTERNAL blacs_gridinfo, descinit, sgsum2d, igamn2d,
234  $ infog2l, pslabad, pscasum, pxerbla, pcamax,
235  $ pccopy, pcsscal, pcgemv, pclaset, pclattrs,
236  $ cgsum2d
237 * ..
238 * .. Intrinsic Functions ..
239  INTRINSIC abs, real, cmplx, conjg, aimag, max
240 * ..
241 * .. Statement Functions ..
242  REAL CABS1
243 * ..
244 * .. Statement Function definitions ..
245  cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) )
246 * ..
247 * .. Executable Statements ..
248 *
249 * This is just to keep ftnchek happy
250  IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
251  $ rsrc_.LT.0 )RETURN
252 *
253  contxt = desct( ctxt_ )
254  rsrc = desct( rsrc_ )
255  csrc = desct( csrc_ )
256  mb = desct( mb_ )
257  nb = desct( nb_ )
258  ldt = desct( lld_ )
259  ldw = ldt
260  ldvr = descvr( lld_ )
261  ldvl = descvl( lld_ )
262 *
263  CALL blacs_gridinfo( contxt, nprow, npcol, myrow, mycol )
264  self = myrow*npcol + mycol
265 *
266 * Decode and test the input parameters
267 *
268  bothv = lsame( side, 'B' )
269  rightv = lsame( side, 'R' ) .OR. bothv
270  leftv = lsame( side, 'L' ) .OR. bothv
271 *
272  allv = lsame( howmny, 'A' )
273  over = lsame( howmny, 'B' ) .OR. lsame( howmny, 'O' )
274  somev = lsame( howmny, 'S' )
275 *
276 * Set M to the number of columns required to store the selected
277 * eigenvectors.
278 *
279  IF( somev ) THEN
280  m = 0
281  DO 10 j = 1, n
282  IF( SELECT( j ) )
283  $ m = m + 1
284  10 CONTINUE
285  ELSE
286  m = n
287  END IF
288 *
289  info = 0
290  IF( .NOT.rightv .AND. .NOT.leftv ) THEN
291  info = -1
292  ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
293  info = -2
294  ELSE IF( n.LT.0 ) THEN
295  info = -4
296  ELSE IF( mm.LT.m ) THEN
297  info = -11
298  END IF
299  CALL igamn2d( contxt, 'ALL', ' ', 1, 1, info, 1, itmp1, itmp2, -1,
300  $ -1, -1 )
301  IF( info.LT.0 ) THEN
302  CALL pxerbla( contxt, 'PCTREVC', -info )
303  RETURN
304  END IF
305 *
306 * Quick return if possible.
307 *
308  IF( n.EQ.0 )
309  $ RETURN
310 *
311 * Set the constants to control overflow.
312 *
313  unfl = pslamch( contxt, 'Safe minimum' )
314  ovfl = one / unfl
315  CALL pslabad( contxt, unfl, ovfl )
316  ulp = pslamch( contxt, 'Precision' )
317  smlnum = unfl*( n / ulp )
318 *
319 * Store the diagonal elements of T in working array WORK( LDW+1 ).
320 *
321  DO 20 i = 1, n
322  CALL infog2l( i, i, desct, nprow, npcol, myrow, mycol, irow,
323  $ icol, itmp1, itmp2 )
324  IF( ( myrow.EQ.itmp1 ) .AND. ( mycol.EQ.itmp2 ) ) THEN
325  work( ldw+irow ) = t( ( icol-1 )*ldt+irow )
326  END IF
327  20 CONTINUE
328 *
329 * Compute 1-norm of each column of strictly upper triangular
330 * part of T to control overflow in triangular solver. Computed,
331 * but not used. For use in PCLATTRS.
332 *
333  rwork( 1 ) = zero
334  DO 30 j = 2, n
335  CALL pscasum( j-1, rwork( j ), t, 1, j, desct, 1 )
336  30 CONTINUE
337 * I replicate the norms in RWORK. Should they be distributed
338 * over the process rows?
339  CALL sgsum2d( contxt, 'Row', ' ', n, 1, rwork, n, -1, -1 )
340 *
341  IF( rightv ) THEN
342 *
343 * Compute right eigenvectors.
344 *
345 * Need to set the distribution pattern of WORK
346 *
347  CALL descinit( descw, n, 1, nb, 1, rsrc, csrc, contxt, ldw,
348  $ info )
349 *
350  is = m
351  DO 70 ki = n, 1, -1
352 *
353  IF( somev ) THEN
354  IF( .NOT.SELECT( ki ) )
355  $ GO TO 70
356  END IF
357 *
358  smin = zero
359  shift = czero
360  CALL infog2l( ki, ki, desct, nprow, npcol, myrow, mycol,
361  $ irow, icol, itmp1, itmp2 )
362  IF( ( myrow.EQ.itmp1 ) .AND. ( mycol.EQ.itmp2 ) ) THEN
363  shift = t( ( icol-1 )*ldt+irow )
364  smin = max( ulp*( cabs1( shift ) ), smlnum )
365  END IF
366  CALL sgsum2d( contxt, 'ALL', ' ', 1, 1, smin, 1, -1, -1 )
367  CALL cgsum2d( contxt, 'ALL', ' ', 1, 1, shift, 1, -1, -1 )
368 *
369  CALL infog2l( 1, 1, descw, nprow, npcol, myrow, mycol, irow,
370  $ icol, itmp1, itmp2 )
371  IF( ( myrow.EQ.itmp1 ) .AND. ( mycol.EQ.itmp2 ) ) THEN
372  work( 1 ) = cone
373  END IF
374 *
375 * Form right-hand side. Distribute rhs onto first column
376 * of processor grid.
377 *
378  IF( ki.GT.1 ) THEN
379  CALL pccopy( ki-1, t, 1, ki, desct, 1, work, 1, 1, descw,
380  $ 1 )
381  END IF
382  DO 40 k = 1, ki - 1
383  CALL infog2l( k, 1, descw, nprow, npcol, myrow, mycol,
384  $ irow, icol, itmp1, itmp2 )
385  IF( myrow.EQ.itmp1 .AND. mycol.EQ.itmp2 ) THEN
386  work( irow ) = -work( irow )
387  END IF
388  40 CONTINUE
389 *
390 * Solve the triangular system:
391 * (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK.
392 *
393  DO 50 k = 1, ki - 1
394  CALL infog2l( k, k, desct, nprow, npcol, myrow, mycol,
395  $ irow, icol, itmp1, itmp2 )
396  IF( ( myrow.EQ.itmp1 ) .AND. ( mycol.EQ.itmp2 ) ) THEN
397  t( ( icol-1 )*ldt+irow ) = t( ( icol-1 )*ldt+irow ) -
398  $ shift
399  IF( cabs1( t( ( icol-1 )*ldt+irow ) ).LT.smin ) THEN
400  t( ( icol-1 )*ldt+irow ) = cmplx( smin )
401  END IF
402  END IF
403  50 CONTINUE
404 *
405  IF( ki.GT.1 ) THEN
406  CALL pclattrs( 'Upper', 'No transpose', 'Non-unit', 'Y',
407  $ ki-1, t, 1, 1, desct, work, 1, 1, descw,
408  $ scale, rwork, info )
409  CALL infog2l( ki, 1, descw, nprow, npcol, myrow, mycol,
410  $ irow, icol, itmp1, itmp2 )
411  IF( myrow.EQ.itmp1 .AND. mycol.EQ.itmp2 ) THEN
412  work( irow ) = cmplx( scale )
413  END IF
414  END IF
415 *
416 * Copy the vector x or Q*x to VR and normalize.
417 *
418  IF( .NOT.over ) THEN
419  CALL pccopy( ki, work, 1, 1, descw, 1, vr, 1, is, descvr,
420  $ 1 )
421 *
422  CALL pcamax( ki, remaxc, ii, vr, 1, is, descvr, 1 )
423  remaxd = one / max( cabs1( remaxc ), unfl )
424  CALL pcsscal( ki, remaxd, vr, 1, is, descvr, 1 )
425 *
426  CALL pclaset( ' ', n-ki, 1, czero, czero, vr, ki+1, is,
427  $ descvr )
428  ELSE
429  IF( ki.GT.1 )
430  $ CALL pcgemv( 'N', n, ki-1, cone, vr, 1, 1, descvr,
431  $ work, 1, 1, descw, 1, cmplx( scale ),
432  $ vr, 1, ki, descvr, 1 )
433 *
434  CALL pcamax( n, remaxc, ii, vr, 1, ki, descvr, 1 )
435  remaxd = one / max( cabs1( remaxc ), unfl )
436  CALL pcsscal( n, remaxd, vr, 1, ki, descvr, 1 )
437  END IF
438 *
439 * Set back the original diagonal elements of T.
440 *
441  DO 60 k = 1, ki - 1
442  CALL infog2l( k, k, desct, nprow, npcol, myrow, mycol,
443  $ irow, icol, itmp1, itmp2 )
444  IF( ( myrow.EQ.itmp1 ) .AND. ( mycol.EQ.itmp2 ) ) THEN
445  t( ( icol-1 )*ldt+irow ) = work( ldw+irow )
446  END IF
447  60 CONTINUE
448 *
449  is = is - 1
450  70 CONTINUE
451  END IF
452 *
453  IF( leftv ) THEN
454 *
455 * Compute left eigenvectors.
456 *
457 * Need to set the distribution pattern of WORK
458 *
459  CALL descinit( descw, n, 1, mb, 1, rsrc, csrc, contxt, ldw,
460  $ info )
461 *
462  is = 1
463  DO 110 ki = 1, n
464 *
465  IF( somev ) THEN
466  IF( .NOT.SELECT( ki ) )
467  $ GO TO 110
468  END IF
469 *
470  smin = zero
471  shift = czero
472  CALL infog2l( ki, ki, desct, nprow, npcol, myrow, mycol,
473  $ irow, icol, itmp1, itmp2 )
474  IF( ( myrow.EQ.itmp1 ) .AND. ( mycol.EQ.itmp2 ) ) THEN
475  shift = t( ( icol-1 )*ldt+irow )
476  smin = max( ulp*( cabs1( shift ) ), smlnum )
477  END IF
478  CALL sgsum2d( contxt, 'ALL', ' ', 1, 1, smin, 1, -1, -1 )
479  CALL cgsum2d( contxt, 'ALL', ' ', 1, 1, shift, 1, -1, -1 )
480 *
481  CALL infog2l( n, 1, descw, nprow, npcol, myrow, mycol, irow,
482  $ icol, itmp1, itmp2 )
483  IF( ( myrow.EQ.itmp1 ) .AND. ( mycol.EQ.itmp2 ) ) THEN
484  work( irow ) = cone
485  END IF
486 *
487 * Form right-hand side.
488 *
489  IF( ki.LT.n ) THEN
490  CALL pccopy( n-ki, t, ki, ki+1, desct, n, work, ki+1, 1,
491  $ descw, 1 )
492  END IF
493  DO 80 k = ki + 1, n
494  CALL infog2l( k, 1, descw, nprow, npcol, myrow, mycol,
495  $ irow, icol, itmp1, itmp2 )
496  IF( myrow.EQ.itmp1 .AND. mycol.EQ.itmp2 ) THEN
497  work( irow ) = -conjg( work( irow ) )
498  END IF
499  80 CONTINUE
500 *
501 * Solve the triangular system:
502 * (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK.
503 *
504  DO 90 k = ki + 1, n
505  CALL infog2l( k, k, desct, nprow, npcol, myrow, mycol,
506  $ irow, icol, itmp1, itmp2 )
507  IF( ( myrow.EQ.itmp1 ) .AND. ( mycol.EQ.itmp2 ) ) THEN
508  t( ( icol-1 )*ldt+irow ) = t( ( icol-1 )*ldt+irow ) -
509  $ shift
510  IF( cabs1( t( ( icol-1 )*ldt+irow ) ).LT.smin )
511  $ t( ( icol-1 )*ldt+irow ) = cmplx( smin )
512  END IF
513  90 CONTINUE
514 *
515  IF( ki.LT.n ) THEN
516  CALL pclattrs( 'Upper', 'Conjugate transpose', 'Nonunit',
517  $ 'Y', n-ki, t, ki+1, ki+1, desct, work,
518  $ ki+1, 1, descw, scale, rwork, info )
519  CALL infog2l( ki, 1, descw, nprow, npcol, myrow, mycol,
520  $ irow, icol, itmp1, itmp2 )
521  IF( myrow.EQ.itmp1 .AND. mycol.EQ.itmp2 ) THEN
522  work( irow ) = cmplx( scale )
523  END IF
524  END IF
525 *
526 * Copy the vector x or Q*x to VL and normalize.
527 *
528  IF( .NOT.over ) THEN
529  CALL pccopy( n-ki+1, work, ki, 1, descw, 1, vl, ki, is,
530  $ descvl, 1 )
531 *
532  CALL pcamax( n-ki+1, remaxc, ii, vl, ki, is, descvl, 1 )
533  remaxd = one / max( cabs1( remaxc ), unfl )
534  CALL pcsscal( n-ki+1, remaxd, vl, ki, is, descvl, 1 )
535 *
536  CALL pclaset( ' ', ki-1, 1, czero, czero, vl, 1, is,
537  $ descvl )
538  ELSE
539  IF( ki.LT.n )
540  $ CALL pcgemv( 'N', n, n-ki, cone, vl, 1, ki+1, descvl,
541  $ work, ki+1, 1, descw, 1, cmplx( scale ),
542  $ vl, 1, ki, descvl, 1 )
543 *
544  CALL pcamax( n, remaxc, ii, vl, 1, ki, descvl, 1 )
545  remaxd = one / max( cabs1( remaxc ), unfl )
546  CALL pcsscal( n, remaxd, vl, 1, ki, descvl, 1 )
547  END IF
548 *
549 * Set back the original diagonal elements of T.
550 *
551  DO 100 k = ki + 1, n
552  CALL infog2l( k, k, desct, nprow, npcol, myrow, mycol,
553  $ irow, icol, itmp1, itmp2 )
554  IF( ( myrow.EQ.itmp1 ) .AND. ( mycol.EQ.itmp2 ) ) THEN
555  t( ( icol-1 )*ldt+irow ) = work( ldw+irow )
556  END IF
557  100 CONTINUE
558 *
559  is = is + 1
560  110 CONTINUE
561  END IF
562 *
563  RETURN
564 *
565 * End of PCTREVC
566 *
567  END
cmplx
float cmplx[2]
Definition: pblas.h:132
max
#define max(A, B)
Definition: pcgemr.c:180
pslabad
subroutine pslabad(ICTXT, SMALL, LARGE)
Definition: pslabad.f:2
infog2l
subroutine infog2l(GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
Definition: infog2l.f:3
pclattrs
subroutine pclattrs(UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, DESCA, X, IX, JX, DESCX, SCALE, CNORM, INFO)
Definition: pclattrs.f:3
descinit
subroutine descinit(DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT, LLD, INFO)
Definition: descinit.f:3
pclaset
subroutine pclaset(UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA)
Definition: pcblastst.f:7508
pctrevc
subroutine pctrevc(SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, VR, DESCVR, MM, M, WORK, RWORK, INFO)
Definition: pctrevc.f:3
pxerbla
subroutine pxerbla(ICTXT, SRNAME, INFO)
Definition: pxerbla.f:2