00001 /* cpftrf.f -- translated by f2c (version 20061008). 00002 You must link the resulting object file with libf2c: 00003 on Microsoft Windows system, link with libf2c.lib; 00004 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 00005 or, if you install libf2c.a in a standard place, with -lf2c -lm 00006 -- in that order, at the end of the command line, as in 00007 cc *.o -lf2c -lm 00008 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 00009 00010 http://www.netlib.org/f2c/libf2c.zip 00011 */ 00012 00013 #include "f2c.h" 00014 #include "blaswrap.h" 00015 00016 /* Table of constant values */ 00017 00018 static complex c_b1 = {1.f,0.f}; 00019 static real c_b15 = -1.f; 00020 static real c_b16 = 1.f; 00021 00022 /* Subroutine */ int cpftrf_(char *transr, char *uplo, integer *n, complex *a, 00023 integer *info) 00024 { 00025 /* System generated locals */ 00026 integer i__1, i__2; 00027 00028 /* Local variables */ 00029 integer k, n1, n2; 00030 logical normaltransr; 00031 extern /* Subroutine */ int cherk_(char *, char *, integer *, integer *, 00032 real *, complex *, integer *, real *, complex *, integer *); 00033 extern logical lsame_(char *, char *); 00034 logical lower; 00035 extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, 00036 integer *, integer *, complex *, complex *, integer *, complex *, 00037 integer *), xerbla_(char *, 00038 integer *); 00039 logical nisodd; 00040 extern /* Subroutine */ int cpotrf_(char *, integer *, complex *, integer 00041 *, integer *); 00042 00043 00044 /* -- LAPACK routine (version 3.2) -- */ 00045 00046 /* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- */ 00047 /* -- November 2008 -- */ 00048 00049 /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ 00050 /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ 00051 00052 /* .. */ 00053 /* .. Scalar Arguments .. */ 00054 /* .. */ 00055 /* .. Array Arguments .. */ 00056 00057 /* Purpose */ 00058 /* ======= */ 00059 00060 /* CPFTRF computes the Cholesky factorization of a complex Hermitian */ 00061 /* positive definite matrix A. */ 00062 00063 /* The factorization has the form */ 00064 /* A = U**H * U, if UPLO = 'U', or */ 00065 /* A = L * L**H, if UPLO = 'L', */ 00066 /* where U is an upper triangular matrix and L is lower triangular. */ 00067 00068 /* This is the block version of the algorithm, calling Level 3 BLAS. */ 00069 00070 /* Arguments */ 00071 /* ========= */ 00072 00073 /* TRANSR (input) CHARACTER */ 00074 /* = 'N': The Normal TRANSR of RFP A is stored; */ 00075 /* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. */ 00076 00077 /* UPLO (input) CHARACTER */ 00078 /* = 'U': Upper triangle of RFP A is stored; */ 00079 /* = 'L': Lower triangle of RFP A is stored. */ 00080 00081 /* N (input) INTEGER */ 00082 /* The order of the matrix A. N >= 0. */ 00083 00084 /* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); */ 00085 /* On entry, the Hermitian matrix A in RFP format. RFP format is */ 00086 /* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ 00087 /* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ 00088 /* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is */ 00089 /* the Conjugate-transpose of RFP A as defined when */ 00090 /* TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ 00091 /* follows: If UPLO = 'U' the RFP A contains the nt elements of */ 00092 /* upper packed A. If UPLO = 'L' the RFP A contains the elements */ 00093 /* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = */ 00094 /* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N */ 00095 /* is odd. See the Note below for more details. */ 00096 00097 /* On exit, if INFO = 0, the factor U or L from the Cholesky */ 00098 /* factorization RFP A = U**H*U or RFP A = L*L**H. */ 00099 00100 /* INFO (output) INTEGER */ 00101 /* = 0: successful exit */ 00102 /* < 0: if INFO = -i, the i-th argument had an illegal value */ 00103 /* > 0: if INFO = i, the leading minor of order i is not */ 00104 /* positive definite, and the factorization could not be */ 00105 /* completed. */ 00106 00107 /* Further Notes on RFP Format: */ 00108 /* ============================ */ 00109 00110 00111 /* We first consider Standard Packed Format when N is even. */ 00112 /* We give an example where N = 6. */ 00113 00114 /* AP is Upper AP is Lower */ 00115 00116 /* 00 01 02 03 04 05 00 */ 00117 /* 11 12 13 14 15 10 11 */ 00118 /* 22 23 24 25 20 21 22 */ 00119 /* 33 34 35 30 31 32 33 */ 00120 /* 44 45 40 41 42 43 44 */ 00121 /* 55 50 51 52 53 54 55 */ 00122 00123 00124 /* Let TRANSR = 'N'. RFP holds AP as follows: */ 00125 /* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ 00126 /* three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ 00127 /* conjugate-transpose of the first three columns of AP upper. */ 00128 /* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ 00129 /* three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ 00130 /* conjugate-transpose of the last three columns of AP lower. */ 00131 /* To denote conjugate we place -- above the element. This covers the */ 00132 /* case N even and TRANSR = 'N'. */ 00133 00134 /* RFP A RFP A */ 00135 00136 /* -- -- -- */ 00137 /* 03 04 05 33 43 53 */ 00138 /* -- -- */ 00139 /* 13 14 15 00 44 54 */ 00140 /* -- */ 00141 /* 23 24 25 10 11 55 */ 00142 00143 /* 33 34 35 20 21 22 */ 00144 /* -- */ 00145 /* 00 44 45 30 31 32 */ 00146 /* -- -- */ 00147 /* 01 11 55 40 41 42 */ 00148 /* -- -- -- */ 00149 /* 02 12 22 50 51 52 */ 00150 00151 /* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */ 00152 /* transpose of RFP A above. One therefore gets: */ 00153 00154 00155 /* RFP A RFP A */ 00156 00157 /* -- -- -- -- -- -- -- -- -- -- */ 00158 /* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ 00159 /* -- -- -- -- -- -- -- -- -- -- */ 00160 /* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ 00161 /* -- -- -- -- -- -- -- -- -- -- */ 00162 /* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ 00163 00164 00165 /* We next consider Standard Packed Format when N is odd. */ 00166 /* We give an example where N = 5. */ 00167 00168 /* AP is Upper AP is Lower */ 00169 00170 /* 00 01 02 03 04 00 */ 00171 /* 11 12 13 14 10 11 */ 00172 /* 22 23 24 20 21 22 */ 00173 /* 33 34 30 31 32 33 */ 00174 /* 44 40 41 42 43 44 */ 00175 00176 00177 /* Let TRANSR = 'N'. RFP holds AP as follows: */ 00178 /* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ 00179 /* three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ 00180 /* conjugate-transpose of the first two columns of AP upper. */ 00181 /* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ 00182 /* three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ 00183 /* conjugate-transpose of the last two columns of AP lower. */ 00184 /* To denote conjugate we place -- above the element. This covers the */ 00185 /* case N odd and TRANSR = 'N'. */ 00186 00187 /* RFP A RFP A */ 00188 00189 /* -- -- */ 00190 /* 02 03 04 00 33 43 */ 00191 /* -- */ 00192 /* 12 13 14 10 11 44 */ 00193 00194 /* 22 23 24 20 21 22 */ 00195 /* -- */ 00196 /* 00 33 34 30 31 32 */ 00197 /* -- -- */ 00198 /* 01 11 44 40 41 42 */ 00199 00200 /* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */ 00201 /* transpose of RFP A above. One therefore gets: */ 00202 00203 00204 /* RFP A RFP A */ 00205 00206 /* -- -- -- -- -- -- -- -- -- */ 00207 /* 02 12 22 00 01 00 10 20 30 40 50 */ 00208 /* -- -- -- -- -- -- -- -- -- */ 00209 /* 03 13 23 33 11 33 11 21 31 41 51 */ 00210 /* -- -- -- -- -- -- -- -- -- */ 00211 /* 04 14 24 34 44 43 44 22 32 42 52 */ 00212 00213 /* ===================================================================== */ 00214 00215 /* .. Parameters .. */ 00216 /* .. */ 00217 /* .. Local Scalars .. */ 00218 /* .. */ 00219 /* .. External Functions .. */ 00220 /* .. */ 00221 /* .. External Subroutines .. */ 00222 /* .. */ 00223 /* .. Intrinsic Functions .. */ 00224 /* .. */ 00225 /* .. Executable Statements .. */ 00226 00227 /* Test the input parameters. */ 00228 00229 *info = 0; 00230 normaltransr = lsame_(transr, "N"); 00231 lower = lsame_(uplo, "L"); 00232 if (! normaltransr && ! lsame_(transr, "C")) { 00233 *info = -1; 00234 } else if (! lower && ! lsame_(uplo, "U")) { 00235 *info = -2; 00236 } else if (*n < 0) { 00237 *info = -3; 00238 } 00239 if (*info != 0) { 00240 i__1 = -(*info); 00241 xerbla_("CPFTRF", &i__1); 00242 return 0; 00243 } 00244 00245 /* Quick return if possible */ 00246 00247 if (*n == 0) { 00248 return 0; 00249 } 00250 00251 /* If N is odd, set NISODD = .TRUE. */ 00252 /* If N is even, set K = N/2 and NISODD = .FALSE. */ 00253 00254 if (*n % 2 == 0) { 00255 k = *n / 2; 00256 nisodd = FALSE_; 00257 } else { 00258 nisodd = TRUE_; 00259 } 00260 00261 /* Set N1 and N2 depending on LOWER */ 00262 00263 if (lower) { 00264 n2 = *n / 2; 00265 n1 = *n - n2; 00266 } else { 00267 n1 = *n / 2; 00268 n2 = *n - n1; 00269 } 00270 00271 /* start execution: there are eight cases */ 00272 00273 if (nisodd) { 00274 00275 /* N is odd */ 00276 00277 if (normaltransr) { 00278 00279 /* N is odd and TRANSR = 'N' */ 00280 00281 if (lower) { 00282 00283 /* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ 00284 /* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ 00285 /* T1 -> a(0), T2 -> a(n), S -> a(n1) */ 00286 00287 cpotrf_("L", &n1, a, n, info); 00288 if (*info > 0) { 00289 return 0; 00290 } 00291 ctrsm_("R", "L", "C", "N", &n2, &n1, &c_b1, a, n, &a[n1], n); 00292 cherk_("U", "N", &n2, &n1, &c_b15, &a[n1], n, &c_b16, &a[*n], 00293 n); 00294 cpotrf_("U", &n2, &a[*n], n, info); 00295 if (*info > 0) { 00296 *info += n1; 00297 } 00298 00299 } else { 00300 00301 /* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ 00302 /* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ 00303 /* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ 00304 00305 cpotrf_("L", &n1, &a[n2], n, info); 00306 if (*info > 0) { 00307 return 0; 00308 } 00309 ctrsm_("L", "L", "N", "N", &n1, &n2, &c_b1, &a[n2], n, a, n); 00310 cherk_("U", "C", &n2, &n1, &c_b15, a, n, &c_b16, &a[n1], n); 00311 cpotrf_("U", &n2, &a[n1], n, info); 00312 if (*info > 0) { 00313 *info += n1; 00314 } 00315 00316 } 00317 00318 } else { 00319 00320 /* N is odd and TRANSR = 'C' */ 00321 00322 if (lower) { 00323 00324 /* SRPA for LOWER, TRANSPOSE and N is odd */ 00325 /* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */ 00326 /* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */ 00327 00328 cpotrf_("U", &n1, a, &n1, info); 00329 if (*info > 0) { 00330 return 0; 00331 } 00332 ctrsm_("L", "U", "C", "N", &n1, &n2, &c_b1, a, &n1, &a[n1 * 00333 n1], &n1); 00334 cherk_("L", "C", &n2, &n1, &c_b15, &a[n1 * n1], &n1, &c_b16, & 00335 a[1], &n1); 00336 cpotrf_("L", &n2, &a[1], &n1, info); 00337 if (*info > 0) { 00338 *info += n1; 00339 } 00340 00341 } else { 00342 00343 /* SRPA for UPPER, TRANSPOSE and N is odd */ 00344 /* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */ 00345 /* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */ 00346 00347 cpotrf_("U", &n1, &a[n2 * n2], &n2, info); 00348 if (*info > 0) { 00349 return 0; 00350 } 00351 ctrsm_("R", "U", "N", "N", &n2, &n1, &c_b1, &a[n2 * n2], &n2, 00352 a, &n2); 00353 cherk_("L", "N", &n2, &n1, &c_b15, a, &n2, &c_b16, &a[n1 * n2] 00354 , &n2); 00355 cpotrf_("L", &n2, &a[n1 * n2], &n2, info); 00356 if (*info > 0) { 00357 *info += n1; 00358 } 00359 00360 } 00361 00362 } 00363 00364 } else { 00365 00366 /* N is even */ 00367 00368 if (normaltransr) { 00369 00370 /* N is even and TRANSR = 'N' */ 00371 00372 if (lower) { 00373 00374 /* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ 00375 /* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ 00376 /* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ 00377 00378 i__1 = *n + 1; 00379 cpotrf_("L", &k, &a[1], &i__1, info); 00380 if (*info > 0) { 00381 return 0; 00382 } 00383 i__1 = *n + 1; 00384 i__2 = *n + 1; 00385 ctrsm_("R", "L", "C", "N", &k, &k, &c_b1, &a[1], &i__1, &a[k 00386 + 1], &i__2); 00387 i__1 = *n + 1; 00388 i__2 = *n + 1; 00389 cherk_("U", "N", &k, &k, &c_b15, &a[k + 1], &i__1, &c_b16, a, 00390 &i__2); 00391 i__1 = *n + 1; 00392 cpotrf_("U", &k, a, &i__1, info); 00393 if (*info > 0) { 00394 *info += k; 00395 } 00396 00397 } else { 00398 00399 /* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ 00400 /* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ 00401 /* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ 00402 00403 i__1 = *n + 1; 00404 cpotrf_("L", &k, &a[k + 1], &i__1, info); 00405 if (*info > 0) { 00406 return 0; 00407 } 00408 i__1 = *n + 1; 00409 i__2 = *n + 1; 00410 ctrsm_("L", "L", "N", "N", &k, &k, &c_b1, &a[k + 1], &i__1, a, 00411 &i__2); 00412 i__1 = *n + 1; 00413 i__2 = *n + 1; 00414 cherk_("U", "C", &k, &k, &c_b15, a, &i__1, &c_b16, &a[k], & 00415 i__2); 00416 i__1 = *n + 1; 00417 cpotrf_("U", &k, &a[k], &i__1, info); 00418 if (*info > 0) { 00419 *info += k; 00420 } 00421 00422 } 00423 00424 } else { 00425 00426 /* N is even and TRANSR = 'C' */ 00427 00428 if (lower) { 00429 00430 /* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ 00431 /* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ 00432 /* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ 00433 00434 cpotrf_("U", &k, &a[k], &k, info); 00435 if (*info > 0) { 00436 return 0; 00437 } 00438 ctrsm_("L", "U", "C", "N", &k, &k, &c_b1, &a[k], &n1, &a[k * ( 00439 k + 1)], &k); 00440 cherk_("L", "C", &k, &k, &c_b15, &a[k * (k + 1)], &k, &c_b16, 00441 a, &k); 00442 cpotrf_("L", &k, a, &k, info); 00443 if (*info > 0) { 00444 *info += k; 00445 } 00446 00447 } else { 00448 00449 /* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ 00450 /* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ 00451 /* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ 00452 00453 cpotrf_("U", &k, &a[k * (k + 1)], &k, info); 00454 if (*info > 0) { 00455 return 0; 00456 } 00457 ctrsm_("R", "U", "N", "N", &k, &k, &c_b1, &a[k * (k + 1)], &k, 00458 a, &k); 00459 cherk_("L", "N", &k, &k, &c_b15, a, &k, &c_b16, &a[k * k], &k); 00460 cpotrf_("L", &k, &a[k * k], &k, info); 00461 if (*info > 0) { 00462 *info += k; 00463 } 00464 00465 } 00466 00467 } 00468 00469 } 00470 00471 return 0; 00472 00473 /* End of CPFTRF */ 00474 00475 } /* cpftrf_ */