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