Mercurial > octave-nkf

comparison libcruft/lapack/cgebak.f @ 7789:82be108cc558

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First attempt at single precision tyeps * * * corrections to qrupdate single precision routines * * * prefer demotion to single over promotion to double * * * Add single precision support to log2 function * * * Trivial PROJECT file update * * * Cache optimized hermitian/transpose methods * * * Add tests for tranpose/hermitian and ChangeLog entry for new transpose code
author David Bateman <dbateman@free.fr>
date Sun, 27 Apr 2008 22:34:17 +0200
parents
children
comparison
equal deleted inserted replaced
7788:45f5faba05a2 7789:82be108cc558
1 SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
2 $ INFO )
3 *
4 * -- LAPACK routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2006
7 *
8 * .. Scalar Arguments ..
9 CHARACTER JOB, SIDE
10 INTEGER IHI, ILO, INFO, LDV, M, N
11 * ..
12 * .. Array Arguments ..
13 REAL SCALE( * )
14 COMPLEX V( LDV, * )
15 * ..
16 *
17 * Purpose
18 * =======
19 *
20 * CGEBAK forms the right or left eigenvectors of a complex general
21 * matrix by backward transformation on the computed eigenvectors of the
22 * balanced matrix output by CGEBAL.
23 *
24 * Arguments
25 * =========
26 *
27 * JOB (input) CHARACTER*1
28 * Specifies the type of backward transformation required:
29 * = 'N', do nothing, return immediately;
30 * = 'P', do backward transformation for permutation only;
31 * = 'S', do backward transformation for scaling only;
32 * = 'B', do backward transformations for both permutation and
33 * scaling.
34 * JOB must be the same as the argument JOB supplied to CGEBAL.
35 *
36 * SIDE (input) CHARACTER*1
37 * = 'R': V contains right eigenvectors;
38 * = 'L': V contains left eigenvectors.
39 *
40 * N (input) INTEGER
41 * The number of rows of the matrix V. N >= 0.
42 *
43 * ILO (input) INTEGER
44 * IHI (input) INTEGER
45 * The integers ILO and IHI determined by CGEBAL.
46 * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
47 *
48 * SCALE (input) REAL array, dimension (N)
49 * Details of the permutation and scaling factors, as returned
50 * by CGEBAL.
51 *
52 * M (input) INTEGER
53 * The number of columns of the matrix V. M >= 0.
54 *
55 * V (input/output) COMPLEX array, dimension (LDV,M)
56 * On entry, the matrix of right or left eigenvectors to be
57 * transformed, as returned by CHSEIN or CTREVC.
58 * On exit, V is overwritten by the transformed eigenvectors.
59 *
60 * LDV (input) INTEGER
61 * The leading dimension of the array V. LDV >= max(1,N).
62 *
63 * INFO (output) INTEGER
64 * = 0: successful exit
65 * < 0: if INFO = -i, the i-th argument had an illegal value.
66 *
67 * =====================================================================
68 *
69 * .. Parameters ..
70 REAL ONE
71 PARAMETER ( ONE = 1.0E+0 )
72 * ..
73 * .. Local Scalars ..
74 LOGICAL LEFTV, RIGHTV
75 INTEGER I, II, K
76 REAL S
77 * ..
78 * .. External Functions ..
79 LOGICAL LSAME
80 EXTERNAL LSAME
81 * ..
82 * .. External Subroutines ..
83 EXTERNAL CSSCAL, CSWAP, XERBLA
84 * ..
85 * .. Intrinsic Functions ..
86 INTRINSIC MAX, MIN
87 * ..
88 * .. Executable Statements ..
89 *
90 * Decode and Test the input parameters
91 *
92 RIGHTV = LSAME( SIDE, 'R' )
93 LEFTV = LSAME( SIDE, 'L' )
94 *
95 INFO = 0
96 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
97 $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
98 INFO = -1
99 ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
100 INFO = -2
101 ELSE IF( N.LT.0 ) THEN
102 INFO = -3
103 ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
104 INFO = -4
105 ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
106 INFO = -5
107 ELSE IF( M.LT.0 ) THEN
108 INFO = -7
109 ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
110 INFO = -9
111 END IF
112 IF( INFO.NE.0 ) THEN
113 CALL XERBLA( 'CGEBAK', -INFO )
114 RETURN
115 END IF
116 *
117 * Quick return if possible
118 *
119 IF( N.EQ.0 )
120 $ RETURN
121 IF( M.EQ.0 )
122 $ RETURN
123 IF( LSAME( JOB, 'N' ) )
124 $ RETURN
125 *
126 IF( ILO.EQ.IHI )
127 $ GO TO 30
128 *
129 * Backward balance
130 *
131 IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
132 *
133 IF( RIGHTV ) THEN
134 DO 10 I = ILO, IHI
135 S = SCALE( I )
136 CALL CSSCAL( M, S, V( I, 1 ), LDV )
137 10 CONTINUE
138 END IF
139 *
140 IF( LEFTV ) THEN
141 DO 20 I = ILO, IHI
142 S = ONE / SCALE( I )
143 CALL CSSCAL( M, S, V( I, 1 ), LDV )
144 20 CONTINUE
145 END IF
146 *
147 END IF
148 *
149 * Backward permutation
150 *
151 * For I = ILO-1 step -1 until 1,
152 * IHI+1 step 1 until N do --
153 *
154 30 CONTINUE
155 IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
156 IF( RIGHTV ) THEN
157 DO 40 II = 1, N
158 I = II
159 IF( I.GE.ILO .AND. I.LE.IHI )
160 $ GO TO 40
161 IF( I.LT.ILO )
162 $ I = ILO - II
163 K = SCALE( I )
164 IF( K.EQ.I )
165 $ GO TO 40
166 CALL CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
167 40 CONTINUE
168 END IF
169 *
170 IF( LEFTV ) THEN
171 DO 50 II = 1, N
172 I = II
173 IF( I.GE.ILO .AND. I.LE.IHI )
174 $ GO TO 50
175 IF( I.LT.ILO )
176 $ I = ILO - II
177 K = SCALE( I )
178 IF( K.EQ.I )
179 $ GO TO 50
180 CALL CSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
181 50 CONTINUE
182 END IF
183 END IF
184 *
185 RETURN
186 *
187 * End of CGEBAK
188 *
189 END