1 /* ./src_f77/zhesv.f -- translated by f2c (version 20030320).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include <punc/vf2c.h>
7
8 /* Table of constant values */
9
10 static integer c__1 = 1;
11 static integer c_n1 = -1;
12
zhesv_(char * uplo,integer * n,integer * nrhs,doublecomplex * a,integer * lda,integer * ipiv,doublecomplex * b,integer * ldb,doublecomplex * work,integer * lwork,integer * info,ftnlen uplo_len)13 /* Subroutine */ int zhesv_(char *uplo, integer *n, integer *nrhs,
14 doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,
15 integer *ldb, doublecomplex *work, integer *lwork, integer *info,
16 ftnlen uplo_len)
17 {
18 /* System generated locals */
19 integer a_dim1, a_offset, b_dim1, b_offset, i__1;
20
21 /* Local variables */
22 static integer nb;
23 extern logical lsame_(char *, char *, ftnlen, ftnlen);
24 extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
25 extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
26 integer *, integer *, ftnlen, ftnlen);
27 extern /* Subroutine */ int zhetrf_(char *, integer *, doublecomplex *,
28 integer *, integer *, doublecomplex *, integer *, integer *,
29 ftnlen), zhetrs_(char *, integer *, integer *, doublecomplex *,
30 integer *, integer *, doublecomplex *, integer *, integer *,
31 ftnlen);
32 static integer lwkopt;
33 static logical lquery;
34
35
36 /* -- LAPACK driver routine (version 3.0) -- */
37 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
38 /* Courant Institute, Argonne National Lab, and Rice University */
39 /* June 30, 1999 */
40
41 /* .. Scalar Arguments .. */
42 /* .. */
43 /* .. Array Arguments .. */
44 /* .. */
45
46 /* Purpose */
47 /* ======= */
48
49 /* ZHESV computes the solution to a complex system of linear equations */
50 /* A * X = B, */
51 /* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS */
52 /* matrices. */
53
54 /* The diagonal pivoting method is used to factor A as */
55 /* A = U * D * U**H, if UPLO = 'U', or */
56 /* A = L * D * L**H, if UPLO = 'L', */
57 /* where U (or L) is a product of permutation and unit upper (lower) */
58 /* triangular matrices, and D is Hermitian and block diagonal with */
59 /* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then */
60 /* used to solve the system of equations A * X = B. */
61
62 /* Arguments */
63 /* ========= */
64
65 /* UPLO (input) CHARACTER*1 */
66 /* = 'U': Upper triangle of A is stored; */
67 /* = 'L': Lower triangle of A is stored. */
68
69 /* N (input) INTEGER */
70 /* The number of linear equations, i.e., the order of the */
71 /* matrix A. N >= 0. */
72
73 /* NRHS (input) INTEGER */
74 /* The number of right hand sides, i.e., the number of columns */
75 /* of the matrix B. NRHS >= 0. */
76
77 /* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
78 /* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */
79 /* N-by-N upper triangular part of A contains the upper */
80 /* triangular part of the matrix A, and the strictly lower */
81 /* triangular part of A is not referenced. If UPLO = 'L', the */
82 /* leading N-by-N lower triangular part of A contains the lower */
83 /* triangular part of the matrix A, and the strictly upper */
84 /* triangular part of A is not referenced. */
85
86 /* On exit, if INFO = 0, the block diagonal matrix D and the */
87 /* multipliers used to obtain the factor U or L from the */
88 /* factorization A = U*D*U**H or A = L*D*L**H as computed by */
89 /* ZHETRF. */
90
91 /* LDA (input) INTEGER */
92 /* The leading dimension of the array A. LDA >= max(1,N). */
93
94 /* IPIV (output) INTEGER array, dimension (N) */
95 /* Details of the interchanges and the block structure of D, as */
96 /* determined by ZHETRF. If IPIV(k) > 0, then rows and columns */
97 /* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
98 /* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
99 /* then rows and columns k-1 and -IPIV(k) were interchanged and */
100 /* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */
101 /* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
102 /* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
103 /* diagonal block. */
104
105 /* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */
106 /* On entry, the N-by-NRHS right hand side matrix B. */
107 /* On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
108
109 /* LDB (input) INTEGER */
110 /* The leading dimension of the array B. LDB >= max(1,N). */
111
112 /* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK) */
113 /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
114
115 /* LWORK (input) INTEGER */
116 /* The length of WORK. LWORK >= 1, and for best performance */
117 /* LWORK >= N*NB, where NB is the optimal blocksize for */
118 /* ZHETRF. */
119
120 /* If LWORK = -1, then a workspace query is assumed; the routine */
121 /* only calculates the optimal size of the WORK array, returns */
122 /* this value as the first entry of the WORK array, and no error */
123 /* message related to LWORK is issued by XERBLA. */
124
125 /* INFO (output) INTEGER */
126 /* = 0: successful exit */
127 /* < 0: if INFO = -i, the i-th argument had an illegal value */
128 /* > 0: if INFO = i, D(i,i) is exactly zero. The factorization */
129 /* has been completed, but the block diagonal matrix D is */
130 /* exactly singular, so the solution could not be computed. */
131
132 /* ===================================================================== */
133
134 /* .. Local Scalars .. */
135 /* .. */
136 /* .. External Functions .. */
137 /* .. */
138 /* .. External Subroutines .. */
139 /* .. */
140 /* .. Intrinsic Functions .. */
141 /* .. */
142 /* .. Executable Statements .. */
143
144 /* Test the input parameters. */
145
146 /* Parameter adjustments */
147 a_dim1 = *lda;
148 a_offset = 1 + a_dim1;
149 a -= a_offset;
150 --ipiv;
151 b_dim1 = *ldb;
152 b_offset = 1 + b_dim1;
153 b -= b_offset;
154 --work;
155
156 /* Function Body */
157 *info = 0;
158 lquery = *lwork == -1;
159 if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", (
160 ftnlen)1, (ftnlen)1)) {
161 *info = -1;
162 } else if (*n < 0) {
163 *info = -2;
164 } else if (*nrhs < 0) {
165 *info = -3;
166 } else if (*lda < max(1,*n)) {
167 *info = -5;
168 } else if (*ldb < max(1,*n)) {
169 *info = -8;
170 } else if (*lwork < 1 && ! lquery) {
171 *info = -10;
172 }
173
174 if (*info == 0) {
175 nb = ilaenv_(&c__1, "ZHETRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
176 (ftnlen)1);
177 lwkopt = *n * nb;
178 work[1].r = (doublereal) lwkopt, work[1].i = 0.;
179 }
180
181 if (*info != 0) {
182 i__1 = -(*info);
183 xerbla_("ZHESV ", &i__1, (ftnlen)6);
184 return 0;
185 } else if (lquery) {
186 return 0;
187 }
188
189 /* Compute the factorization A = U*D*U' or A = L*D*L'. */
190
191 zhetrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info, (
192 ftnlen)1);
193 if (*info == 0) {
194
195 /* Solve the system A*X = B, overwriting B with X. */
196
197 zhetrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], ldb,
198 info, (ftnlen)1);
199
200 }
201
202 work[1].r = (doublereal) lwkopt, work[1].i = 0.;
203
204 return 0;
205
206 /* End of ZHESV */
207
208 } /* zhesv_ */
209
210