sgebak.c
Go to the documentation of this file.
00001 /* sgebak.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 /* Subroutine */ int sgebak_(char *job, char *side, integer *n, integer *ilo, 
00017         integer *ihi, real *scale, integer *m, real *v, integer *ldv, integer 
00018         *info)
00019 {
00020     /* System generated locals */
00021     integer v_dim1, v_offset, i__1;
00022 
00023     /* Local variables */
00024     integer i__, k;
00025     real s;
00026     integer ii;
00027     extern logical lsame_(char *, char *);
00028     extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
00029     logical leftv;
00030     extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
00031             integer *), xerbla_(char *, integer *);
00032     logical rightv;
00033 
00034 
00035 /*  -- LAPACK routine (version 3.2) -- */
00036 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00037 /*     November 2006 */
00038 
00039 /*     .. Scalar Arguments .. */
00040 /*     .. */
00041 /*     .. Array Arguments .. */
00042 /*     .. */
00043 
00044 /*  Purpose */
00045 /*  ======= */
00046 
00047 /*  SGEBAK forms the right or left eigenvectors of a real general matrix */
00048 /*  by backward transformation on the computed eigenvectors of the */
00049 /*  balanced matrix output by SGEBAL. */
00050 
00051 /*  Arguments */
00052 /*  ========= */
00053 
00054 /*  JOB     (input) CHARACTER*1 */
00055 /*          Specifies the type of backward transformation required: */
00056 /*          = 'N', do nothing, return immediately; */
00057 /*          = 'P', do backward transformation for permutation only; */
00058 /*          = 'S', do backward transformation for scaling only; */
00059 /*          = 'B', do backward transformations for both permutation and */
00060 /*                 scaling. */
00061 /*          JOB must be the same as the argument JOB supplied to SGEBAL. */
00062 
00063 /*  SIDE    (input) CHARACTER*1 */
00064 /*          = 'R':  V contains right eigenvectors; */
00065 /*          = 'L':  V contains left eigenvectors. */
00066 
00067 /*  N       (input) INTEGER */
00068 /*          The number of rows of the matrix V.  N >= 0. */
00069 
00070 /*  ILO     (input) INTEGER */
00071 /*  IHI     (input) INTEGER */
00072 /*          The integers ILO and IHI determined by SGEBAL. */
00073 /*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */
00074 
00075 /*  SCALE   (input) REAL array, dimension (N) */
00076 /*          Details of the permutation and scaling factors, as returned */
00077 /*          by SGEBAL. */
00078 
00079 /*  M       (input) INTEGER */
00080 /*          The number of columns of the matrix V.  M >= 0. */
00081 
00082 /*  V       (input/output) REAL array, dimension (LDV,M) */
00083 /*          On entry, the matrix of right or left eigenvectors to be */
00084 /*          transformed, as returned by SHSEIN or STREVC. */
00085 /*          On exit, V is overwritten by the transformed eigenvectors. */
00086 
00087 /*  LDV     (input) INTEGER */
00088 /*          The leading dimension of the array V. LDV >= max(1,N). */
00089 
00090 /*  INFO    (output) INTEGER */
00091 /*          = 0:  successful exit */
00092 /*          < 0:  if INFO = -i, the i-th argument had an illegal value. */
00093 
00094 /*  ===================================================================== */
00095 
00096 /*     .. Parameters .. */
00097 /*     .. */
00098 /*     .. Local Scalars .. */
00099 /*     .. */
00100 /*     .. External Functions .. */
00101 /*     .. */
00102 /*     .. External Subroutines .. */
00103 /*     .. */
00104 /*     .. Intrinsic Functions .. */
00105 /*     .. */
00106 /*     .. Executable Statements .. */
00107 
00108 /*     Decode and Test the input parameters */
00109 
00110     /* Parameter adjustments */
00111     --scale;
00112     v_dim1 = *ldv;
00113     v_offset = 1 + v_dim1;
00114     v -= v_offset;
00115 
00116     /* Function Body */
00117     rightv = lsame_(side, "R");
00118     leftv = lsame_(side, "L");
00119 
00120     *info = 0;
00121     if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") 
00122             && ! lsame_(job, "B")) {
00123         *info = -1;
00124     } else if (! rightv && ! leftv) {
00125         *info = -2;
00126     } else if (*n < 0) {
00127         *info = -3;
00128     } else if (*ilo < 1 || *ilo > max(1,*n)) {
00129         *info = -4;
00130     } else if (*ihi < min(*ilo,*n) || *ihi > *n) {
00131         *info = -5;
00132     } else if (*m < 0) {
00133         *info = -7;
00134     } else if (*ldv < max(1,*n)) {
00135         *info = -9;
00136     }
00137     if (*info != 0) {
00138         i__1 = -(*info);
00139         xerbla_("SGEBAK", &i__1);
00140         return 0;
00141     }
00142 
00143 /*     Quick return if possible */
00144 
00145     if (*n == 0) {
00146         return 0;
00147     }
00148     if (*m == 0) {
00149         return 0;
00150     }
00151     if (lsame_(job, "N")) {
00152         return 0;
00153     }
00154 
00155     if (*ilo == *ihi) {
00156         goto L30;
00157     }
00158 
00159 /*     Backward balance */
00160 
00161     if (lsame_(job, "S") || lsame_(job, "B")) {
00162 
00163         if (rightv) {
00164             i__1 = *ihi;
00165             for (i__ = *ilo; i__ <= i__1; ++i__) {
00166                 s = scale[i__];
00167                 sscal_(m, &s, &v[i__ + v_dim1], ldv);
00168 /* L10: */
00169             }
00170         }
00171 
00172         if (leftv) {
00173             i__1 = *ihi;
00174             for (i__ = *ilo; i__ <= i__1; ++i__) {
00175                 s = 1.f / scale[i__];
00176                 sscal_(m, &s, &v[i__ + v_dim1], ldv);
00177 /* L20: */
00178             }
00179         }
00180 
00181     }
00182 
00183 /*     Backward permutation */
00184 
00185 /*     For  I = ILO-1 step -1 until 1, */
00186 /*              IHI+1 step 1 until N do -- */
00187 
00188 L30:
00189     if (lsame_(job, "P") || lsame_(job, "B")) {
00190         if (rightv) {
00191             i__1 = *n;
00192             for (ii = 1; ii <= i__1; ++ii) {
00193                 i__ = ii;
00194                 if (i__ >= *ilo && i__ <= *ihi) {
00195                     goto L40;
00196                 }
00197                 if (i__ < *ilo) {
00198                     i__ = *ilo - ii;
00199                 }
00200                 k = scale[i__];
00201                 if (k == i__) {
00202                     goto L40;
00203                 }
00204                 sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
00205 L40:
00206                 ;
00207             }
00208         }
00209 
00210         if (leftv) {
00211             i__1 = *n;
00212             for (ii = 1; ii <= i__1; ++ii) {
00213                 i__ = ii;
00214                 if (i__ >= *ilo && i__ <= *ihi) {
00215                     goto L50;
00216                 }
00217                 if (i__ < *ilo) {
00218                     i__ = *ilo - ii;
00219                 }
00220                 k = scale[i__];
00221                 if (k == i__) {
00222                     goto L50;
00223                 }
00224                 sswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv);
00225 L50:
00226                 ;
00227             }
00228         }
00229     }
00230 
00231     return 0;
00232 
00233 /*     End of SGEBAK */
00234 
00235 } /* sgebak_ */


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