LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cla_porcond_c.f
Go to the documentation of this file.
1 *> \brief \b CLA_PORCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for Hermitian positive-definite matrices.
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 *> \htmlonly
9 *> Download CLA_PORCOND_C + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cla_porcond_c.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cla_porcond_c.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cla_porcond_c.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 * Definition:
19 * ===========
20 *
21 * REAL FUNCTION CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY,
22 * INFO, WORK, RWORK )
23 *
24 * .. Scalar Arguments ..
25 * CHARACTER UPLO
26 * LOGICAL CAPPLY
27 * INTEGER N, LDA, LDAF, INFO
28 * ..
29 * .. Array Arguments ..
30 * COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * )
31 * REAL C( * ), RWORK( * )
32 * ..
33 *
34 *
35 *> \par Purpose:
36 * =============
37 *>
38 *> \verbatim
39 *>
40 *> CLA_PORCOND_C Computes the infinity norm condition number of
41 *> op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector
42 *> \endverbatim
43 *
44 * Arguments:
45 * ==========
46 *
47 *> \param[in] UPLO
48 *> \verbatim
49 *> UPLO is CHARACTER*1
50 *> = 'U': Upper triangle of A is stored;
51 *> = 'L': Lower triangle of A is stored.
52 *> \endverbatim
53 *>
54 *> \param[in] N
55 *> \verbatim
56 *> N is INTEGER
57 *> The number of linear equations, i.e., the order of the
58 *> matrix A. N >= 0.
59 *> \endverbatim
60 *>
61 *> \param[in] A
62 *> \verbatim
63 *> A is COMPLEX array, dimension (LDA,N)
64 *> On entry, the N-by-N matrix A
65 *> \endverbatim
66 *>
67 *> \param[in] LDA
68 *> \verbatim
69 *> LDA is INTEGER
70 *> The leading dimension of the array A. LDA >= max(1,N).
71 *> \endverbatim
72 *>
73 *> \param[in] AF
74 *> \verbatim
75 *> AF is COMPLEX array, dimension (LDAF,N)
76 *> The triangular factor U or L from the Cholesky factorization
77 *> A = U**H*U or A = L*L**H, as computed by CPOTRF.
78 *> \endverbatim
79 *>
80 *> \param[in] LDAF
81 *> \verbatim
82 *> LDAF is INTEGER
83 *> The leading dimension of the array AF. LDAF >= max(1,N).
84 *> \endverbatim
85 *>
86 *> \param[in] C
87 *> \verbatim
88 *> C is REAL array, dimension (N)
89 *> The vector C in the formula op(A) * inv(diag(C)).
90 *> \endverbatim
91 *>
92 *> \param[in] CAPPLY
93 *> \verbatim
94 *> CAPPLY is LOGICAL
95 *> If .TRUE. then access the vector C in the formula above.
96 *> \endverbatim
97 *>
98 *> \param[out] INFO
99 *> \verbatim
100 *> INFO is INTEGER
101 *> = 0: Successful exit.
102 *> i > 0: The ith argument is invalid.
103 *> \endverbatim
104 *>
105 *> \param[in] WORK
106 *> \verbatim
107 *> WORK is COMPLEX array, dimension (2*N).
108 *> Workspace.
109 *> \endverbatim
110 *>
111 *> \param[in] RWORK
112 *> \verbatim
113 *> RWORK is REAL array, dimension (N).
114 *> Workspace.
115 *> \endverbatim
116 *
117 * Authors:
118 * ========
119 *
120 *> \author Univ. of Tennessee
121 *> \author Univ. of California Berkeley
122 *> \author Univ. of Colorado Denver
123 *> \author NAG Ltd.
124 *
125 *> \date September 2012
126 *
127 *> \ingroup complexPOcomputational
128 *
129 * =====================================================================
130  REAL FUNCTION cla_porcond_c( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY,
131  $ info, work, rwork )
132 *
133 * -- LAPACK computational routine (version 3.4.2) --
134 * -- LAPACK is a software package provided by Univ. of Tennessee, --
135 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
136 * September 2012
137 *
138 * .. Scalar Arguments ..
139  CHARACTER uplo
140  LOGICAL capply
141  INTEGER n, lda, ldaf, info
142 * ..
143 * .. Array Arguments ..
144  COMPLEX a( lda, * ), af( ldaf, * ), work( * )
145  REAL c( * ), rwork( * )
146 * ..
147 *
148 * =====================================================================
149 *
150 * .. Local Scalars ..
151  INTEGER kase
152  REAL ainvnm, anorm, tmp
153  INTEGER i, j
154  LOGICAL up, upper
155  COMPLEX zdum
156 * ..
157 * .. Local Arrays ..
158  INTEGER isave( 3 )
159 * ..
160 * .. External Functions ..
161  LOGICAL lsame
162  EXTERNAL lsame
163 * ..
164 * .. External Subroutines ..
165  EXTERNAL clacn2, cpotrs, xerbla
166 * ..
167 * .. Intrinsic Functions ..
168  INTRINSIC abs, max, REAL, aimag
169 * ..
170 * .. Statement Functions ..
171  REAL cabs1
172 * ..
173 * .. Statement Function Definitions ..
174  cabs1( zdum ) = abs( REAL( ZDUM ) ) + abs( aimag( zdum ) )
175 * ..
176 * .. Executable Statements ..
177 *
178  cla_porcond_c = 0.0e+0
179 *
180  info = 0
181  upper = lsame( uplo, 'U' )
182  IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
183  info = -1
184  ELSE IF( n.LT.0 ) THEN
185  info = -2
186  ELSE IF( lda.LT.max( 1, n ) ) THEN
187  info = -4
188  ELSE IF( ldaf.LT.max( 1, n ) ) THEN
189  info = -6
190  END IF
191  IF( info.NE.0 ) THEN
192  CALL xerbla( 'CLA_PORCOND_C', -info )
193  return
194  END IF
195  up = .false.
196  IF ( lsame( uplo, 'U' ) ) up = .true.
197 *
198 * Compute norm of op(A)*op2(C).
199 *
200  anorm = 0.0e+0
201  IF ( up ) THEN
202  DO i = 1, n
203  tmp = 0.0e+0
204  IF ( capply ) THEN
205  DO j = 1, i
206  tmp = tmp + cabs1( a( j, i ) ) / c( j )
207  END DO
208  DO j = i+1, n
209  tmp = tmp + cabs1( a( i, j ) ) / c( j )
210  END DO
211  ELSE
212  DO j = 1, i
213  tmp = tmp + cabs1( a( j, i ) )
214  END DO
215  DO j = i+1, n
216  tmp = tmp + cabs1( a( i, j ) )
217  END DO
218  END IF
219  rwork( i ) = tmp
220  anorm = max( anorm, tmp )
221  END DO
222  ELSE
223  DO i = 1, n
224  tmp = 0.0e+0
225  IF ( capply ) THEN
226  DO j = 1, i
227  tmp = tmp + cabs1( a( i, j ) ) / c( j )
228  END DO
229  DO j = i+1, n
230  tmp = tmp + cabs1( a( j, i ) ) / c( j )
231  END DO
232  ELSE
233  DO j = 1, i
234  tmp = tmp + cabs1( a( i, j ) )
235  END DO
236  DO j = i+1, n
237  tmp = tmp + cabs1( a( j, i ) )
238  END DO
239  END IF
240  rwork( i ) = tmp
241  anorm = max( anorm, tmp )
242  END DO
243  END IF
244 *
245 * Quick return if possible.
246 *
247  IF( n.EQ.0 ) THEN
248  cla_porcond_c = 1.0e+0
249  return
250  ELSE IF( anorm .EQ. 0.0e+0 ) THEN
251  return
252  END IF
253 *
254 * Estimate the norm of inv(op(A)).
255 *
256  ainvnm = 0.0e+0
257 *
258  kase = 0
259  10 continue
260  CALL clacn2( n, work( n+1 ), work, ainvnm, kase, isave )
261  IF( kase.NE.0 ) THEN
262  IF( kase.EQ.2 ) THEN
263 *
264 * Multiply by R.
265 *
266  DO i = 1, n
267  work( i ) = work( i ) * rwork( i )
268  END DO
269 *
270  IF ( up ) THEN
271  CALL cpotrs( 'U', n, 1, af, ldaf,
272  $ work, n, info )
273  ELSE
274  CALL cpotrs( 'L', n, 1, af, ldaf,
275  $ work, n, info )
276  ENDIF
277 *
278 * Multiply by inv(C).
279 *
280  IF ( capply ) THEN
281  DO i = 1, n
282  work( i ) = work( i ) * c( i )
283  END DO
284  END IF
285  ELSE
286 *
287 * Multiply by inv(C**H).
288 *
289  IF ( capply ) THEN
290  DO i = 1, n
291  work( i ) = work( i ) * c( i )
292  END DO
293  END IF
294 *
295  IF ( up ) THEN
296  CALL cpotrs( 'U', n, 1, af, ldaf,
297  $ work, n, info )
298  ELSE
299  CALL cpotrs( 'L', n, 1, af, ldaf,
300  $ work, n, info )
301  END IF
302 *
303 * Multiply by R.
304 *
305  DO i = 1, n
306  work( i ) = work( i ) * rwork( i )
307  END DO
308  END IF
309  go to 10
310  END IF
311 *
312 * Compute the estimate of the reciprocal condition number.
313 *
314  IF( ainvnm .NE. 0.0e+0 )
315  $ cla_porcond_c = 1.0e+0 / ainvnm
316 *
317  return
318 *
319  END