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 integer c__1 = 1;
00019
00020 int dppcon_(char *uplo, integer *n, doublereal *ap,
00021 doublereal *anorm, doublereal *rcond, doublereal *work, integer *
00022 iwork, integer *info)
00023 {
00024
00025 integer i__1;
00026 doublereal d__1;
00027
00028
00029 integer ix, kase;
00030 doublereal scale;
00031 extern logical lsame_(char *, char *);
00032 integer isave[3];
00033 extern int drscl_(integer *, doublereal *, doublereal *,
00034 integer *);
00035 logical upper;
00036 extern int dlacn2_(integer *, doublereal *, doublereal *,
00037 integer *, doublereal *, integer *, integer *);
00038 extern doublereal dlamch_(char *);
00039 doublereal scalel;
00040 extern integer idamax_(integer *, doublereal *, integer *);
00041 doublereal scaleu;
00042 extern int xerbla_(char *, integer *), dlatps_(
00043 char *, char *, char *, char *, integer *, doublereal *,
00044 doublereal *, doublereal *, doublereal *, integer *);
00045 doublereal ainvnm;
00046 char normin[1];
00047 doublereal smlnum;
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
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122
00123
00124
00125 --iwork;
00126 --work;
00127 --ap;
00128
00129
00130 *info = 0;
00131 upper = lsame_(uplo, "U");
00132 if (! upper && ! lsame_(uplo, "L")) {
00133 *info = -1;
00134 } else if (*n < 0) {
00135 *info = -2;
00136 } else if (*anorm < 0.) {
00137 *info = -4;
00138 }
00139 if (*info != 0) {
00140 i__1 = -(*info);
00141 xerbla_("DPPCON", &i__1);
00142 return 0;
00143 }
00144
00145
00146
00147 *rcond = 0.;
00148 if (*n == 0) {
00149 *rcond = 1.;
00150 return 0;
00151 } else if (*anorm == 0.) {
00152 return 0;
00153 }
00154
00155 smlnum = dlamch_("Safe minimum");
00156
00157
00158
00159 kase = 0;
00160 *(unsigned char *)normin = 'N';
00161 L10:
00162 dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
00163 if (kase != 0) {
00164 if (upper) {
00165
00166
00167
00168 dlatps_("Upper", "Transpose", "Non-unit", normin, n, &ap[1], &
00169 work[1], &scalel, &work[(*n << 1) + 1], info);
00170 *(unsigned char *)normin = 'Y';
00171
00172
00173
00174 dlatps_("Upper", "No transpose", "Non-unit", normin, n, &ap[1], &
00175 work[1], &scaleu, &work[(*n << 1) + 1], info);
00176 } else {
00177
00178
00179
00180 dlatps_("Lower", "No transpose", "Non-unit", normin, n, &ap[1], &
00181 work[1], &scalel, &work[(*n << 1) + 1], info);
00182 *(unsigned char *)normin = 'Y';
00183
00184
00185
00186 dlatps_("Lower", "Transpose", "Non-unit", normin, n, &ap[1], &
00187 work[1], &scaleu, &work[(*n << 1) + 1], info);
00188 }
00189
00190
00191
00192 scale = scalel * scaleu;
00193 if (scale != 1.) {
00194 ix = idamax_(n, &work[1], &c__1);
00195 if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.)
00196 {
00197 goto L20;
00198 }
00199 drscl_(n, &scale, &work[1], &c__1);
00200 }
00201 goto L10;
00202 }
00203
00204
00205
00206 if (ainvnm != 0.) {
00207 *rcond = 1. / ainvnm / *anorm;
00208 }
00209
00210 L20:
00211 return 0;
00212
00213
00214
00215 }