swiftnav: cerrhe.c Source File

Go to the documentation of this file.
00001 /* cerrhe.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 /* Common Block Declarations */
00017 
00018 struct {
00019     integer infot, nout;
00020     logical ok, lerr;
00021 } infoc_;
00022 
00023 #define infoc_1 infoc_
00024 
00025 struct {
00026     char srnamt[32];
00027 } srnamc_;
00028 
00029 #define srnamc_1 srnamc_
00030 
00031 /* Table of constant values */
00032 
00033 static integer c__2 = 2;
00034 static integer c__0 = 0;
00035 static integer c__1 = 1;
00036 static integer c_n1 = -1;
00037 static integer c__4 = 4;
00038 
00039 /* Subroutine */ int cerrhe_(char *path, integer *nunit)
00040 {
00041     /* System generated locals */
00042     integer i__1;
00043     real r__1, r__2;
00044     complex q__1;
00045 
00046     /* Builtin functions */
00047     integer s_wsle(cilist *), e_wsle(void);
00048     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00049 
00050     /* Local variables */
00051     complex a[16]       /* was [4][4] */, b[4];
00052     integer i__, j;
00053     real r__[4];
00054     complex w[8], x[4];
00055     char c2[2];
00056     real r1[4], r2[4];
00057     complex af[16]      /* was [4][4] */;
00058     integer ip[4], info;
00059     real anrm, rcond;
00060     extern /* Subroutine */ int chetf2_(char *, integer *, complex *, integer 
00061             *, integer *, integer *), checon_(char *, integer *, 
00062             complex *, integer *, integer *, real *, real *, complex *, 
00063             integer *), alaesm_(char *, logical *, integer *),
00064              cherfs_(char *, integer *, integer *, complex *, integer *, 
00065             complex *, integer *, integer *, complex *, integer *, complex *, 
00066             integer *, real *, real *, complex *, real *, integer *), 
00067             chetrf_(char *, integer *, complex *, integer *, integer *, 
00068             complex *, integer *, integer *), chpcon_(char *, integer 
00069             *, complex *, integer *, real *, real *, complex *, integer *), chetri_(char *, integer *, complex *, integer *, integer 
00070             *, complex *, integer *);
00071     extern logical lsamen_(integer *, char *, char *);
00072     extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical 
00073             *, logical *), chprfs_(char *, integer *, integer *, 
00074             complex *, complex *, integer *, complex *, integer *, complex *, 
00075             integer *, real *, real *, complex *, real *, integer *), 
00076             chptrf_(char *, integer *, complex *, integer *, integer *), chetrs_(char *, integer *, integer *, complex *, integer 
00077             *, integer *, complex *, integer *, integer *), chptri_(
00078             char *, integer *, complex *, integer *, complex *, integer *), chptrs_(char *, integer *, integer *, complex *, integer 
00079             *, complex *, integer *, integer *);
00080 
00081     /* Fortran I/O blocks */
00082     static cilist io___1 = { 0, 0, 0, 0, 0 };
00083 
00084 
00085 
00086 /*  -- LAPACK test routine (version 3.1) -- */
00087 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00088 /*     November 2006 */
00089 
00090 /*     .. Scalar Arguments .. */
00091 /*     .. */
00092 
00093 /*  Purpose */
00094 /*  ======= */
00095 
00096 /*  CERRHE tests the error exits for the COMPLEX routines */
00097 /*  for Hermitian indefinite matrices. */
00098 
00099 /*  Arguments */
00100 /*  ========= */
00101 
00102 /*  PATH    (input) CHARACTER*3 */
00103 /*          The LAPACK path name for the routines to be tested. */
00104 
00105 /*  NUNIT   (input) INTEGER */
00106 /*          The unit number for output. */
00107 
00108 /*  ===================================================================== */
00109 
00110 
00111 /*     .. Parameters .. */
00112 /*     .. */
00113 /*     .. Local Scalars .. */
00114 /*     .. */
00115 /*     .. Local Arrays .. */
00116 /*     .. */
00117 /*     .. External Functions .. */
00118 /*     .. */
00119 /*     .. External Subroutines .. */
00120 /*     .. */
00121 /*     .. Scalars in Common .. */
00122 /*     .. */
00123 /*     .. Common blocks .. */
00124 /*     .. */
00125 /*     .. Intrinsic Functions .. */
00126 /*     .. */
00127 /*     .. Executable Statements .. */
00128 
00129     infoc_1.nout = *nunit;
00130     io___1.ciunit = infoc_1.nout;
00131     s_wsle(&io___1);
00132     e_wsle();
00133     s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
00134 
00135 /*     Set the variables to innocuous values. */
00136 
00137     for (j = 1; j <= 4; ++j) {
00138         for (i__ = 1; i__ <= 4; ++i__) {
00139             i__1 = i__ + (j << 2) - 5;
00140             r__1 = 1.f / (real) (i__ + j);
00141             r__2 = -1.f / (real) (i__ + j);
00142             q__1.r = r__1, q__1.i = r__2;
00143             a[i__1].r = q__1.r, a[i__1].i = q__1.i;
00144             i__1 = i__ + (j << 2) - 5;
00145             r__1 = 1.f / (real) (i__ + j);
00146             r__2 = -1.f / (real) (i__ + j);
00147             q__1.r = r__1, q__1.i = r__2;
00148             af[i__1].r = q__1.r, af[i__1].i = q__1.i;
00149 /* L10: */
00150         }
00151         i__1 = j - 1;
00152         b[i__1].r = 0.f, b[i__1].i = 0.f;
00153         r1[j - 1] = 0.f;
00154         r2[j - 1] = 0.f;
00155         i__1 = j - 1;
00156         w[i__1].r = 0.f, w[i__1].i = 0.f;
00157         i__1 = j - 1;
00158         x[i__1].r = 0.f, x[i__1].i = 0.f;
00159         ip[j - 1] = j;
00160 /* L20: */
00161     }
00162     anrm = 1.f;
00163     infoc_1.ok = TRUE_;
00164 
00165 /*     Test error exits of the routines that use the diagonal pivoting */
00166 /*     factorization of a Hermitian indefinite matrix. */
00167 
00168     if (lsamen_(&c__2, c2, "HE")) {
00169 
00170 /*        CHETRF */
00171 
00172         s_copy(srnamc_1.srnamt, "CHETRF", (ftnlen)32, (ftnlen)6);
00173         infoc_1.infot = 1;
00174         chetrf_("/", &c__0, a, &c__1, ip, w, &c__1, &info);
00175         chkxer_("CHETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00176                 infoc_1.ok);
00177         infoc_1.infot = 2;
00178         chetrf_("U", &c_n1, a, &c__1, ip, w, &c__1, &info);
00179         chkxer_("CHETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00180                 infoc_1.ok);
00181         infoc_1.infot = 4;
00182         chetrf_("U", &c__2, a, &c__1, ip, w, &c__4, &info);
00183         chkxer_("CHETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00184                 infoc_1.ok);
00185 
00186 /*        CHETF2 */
00187 
00188         s_copy(srnamc_1.srnamt, "CHETF2", (ftnlen)32, (ftnlen)6);
00189         infoc_1.infot = 1;
00190         chetf2_("/", &c__0, a, &c__1, ip, &info);
00191         chkxer_("CHETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00192                 infoc_1.ok);
00193         infoc_1.infot = 2;
00194         chetf2_("U", &c_n1, a, &c__1, ip, &info);
00195         chkxer_("CHETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00196                 infoc_1.ok);
00197         infoc_1.infot = 4;
00198         chetf2_("U", &c__2, a, &c__1, ip, &info);
00199         chkxer_("CHETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00200                 infoc_1.ok);
00201 
00202 /*        CHETRI */
00203 
00204         s_copy(srnamc_1.srnamt, "CHETRI", (ftnlen)32, (ftnlen)6);
00205         infoc_1.infot = 1;
00206         chetri_("/", &c__0, a, &c__1, ip, w, &info);
00207         chkxer_("CHETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00208                 infoc_1.ok);
00209         infoc_1.infot = 2;
00210         chetri_("U", &c_n1, a, &c__1, ip, w, &info);
00211         chkxer_("CHETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00212                 infoc_1.ok);
00213         infoc_1.infot = 4;
00214         chetri_("U", &c__2, a, &c__1, ip, w, &info);
00215         chkxer_("CHETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00216                 infoc_1.ok);
00217 
00218 /*        CHETRS */
00219 
00220         s_copy(srnamc_1.srnamt, "CHETRS", (ftnlen)32, (ftnlen)6);
00221         infoc_1.infot = 1;
00222         chetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
00223         chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00224                 infoc_1.ok);
00225         infoc_1.infot = 2;
00226         chetrs_("U", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
00227         chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00228                 infoc_1.ok);
00229         infoc_1.infot = 3;
00230         chetrs_("U", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
00231         chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00232                 infoc_1.ok);
00233         infoc_1.infot = 5;
00234         chetrs_("U", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
00235         chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00236                 infoc_1.ok);
00237         infoc_1.infot = 8;
00238         chetrs_("U", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
00239         chkxer_("CHETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00240                 infoc_1.ok);
00241 
00242 /*        CHERFS */
00243 
00244         s_copy(srnamc_1.srnamt, "CHERFS", (ftnlen)32, (ftnlen)6);
00245         infoc_1.infot = 1;
00246         cherfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
00247                 c__1, r1, r2, w, r__, &info);
00248         chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00249                 infoc_1.ok);
00250         infoc_1.infot = 2;
00251         cherfs_("U", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
00252                 c__1, r1, r2, w, r__, &info);
00253         chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00254                 infoc_1.ok);
00255         infoc_1.infot = 3;
00256         cherfs_("U", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
00257                 c__1, r1, r2, w, r__, &info);
00258         chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00259                 infoc_1.ok);
00260         infoc_1.infot = 5;
00261         cherfs_("U", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
00262                 c__2, r1, r2, w, r__, &info);
00263         chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00264                 infoc_1.ok);
00265         infoc_1.infot = 7;
00266         cherfs_("U", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
00267                 c__2, r1, r2, w, r__, &info);
00268         chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00269                 infoc_1.ok);
00270         infoc_1.infot = 10;
00271         cherfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
00272                 c__2, r1, r2, w, r__, &info);
00273         chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00274                 infoc_1.ok);
00275         infoc_1.infot = 12;
00276         cherfs_("U", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
00277                 c__1, r1, r2, w, r__, &info);
00278         chkxer_("CHERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00279                 infoc_1.ok);
00280 
00281 /*        CHECON */
00282 
00283         s_copy(srnamc_1.srnamt, "CHECON", (ftnlen)32, (ftnlen)6);
00284         infoc_1.infot = 1;
00285         checon_("/", &c__0, a, &c__1, ip, &anrm, &rcond, w, &info);
00286         chkxer_("CHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00287                 infoc_1.ok);
00288         infoc_1.infot = 2;
00289         checon_("U", &c_n1, a, &c__1, ip, &anrm, &rcond, w, &info);
00290         chkxer_("CHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00291                 infoc_1.ok);
00292         infoc_1.infot = 4;
00293         checon_("U", &c__2, a, &c__1, ip, &anrm, &rcond, w, &info);
00294         chkxer_("CHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00295                 infoc_1.ok);
00296         infoc_1.infot = 6;
00297         r__1 = -anrm;
00298         checon_("U", &c__1, a, &c__1, ip, &r__1, &rcond, w, &info);
00299         chkxer_("CHECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00300                 infoc_1.ok);
00301 
00302 /*     Test error exits of the routines that use the diagonal pivoting */
00303 /*     factorization of a Hermitian indefinite packed matrix. */
00304 
00305     } else if (lsamen_(&c__2, c2, "HP")) {
00306 
00307 /*        CHPTRF */
00308 
00309         s_copy(srnamc_1.srnamt, "CHPTRF", (ftnlen)32, (ftnlen)6);
00310         infoc_1.infot = 1;
00311         chptrf_("/", &c__0, a, ip, &info);
00312         chkxer_("CHPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00313                 infoc_1.ok);
00314         infoc_1.infot = 2;
00315         chptrf_("U", &c_n1, a, ip, &info);
00316         chkxer_("CHPTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00317                 infoc_1.ok);
00318 
00319 /*        CHPTRI */
00320 
00321         s_copy(srnamc_1.srnamt, "CHPTRI", (ftnlen)32, (ftnlen)6);
00322         infoc_1.infot = 1;
00323         chptri_("/", &c__0, a, ip, w, &info);
00324         chkxer_("CHPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00325                 infoc_1.ok);
00326         infoc_1.infot = 2;
00327         chptri_("U", &c_n1, a, ip, w, &info);
00328         chkxer_("CHPTRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00329                 infoc_1.ok);
00330 
00331 /*        CHPTRS */
00332 
00333         s_copy(srnamc_1.srnamt, "CHPTRS", (ftnlen)32, (ftnlen)6);
00334         infoc_1.infot = 1;
00335         chptrs_("/", &c__0, &c__0, a, ip, b, &c__1, &info);
00336         chkxer_("CHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00337                 infoc_1.ok);
00338         infoc_1.infot = 2;
00339         chptrs_("U", &c_n1, &c__0, a, ip, b, &c__1, &info);
00340         chkxer_("CHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00341                 infoc_1.ok);
00342         infoc_1.infot = 3;
00343         chptrs_("U", &c__0, &c_n1, a, ip, b, &c__1, &info);
00344         chkxer_("CHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00345                 infoc_1.ok);
00346         infoc_1.infot = 7;
00347         chptrs_("U", &c__2, &c__1, a, ip, b, &c__1, &info);
00348         chkxer_("CHPTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00349                 infoc_1.ok);
00350 
00351 /*        CHPRFS */
00352 
00353         s_copy(srnamc_1.srnamt, "CHPRFS", (ftnlen)32, (ftnlen)6);
00354         infoc_1.infot = 1;
00355         chprfs_("/", &c__0, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w, 
00356                 r__, &info);
00357         chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00358                 infoc_1.ok);
00359         infoc_1.infot = 2;
00360         chprfs_("U", &c_n1, &c__0, a, af, ip, b, &c__1, x, &c__1, r1, r2, w, 
00361                 r__, &info);
00362         chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00363                 infoc_1.ok);
00364         infoc_1.infot = 3;
00365         chprfs_("U", &c__0, &c_n1, a, af, ip, b, &c__1, x, &c__1, r1, r2, w, 
00366                 r__, &info);
00367         chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00368                 infoc_1.ok);
00369         infoc_1.infot = 8;
00370         chprfs_("U", &c__2, &c__1, a, af, ip, b, &c__1, x, &c__2, r1, r2, w, 
00371                 r__, &info);
00372         chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00373                 infoc_1.ok);
00374         infoc_1.infot = 10;
00375         chprfs_("U", &c__2, &c__1, a, af, ip, b, &c__2, x, &c__1, r1, r2, w, 
00376                 r__, &info);
00377         chkxer_("CHPRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00378                 infoc_1.ok);
00379 
00380 /*        CHPCON */
00381 
00382         s_copy(srnamc_1.srnamt, "CHPCON", (ftnlen)32, (ftnlen)6);
00383         infoc_1.infot = 1;
00384         chpcon_("/", &c__0, a, ip, &anrm, &rcond, w, &info);
00385         chkxer_("CHPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00386                 infoc_1.ok);
00387         infoc_1.infot = 2;
00388         chpcon_("U", &c_n1, a, ip, &anrm, &rcond, w, &info);
00389         chkxer_("CHPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00390                 infoc_1.ok);
00391         infoc_1.infot = 5;
00392         r__1 = -anrm;
00393         chpcon_("U", &c__1, a, ip, &r__1, &rcond, w, &info);
00394         chkxer_("CHPCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
00395                 infoc_1.ok);
00396     }
00397 
00398 /*     Print a summary line. */
00399 
00400     alaesm_(path, &infoc_1.ok, &infoc_1.nout);
00401 
00402     return 0;
00403 
00404 /*     End of CERRHE */
00405 
00406 } /* cerrhe_ */