cchkbk.c
Go to the documentation of this file.
00001 /* cchkbk.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__3 = 3;
00019 static integer c__1 = 1;
00020 static integer c__4 = 4;
00021 static integer c__6 = 6;
00022 static integer c__20 = 20;
00023 
00024 /* Subroutine */ int cchkbk_(integer *nin, integer *nout)
00025 {
00026     /* Format strings */
00027     static char fmt_9999[] = "(1x,\002.. test output of CGEBAK .. \002)";
00028     static char fmt_9998[] = "(1x,\002value of largest test error           "
00029             "  = \002,e12.3)";
00030     static char fmt_9997[] = "(1x,\002example number where info is not zero "
00031             "  = \002,i4)";
00032     static char fmt_9996[] = "(1x,\002example number having largest error   "
00033             "  = \002,i4)";
00034     static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
00035             "  = \002,i4)";
00036     static char fmt_9994[] = "(1x,\002total number of examples tested       "
00037             "  = \002,i4)";
00038 
00039     /* System generated locals */
00040     integer i__1, i__2, i__3, i__4;
00041     real r__1, r__2, r__3, r__4;
00042     complex q__1, q__2;
00043 
00044     /* Builtin functions */
00045     integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), 
00046             e_rsle(void);
00047     double r_imag(complex *);
00048     integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
00049 
00050     /* Local variables */
00051     complex e[400]      /* was [20][20] */;
00052     integer i__, j, n;
00053     real x;
00054     integer ihi;
00055     complex ein[400]    /* was [20][20] */;
00056     integer ilo;
00057     real eps;
00058     integer knt, info, lmax[2];
00059     real rmax, vmax, scale[20];
00060     integer ninfo;
00061     extern /* Subroutine */ int cgebak_(char *, char *, integer *, integer *, 
00062             integer *, real *, integer *, complex *, integer *, integer *);
00063     extern doublereal slamch_(char *);
00064     real safmin;
00065 
00066     /* Fortran I/O blocks */
00067     static cilist io___7 = { 0, 0, 0, 0, 0 };
00068     static cilist io___11 = { 0, 0, 0, 0, 0 };
00069     static cilist io___14 = { 0, 0, 0, 0, 0 };
00070     static cilist io___17 = { 0, 0, 0, 0, 0 };
00071     static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
00072     static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
00073     static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
00074     static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
00075     static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
00076     static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
00077 
00078 
00079 
00080 /*  -- LAPACK test routine (version 3.1) -- */
00081 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00082 /*     November 2006 */
00083 
00084 /*     .. Scalar Arguments .. */
00085 /*     .. */
00086 
00087 /*  Purpose */
00088 /*  ======= */
00089 
00090 /*  CCHKBK tests CGEBAK, a routine for backward transformation of */
00091 /*  the computed right or left eigenvectors if the orginal matrix */
00092 /*  was preprocessed by balance subroutine CGEBAL. */
00093 
00094 /*  Arguments */
00095 /*  ========= */
00096 
00097 /*  NIN     (input) INTEGER */
00098 /*          The logical unit number for input.  NIN > 0. */
00099 
00100 /*  NOUT    (input) INTEGER */
00101 /*          The logical unit number for output.  NOUT > 0. */
00102 
00103 /* ====================================================================== */
00104 
00105 /*     .. Parameters .. */
00106 /*     .. */
00107 /*     .. Local Scalars .. */
00108 /*     .. */
00109 /*     .. Local Arrays .. */
00110 /*     .. */
00111 /*     .. External Functions .. */
00112 /*     .. */
00113 /*     .. External Subroutines .. */
00114 /*     .. */
00115 /*     .. Intrinsic Functions .. */
00116 /*     .. */
00117 /*     .. Statement Functions .. */
00118 /*     .. */
00119 /*     .. Statement Function definitions .. */
00120 /*     .. */
00121 /*     .. Executable Statements .. */
00122 
00123     lmax[0] = 0;
00124     lmax[1] = 0;
00125     ninfo = 0;
00126     knt = 0;
00127     rmax = 0.f;
00128     eps = slamch_("E");
00129     safmin = slamch_("S");
00130 
00131 L10:
00132 
00133     io___7.ciunit = *nin;
00134     s_rsle(&io___7);
00135     do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
00136     do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
00137     do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
00138     e_rsle();
00139     if (n == 0) {
00140         goto L60;
00141     }
00142 
00143     io___11.ciunit = *nin;
00144     s_rsle(&io___11);
00145     i__1 = n;
00146     for (i__ = 1; i__ <= i__1; ++i__) {
00147         do_lio(&c__4, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(real));
00148     }
00149     e_rsle();
00150     i__1 = n;
00151     for (i__ = 1; i__ <= i__1; ++i__) {
00152         io___14.ciunit = *nin;
00153         s_rsle(&io___14);
00154         i__2 = n;
00155         for (j = 1; j <= i__2; ++j) {
00156             do_lio(&c__6, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
00157                     sizeof(complex));
00158         }
00159         e_rsle();
00160 /* L20: */
00161     }
00162 
00163     i__1 = n;
00164     for (i__ = 1; i__ <= i__1; ++i__) {
00165         io___17.ciunit = *nin;
00166         s_rsle(&io___17);
00167         i__2 = n;
00168         for (j = 1; j <= i__2; ++j) {
00169             do_lio(&c__6, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
00170                     sizeof(complex));
00171         }
00172         e_rsle();
00173 /* L30: */
00174     }
00175 
00176     ++knt;
00177     cgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
00178 
00179     if (info != 0) {
00180         ++ninfo;
00181         lmax[0] = knt;
00182     }
00183 
00184     vmax = 0.f;
00185     i__1 = n;
00186     for (i__ = 1; i__ <= i__1; ++i__) {
00187         i__2 = n;
00188         for (j = 1; j <= i__2; ++j) {
00189             i__3 = i__ + j * 20 - 21;
00190             i__4 = i__ + j * 20 - 21;
00191             q__2.r = e[i__3].r - ein[i__4].r, q__2.i = e[i__3].i - ein[i__4]
00192                     .i;
00193             q__1.r = q__2.r, q__1.i = q__2.i;
00194             x = ((r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&q__1), dabs(
00195                     r__2))) / eps;
00196             i__3 = i__ + j * 20 - 21;
00197             if ((r__1 = e[i__3].r, dabs(r__1)) + (r__2 = r_imag(&e[i__ + j * 
00198                     20 - 21]), dabs(r__2)) > safmin) {
00199                 i__4 = i__ + j * 20 - 21;
00200                 x /= (r__3 = e[i__4].r, dabs(r__3)) + (r__4 = r_imag(&e[i__ + 
00201                         j * 20 - 21]), dabs(r__4));
00202             }
00203             vmax = dmax(vmax,x);
00204 /* L40: */
00205         }
00206 /* L50: */
00207     }
00208 
00209     if (vmax > rmax) {
00210         lmax[1] = knt;
00211         rmax = vmax;
00212     }
00213 
00214     goto L10;
00215 
00216 L60:
00217 
00218     io___22.ciunit = *nout;
00219     s_wsfe(&io___22);
00220     e_wsfe();
00221 
00222     io___23.ciunit = *nout;
00223     s_wsfe(&io___23);
00224     do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
00225     e_wsfe();
00226     io___24.ciunit = *nout;
00227     s_wsfe(&io___24);
00228     do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
00229     e_wsfe();
00230     io___25.ciunit = *nout;
00231     s_wsfe(&io___25);
00232     do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
00233     e_wsfe();
00234     io___26.ciunit = *nout;
00235     s_wsfe(&io___26);
00236     do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
00237     e_wsfe();
00238     io___27.ciunit = *nout;
00239     s_wsfe(&io___27);
00240     do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
00241     e_wsfe();
00242 
00243     return 0;
00244 
00245 /*     End of CCHKBK */
00246 
00247 } /* cchkbk_ */


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