dtpt03.c
Go to the documentation of this file.
00001 /* dtpt03.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 integer c__1 = 1;
00019 
00020 /* Subroutine */ int dtpt03_(char *uplo, char *trans, char *diag, integer *n, 
00021         integer *nrhs, doublereal *ap, doublereal *scale, doublereal *cnorm, 
00022         doublereal *tscal, doublereal *x, integer *ldx, doublereal *b, 
00023         integer *ldb, doublereal *work, doublereal *resid)
00024 {
00025     /* System generated locals */
00026     integer b_dim1, b_offset, x_dim1, x_offset, i__1;
00027     doublereal d__1, d__2, d__3;
00028 
00029     /* Local variables */
00030     integer j, jj, ix;
00031     doublereal eps, err;
00032     extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
00033             integer *);
00034     extern logical lsame_(char *, char *);
00035     doublereal xscal;
00036     extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
00037             doublereal *, integer *), daxpy_(integer *, doublereal *, 
00038             doublereal *, integer *, doublereal *, integer *), dtpmv_(char *, 
00039             char *, char *, integer *, doublereal *, doublereal *, integer *);
00040     doublereal tnorm, xnorm;
00041     extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
00042     extern doublereal dlamch_(char *);
00043     extern integer idamax_(integer *, doublereal *, integer *);
00044     doublereal bignum, smlnum;
00045 
00046 
00047 /*  -- LAPACK test routine (version 3.1) -- */
00048 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00049 /*     November 2006 */
00050 
00051 /*     .. Scalar Arguments .. */
00052 /*     .. */
00053 /*     .. Array Arguments .. */
00054 /*     .. */
00055 
00056 /*  Purpose */
00057 /*  ======= */
00058 
00059 /*  DTPT03 computes the residual for the solution to a scaled triangular */
00060 /*  system of equations A*x = s*b  or  A'*x = s*b  when the triangular */
00061 /*  matrix A is stored in packed format.  Here A' is the transpose of A, */
00062 /*  s is a scalar, and x and b are N by NRHS matrices.  The test ratio is */
00063 /*  the maximum over the number of right hand sides of */
00064 /*     norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
00065 /*  where op(A) denotes A or A' and EPS is the machine epsilon. */
00066 
00067 /*  Arguments */
00068 /*  ========= */
00069 
00070 /*  UPLO    (input) CHARACTER*1 */
00071 /*          Specifies whether the matrix A is upper or lower triangular. */
00072 /*          = 'U':  Upper triangular */
00073 /*          = 'L':  Lower triangular */
00074 
00075 /*  TRANS   (input) CHARACTER*1 */
00076 /*          Specifies the operation applied to A. */
00077 /*          = 'N':  A *x = s*b  (No transpose) */
00078 /*          = 'T':  A'*x = s*b  (Transpose) */
00079 /*          = 'C':  A'*x = s*b  (Conjugate transpose = Transpose) */
00080 
00081 /*  DIAG    (input) CHARACTER*1 */
00082 /*          Specifies whether or not the matrix A is unit triangular. */
00083 /*          = 'N':  Non-unit triangular */
00084 /*          = 'U':  Unit triangular */
00085 
00086 /*  N       (input) INTEGER */
00087 /*          The order of the matrix A.  N >= 0. */
00088 
00089 /*  NRHS    (input) INTEGER */
00090 /*          The number of right hand sides, i.e., the number of columns */
00091 /*          of the matrices X and B.  NRHS >= 0. */
00092 
00093 /*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2) */
00094 /*          The upper or lower triangular matrix A, packed columnwise in */
00095 /*          a linear array.  The j-th column of A is stored in the array */
00096 /*          AP as follows: */
00097 /*          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j; */
00098 /*          if UPLO = 'L', */
00099 /*             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n. */
00100 
00101 /*  SCALE   (input) DOUBLE PRECISION */
00102 /*          The scaling factor s used in solving the triangular system. */
00103 
00104 /*  CNORM   (input) DOUBLE PRECISION array, dimension (N) */
00105 /*          The 1-norms of the columns of A, not counting the diagonal. */
00106 
00107 /*  TSCAL   (input) DOUBLE PRECISION */
00108 /*          The scaling factor used in computing the 1-norms in CNORM. */
00109 /*          CNORM actually contains the column norms of TSCAL*A. */
00110 
00111 /*  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS) */
00112 /*          The computed solution vectors for the system of linear */
00113 /*          equations. */
00114 
00115 /*  LDX     (input) INTEGER */
00116 /*          The leading dimension of the array X.  LDX >= max(1,N). */
00117 
00118 /*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */
00119 /*          The right hand side vectors for the system of linear */
00120 /*          equations. */
00121 
00122 /*  LDB     (input) INTEGER */
00123 /*          The leading dimension of the array B.  LDB >= max(1,N). */
00124 
00125 /*  WORK    (workspace) DOUBLE PRECISION array, dimension (N) */
00126 
00127 /*  RESID   (output) DOUBLE PRECISION */
00128 /*          The maximum over the number of right hand sides of */
00129 /*          norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
00130 
00131 /*  ===================================================================== */
00132 
00133 /*     .. Parameters .. */
00134 /*     .. */
00135 /*     .. Local Scalars .. */
00136 /*     .. */
00137 /*     .. External Functions .. */
00138 /*     .. */
00139 /*     .. External Subroutines .. */
00140 /*     .. */
00141 /*     .. Intrinsic Functions .. */
00142 /*     .. */
00143 /*     .. Executable Statements .. */
00144 
00145 /*     Quick exit if N = 0. */
00146 
00147     /* Parameter adjustments */
00148     --ap;
00149     --cnorm;
00150     x_dim1 = *ldx;
00151     x_offset = 1 + x_dim1;
00152     x -= x_offset;
00153     b_dim1 = *ldb;
00154     b_offset = 1 + b_dim1;
00155     b -= b_offset;
00156     --work;
00157 
00158     /* Function Body */
00159     if (*n <= 0 || *nrhs <= 0) {
00160         *resid = 0.;
00161         return 0;
00162     }
00163     eps = dlamch_("Epsilon");
00164     smlnum = dlamch_("Safe minimum");
00165     bignum = 1. / smlnum;
00166     dlabad_(&smlnum, &bignum);
00167 
00168 /*     Compute the norm of the triangular matrix A using the column */
00169 /*     norms already computed by DLATPS. */
00170 
00171     tnorm = 0.;
00172     if (lsame_(diag, "N")) {
00173         if (lsame_(uplo, "U")) {
00174             jj = 1;
00175             i__1 = *n;
00176             for (j = 1; j <= i__1; ++j) {
00177 /* Computing MAX */
00178                 d__2 = tnorm, d__3 = *tscal * (d__1 = ap[jj], abs(d__1)) + 
00179                         cnorm[j];
00180                 tnorm = max(d__2,d__3);
00181                 jj = jj + j + 1;
00182 /* L10: */
00183             }
00184         } else {
00185             jj = 1;
00186             i__1 = *n;
00187             for (j = 1; j <= i__1; ++j) {
00188 /* Computing MAX */
00189                 d__2 = tnorm, d__3 = *tscal * (d__1 = ap[jj], abs(d__1)) + 
00190                         cnorm[j];
00191                 tnorm = max(d__2,d__3);
00192                 jj = jj + *n - j + 1;
00193 /* L20: */
00194             }
00195         }
00196     } else {
00197         i__1 = *n;
00198         for (j = 1; j <= i__1; ++j) {
00199 /* Computing MAX */
00200             d__1 = tnorm, d__2 = *tscal + cnorm[j];
00201             tnorm = max(d__1,d__2);
00202 /* L30: */
00203         }
00204     }
00205 
00206 /*     Compute the maximum over the number of right hand sides of */
00207 /*        norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
00208 
00209     *resid = 0.;
00210     i__1 = *nrhs;
00211     for (j = 1; j <= i__1; ++j) {
00212         dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
00213         ix = idamax_(n, &work[1], &c__1);
00214 /* Computing MAX */
00215         d__2 = 1., d__3 = (d__1 = x[ix + j * x_dim1], abs(d__1));
00216         xnorm = max(d__2,d__3);
00217         xscal = 1. / xnorm / (doublereal) (*n);
00218         dscal_(n, &xscal, &work[1], &c__1);
00219         dtpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
00220         d__1 = -(*scale) * xscal;
00221         daxpy_(n, &d__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
00222         ix = idamax_(n, &work[1], &c__1);
00223         err = *tscal * (d__1 = work[ix], abs(d__1));
00224         ix = idamax_(n, &x[j * x_dim1 + 1], &c__1);
00225         xnorm = (d__1 = x[ix + j * x_dim1], abs(d__1));
00226         if (err * smlnum <= xnorm) {
00227             if (xnorm > 0.) {
00228                 err /= xnorm;
00229             }
00230         } else {
00231             if (err > 0.) {
00232                 err = 1. / eps;
00233             }
00234         }
00235         if (err * smlnum <= tnorm) {
00236             if (tnorm > 0.) {
00237                 err /= tnorm;
00238             }
00239         } else {
00240             if (err > 0.) {
00241                 err = 1. / eps;
00242             }
00243         }
00244         *resid = max(*resid,err);
00245 /* L40: */
00246     }
00247 
00248     return 0;
00249 
00250 /*     End of DTPT03 */
00251 
00252 } /* dtpt03_ */


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:49