00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015
00016
00017
00018 static doublereal c_b8 = 1.;
00019 static integer c__1 = 1;
00020
00021 int zpptri_(char *uplo, integer *n, doublecomplex *ap,
00022 integer *info)
00023 {
00024
00025 integer i__1, i__2, i__3;
00026 doublereal d__1;
00027 doublecomplex z__1;
00028
00029
00030 integer j, jc, jj;
00031 doublereal ajj;
00032 integer jjn;
00033 extern int zhpr_(char *, integer *, doublereal *,
00034 doublecomplex *, integer *, doublecomplex *);
00035 extern logical lsame_(char *, char *);
00036 extern VOID zdotc_(doublecomplex *, integer *,
00037 doublecomplex *, integer *, doublecomplex *, integer *);
00038 logical upper;
00039 extern int ztpmv_(char *, char *, char *, integer *,
00040 doublecomplex *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *,
00041 doublereal *, doublecomplex *, integer *), ztptri_(char *, char *,
00042 integer *, doublecomplex *, integer *);
00043
00044
00045
00046
00047
00048
00049
00050
00051
00052
00053
00054
00055
00056
00057
00058
00059
00060
00061
00062
00063
00064
00065
00066
00067
00068
00069
00070
00071
00072
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086
00087
00088
00089
00090
00091
00092
00093
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105 --ap;
00106
00107
00108 *info = 0;
00109 upper = lsame_(uplo, "U");
00110 if (! upper && ! lsame_(uplo, "L")) {
00111 *info = -1;
00112 } else if (*n < 0) {
00113 *info = -2;
00114 }
00115 if (*info != 0) {
00116 i__1 = -(*info);
00117 xerbla_("ZPPTRI", &i__1);
00118 return 0;
00119 }
00120
00121
00122
00123 if (*n == 0) {
00124 return 0;
00125 }
00126
00127
00128
00129 ztptri_(uplo, "Non-unit", n, &ap[1], info);
00130 if (*info > 0) {
00131 return 0;
00132 }
00133 if (upper) {
00134
00135
00136
00137 jj = 0;
00138 i__1 = *n;
00139 for (j = 1; j <= i__1; ++j) {
00140 jc = jj + 1;
00141 jj += j;
00142 if (j > 1) {
00143 i__2 = j - 1;
00144 zhpr_("Upper", &i__2, &c_b8, &ap[jc], &c__1, &ap[1]);
00145 }
00146 i__2 = jj;
00147 ajj = ap[i__2].r;
00148 zdscal_(&j, &ajj, &ap[jc], &c__1);
00149
00150 }
00151
00152 } else {
00153
00154
00155
00156 jj = 1;
00157 i__1 = *n;
00158 for (j = 1; j <= i__1; ++j) {
00159 jjn = jj + *n - j + 1;
00160 i__2 = jj;
00161 i__3 = *n - j + 1;
00162 zdotc_(&z__1, &i__3, &ap[jj], &c__1, &ap[jj], &c__1);
00163 d__1 = z__1.r;
00164 ap[i__2].r = d__1, ap[i__2].i = 0.;
00165 if (j < *n) {
00166 i__2 = *n - j;
00167 ztpmv_("Lower", "Conjugate transpose", "Non-unit", &i__2, &ap[
00168 jjn], &ap[jj + 1], &c__1);
00169 }
00170 jj = jjn;
00171
00172 }
00173 }
00174
00175 return 0;
00176
00177
00178
00179 }