EMAN2
lapackblas.cpp
Go to the documentation of this file.
00001 /*
00002  * Author: Chao Yang
00003  * Copyright (c) 2000-2006
00004  *
00005  * This software is issued under a joint BSD/GNU license. You may use the
00006  * source code in this file under either license. However, note that the
00007  * complete EMAN2 and SPARX software packages have some GPL dependencies,
00008  * so you are responsible for compliance with the licenses of these packages
00009  * if you opt to use BSD licensing. The warranty disclaimer below holds
00010  * in either instance.
00011  *
00012  * This complete copyright notice must be included in any revised version of the
00013  * source code. Additional authorship citations may be added, but existing
00014  * author citations must be preserved.
00015  *
00016  * This program is free software; you can redistribute it and/or modify
00017  * it under the terms of the GNU General Public License as published by
00018  * the Free Software Foundation; either version 2 of the License, or
00019  * (at your option) any later version.
00020  *
00021  * This program is distributed in the hope that it will be useful,
00022  * but WITHOUT ANY WARRANTY; without even the implied warranty of
00023  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
00024  * GNU General Public License for more details.
00025  *
00026  * You should have received a copy of the GNU General Public License
00027  * along with this program; if not, write to the Free Software
00028  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
00029  *
00030  */
00031 
00032 #include <cstdio>
00033 #include <cstdlib>
00034 
00035 #include "lapackblas.h"
00036 
00037 int s_cat(char *lp, const char **rpp, integer *rnp, integer *np, ftnlen ll)
00038 //VOID s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll)
00039 {
00040    ftnlen i, n, nc;
00041    const char *f__rp;
00042 
00043    n = (int)*np;
00044    for(i = 0 ; i < n ; ++i) {
00045       nc = ll;
00046       if(rnp[i] < nc) nc = rnp[i];
00047       ll -= nc;
00048       f__rp = rpp[i];
00049       while(--nc >= 0)  *lp++ = *f__rp++;
00050    }
00051    while(--ll >= 0)
00052    *lp++ = ' ';
00053    return 0; 
00054 }
00055 
00056 integer ieeeck_(integer *ispec, real *zero, real *one)
00057 {
00058 /*  -- LAPACK auxiliary routine (version 3.0) --   
00059        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
00060        Courant Institute, Argonne National Lab, and Rice University   
00061        June 30, 1998   
00062 
00063 
00064     Purpose   
00065     =======   
00066 
00067     IEEECK is called from the ILAENV to verify that Infinity and   
00068     possibly NaN arithmetic is safe (i.e. will not trap).   
00069 
00070     Arguments   
00071     =========   
00072 
00073     ISPEC   (input) INTEGER   
00074             Specifies whether to test just for inifinity arithmetic   
00075             or whether to test for infinity and NaN arithmetic.   
00076             = 0: Verify infinity arithmetic only.   
00077             = 1: Verify infinity and NaN arithmetic.   
00078 
00079     ZERO    (input) REAL   
00080             Must contain the value 0.0   
00081             This is passed to prevent the compiler from optimizing   
00082             away this code.   
00083 
00084     ONE     (input) REAL   
00085             Must contain the value 1.0   
00086             This is passed to prevent the compiler from optimizing   
00087             away this code.   
00088 
00089     RETURN VALUE:  INTEGER   
00090             = 0:  Arithmetic failed to produce the correct answers   
00091             = 1:  Arithmetic produced the correct answers */
00092     /* System generated locals */
00093     integer ret_val;
00094     /* Local variables */
00095     static real neginf, posinf, negzro, newzro, nan1, nan2, nan3, nan4, nan5, 
00096             nan6;
00097 
00098 
00099     ret_val = 1;
00100 
00101     posinf = *one / *zero;
00102     if (posinf <= *one) {
00103         ret_val = 0;
00104         return ret_val;
00105     }
00106 
00107     neginf = -(*one) / *zero;
00108     if (neginf >= *zero) {
00109         ret_val = 0;
00110         return ret_val;
00111     }
00112 
00113     negzro = *one / (neginf + *one);
00114     if (negzro != *zero) {
00115         ret_val = 0;
00116         return ret_val;
00117     }
00118 
00119     neginf = *one / negzro;
00120     if (neginf >= *zero) {
00121         ret_val = 0;
00122         return ret_val;
00123     }
00124 
00125     newzro = negzro + *zero;
00126     if (newzro != *zero) {
00127         ret_val = 0;
00128         return ret_val;
00129     }
00130 
00131     posinf = *one / newzro;
00132     if (posinf <= *one) {
00133         ret_val = 0;
00134         return ret_val;
00135     }
00136 
00137     neginf *= posinf;
00138     if (neginf >= *zero) {
00139         ret_val = 0;
00140         return ret_val;
00141     }
00142 
00143     posinf *= posinf;
00144     if (posinf <= *one) {
00145         ret_val = 0;
00146         return ret_val;
00147     }
00148 
00149 
00150 
00151 
00152 /*     Return if we were only asked to check infinity arithmetic */
00153 
00154     if (*ispec == 0) {
00155         return ret_val;
00156     }
00157 
00158     nan1 = posinf + neginf;
00159 
00160     nan2 = posinf / neginf;
00161 
00162     nan3 = posinf / posinf;
00163 
00164     nan4 = posinf * *zero;
00165 
00166     nan5 = neginf * negzro;
00167 
00168     nan6 = nan5 * 0.f;
00169 
00170     if (nan1 == nan1) {
00171         ret_val = 0;
00172         return ret_val;
00173     }
00174 
00175     if (nan2 == nan2) {
00176         ret_val = 0;
00177         return ret_val;
00178     }
00179 
00180     if (nan3 == nan3) {
00181         ret_val = 0;
00182         return ret_val;
00183     }
00184 
00185     if (nan4 == nan4) {
00186         ret_val = 0;
00187         return ret_val;
00188     }
00189 
00190     if (nan5 == nan5) {
00191         ret_val = 0;
00192         return ret_val;
00193     }
00194 
00195     if (nan6 == nan6) {
00196         ret_val = 0;
00197         return ret_val;
00198     }
00199 
00200     return ret_val;
00201 } /* ieeeck_ */
00202 
00203 
00204 
00205 
00206 integer ilaenv_(integer *ispec, const char *name__, const char *, integer *n1, 
00207         integer *n2, integer *, integer *n4, ftnlen name_len, ftnlen )
00208 {
00209 /*  -- LAPACK auxiliary routine (version 3.0) --   
00210        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
00211        Courant Institute, Argonne National Lab, and Rice University   
00212        June 30, 1999   
00213 
00214 
00215     Purpose   
00216     =======   
00217 
00218     ILAENV is called from the LAPACK routines to choose problem-dependent   
00219     parameters for the local environment.  See ISPEC for a description of   
00220     the parameters.   
00221 
00222     This version provides a set of parameters which should give good,   
00223     but not optimal, performance on many of the currently available   
00224     computers.  Users are encouraged to modify this subroutine to set   
00225     the tuning parameters for their particular machine using the option   
00226     and problem size information in the arguments.   
00227 
00228     This routine will not function correctly if it is converted to all   
00229     lower case.  Converting it to all upper case is allowed.   
00230 
00231     Arguments   
00232     =========   
00233 
00234     ISPEC   (input) INTEGER   
00235             Specifies the parameter to be returned as the value of   
00236             ILAENV.   
00237             = 1: the optimal blocksize; if this value is 1, an unblocked   
00238                  algorithm will give the best performance.   
00239             = 2: the minimum block size for which the block routine   
00240                  should be used; if the usable block size is less than   
00241                  this value, an unblocked routine should be used.   
00242             = 3: the crossover point (in a block routine, for N less   
00243                  than this value, an unblocked routine should be used)   
00244             = 4: the number of shifts, used in the nonsymmetric   
00245                  eigenvalue routines   
00246             = 5: the MINIMUM Column dimension for blocking to be used;   
00247                  rectangular blocks must have dimension at least k by m,   
00248                  where k is given by ILAENV(2,...) and m by ILAENV(5,...)   
00249             = 6: the crossover point for the SVD (when reducing an m by n   
00250                  matrix to bidiagonal form, if f2cmax(m,n)/min(m,n) exceeds   
00251                  this value, a QR factorization is used first to reduce   
00252                  the matrix to a triangular form.)   
00253             = 7: the number of processors   
00254             = 8: the crossover point for the multishift QR and QZ methods   
00255                  for nonsymmetric eigenvalue problems.   
00256             = 9: maximum size of the subproblems at the bottom of the   
00257                  computation tree in the divide-and-conquer algorithm   
00258                  (used by xGELSD and xGESDD)   
00259             =10: ieee NaN arithmetic can be trusted not to trap   
00260             =11: infinity arithmetic can be trusted not to trap   
00261 
00262     NAME    (input) CHARACTER*(*)   
00263             The name of the calling subroutine, in either upper case or   
00264             lower case.   
00265 
00266     OPTS    (input) CHARACTER*(*)   
00267             The character options to the subroutine NAME, concatenated   
00268             into a single character string.  For example, UPLO = 'U',   
00269             TRANS = 'T', and DIAG = 'N' for a triangular routine would   
00270             be specified as OPTS = 'UTN'.   
00271 
00272     N1      (input) INTEGER   
00273     N2      (input) INTEGER   
00274     N3      (input) INTEGER   
00275     N4      (input) INTEGER   
00276             Problem dimensions for the subroutine NAME; these may not all   
00277             be required.   
00278 
00279    (ILAENV) (output) INTEGER   
00280             >= 0: the value of the parameter specified by ISPEC   
00281             < 0:  if ILAENV = -k, the k-th argument had an illegal value.   
00282 
00283     Further Details   
00284     ===============   
00285 
00286     The following conventions have been used when calling ILAENV from the   
00287     LAPACK routines:   
00288     1)  OPTS is a concatenation of all of the character options to   
00289         subroutine NAME, in the same order that they appear in the   
00290         argument list for NAME, even if they are not used in determining   
00291         the value of the parameter specified by ISPEC.   
00292     2)  The problem dimensions N1, N2, N3, N4 are specified in the order   
00293         that they appear in the argument list for NAME.  N1 is used   
00294         first, N2 second, and so on, and unused problem dimensions are   
00295         passed a value of -1.   
00296     3)  The parameter value returned by ILAENV is checked for validity in   
00297         the calling subroutine.  For example, ILAENV is used to retrieve   
00298         the optimal blocksize for STRTRI as follows:   
00299 
00300         NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )   
00301         IF( NB.LE.1 ) NB = MAX( 1, N )   
00302 
00303     ===================================================================== */
00304     /* Table of constant values */
00305     static integer c__0 = 0;
00306     static real c_b162 = 0.f;
00307     static real c_b163 = 1.f;
00308     static integer c__1 = 1;
00309     
00310     /* System generated locals */
00311     integer ret_val;
00312     /* Builtin functions   
00313        Subroutine */ void s_copy(char *, const char *, ftnlen, ftnlen);
00314     integer s_cmp(char *, const char *, ftnlen, ftnlen);
00315     /* Local variables */
00316     static integer i__;
00317     static logical cname, sname;
00318     static integer nbmin;
00319     static char c1[1], c2[2], c3[3], c4[2];
00320     static integer ic, nb;
00321     extern integer ieeeck_(integer *, real *, real *);
00322     static integer iz, nx;
00323     static char subnam[6];
00324 
00325 
00326 
00327 
00328     switch (*ispec) {
00329         case 1:  goto L100;
00330         case 2:  goto L100;
00331         case 3:  goto L100;
00332         case 4:  goto L400;
00333         case 5:  goto L500;
00334         case 6:  goto L600;
00335         case 7:  goto L700;
00336         case 8:  goto L800;
00337         case 9:  goto L900;
00338         case 10:  goto L1000;
00339         case 11:  goto L1100;
00340     }
00341 
00342 /*     Invalid value for ISPEC */
00343 
00344     ret_val = -1;
00345     return ret_val;
00346 
00347 L100:
00348 
00349 /*     Convert NAME to upper case if the first character is lower case. */
00350 
00351     ret_val = 1;
00352     s_copy(subnam, name__, (ftnlen)6, name_len);
00353     ic = *(unsigned char *)subnam;
00354     iz = 'Z';
00355     if (iz == 90 || iz == 122) {
00356 
00357 /*        ASCII character set */
00358 
00359         if (ic >= 97 && ic <= 122) {
00360             *(unsigned char *)subnam = (char) (ic - 32);
00361             for (i__ = 2; i__ <= 6; ++i__) {
00362                 ic = *(unsigned char *)&subnam[i__ - 1];
00363                 if (ic >= 97 && ic <= 122) {
00364                     *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
00365                 }
00366 /* L10: */
00367             }
00368         }
00369 
00370     } else if (iz == 233 || iz == 169) {
00371 
00372 /*        EBCDIC character set */
00373 
00374         if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && 
00375                 ic <= 169) {
00376             *(unsigned char *)subnam = (char) (ic + 64);
00377             for (i__ = 2; i__ <= 6; ++i__) {
00378                 ic = *(unsigned char *)&subnam[i__ - 1];
00379                 if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 
00380                         162 && ic <= 169) {
00381                     *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
00382                 }
00383 /* L20: */
00384             }
00385         }
00386 
00387     } else if (iz == 218 || iz == 250) {
00388 
00389 /*        Prime machines:  ASCII+128 */
00390 
00391         if (ic >= 225 && ic <= 250) {
00392             *(unsigned char *)subnam = (char) (ic - 32);
00393             for (i__ = 2; i__ <= 6; ++i__) {
00394                 ic = *(unsigned char *)&subnam[i__ - 1];
00395                 if (ic >= 225 && ic <= 250) {
00396                     *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
00397                 }
00398 /* L30: */
00399             }
00400         }
00401     }
00402 
00403     *(unsigned char *)c1 = *(unsigned char *)subnam;
00404     sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
00405     cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
00406     if (! (cname || sname)) {
00407         return ret_val;
00408     }
00409     s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2);
00410     s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3);
00411     s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2);
00412 
00413     switch (*ispec) {
00414         case 1:  goto L110;
00415         case 2:  goto L200;
00416         case 3:  goto L300;
00417     }
00418 
00419 L110:
00420 
00421 /*     ISPEC = 1:  block size   
00422 
00423        In these examples, separate code is provided for setting NB for   
00424        real and complex.  We assume that NB will take the same value in   
00425        single or double precision. */
00426 
00427     nb = 1;
00428 
00429     if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
00430         if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00431             if (sname) {
00432                 nb = 64;
00433             } else {
00434                 nb = 64;
00435             }
00436         } else if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, 
00437                 "RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)
00438                 3, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) 
00439                 == 0) {
00440             if (sname) {
00441                 nb = 32;
00442             } else {
00443                 nb = 32;
00444             }
00445         } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
00446             if (sname) {
00447                 nb = 32;
00448             } else {
00449                 nb = 32;
00450             }
00451         } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
00452             if (sname) {
00453                 nb = 32;
00454             } else {
00455                 nb = 32;
00456             }
00457         } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
00458             if (sname) {
00459                 nb = 64;
00460             } else {
00461                 nb = 64;
00462             }
00463         }
00464     } else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) {
00465         if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00466             if (sname) {
00467                 nb = 64;
00468             } else {
00469                 nb = 64;
00470             }
00471         }
00472     } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
00473         if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00474             if (sname) {
00475                 nb = 64;
00476             } else {
00477                 nb = 64;
00478             }
00479         } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00480             nb = 32;
00481         } else if (sname && s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
00482             nb = 64;
00483         }
00484     } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
00485         if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00486             nb = 64;
00487         } else if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00488             nb = 32;
00489         } else if (s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) {
00490             nb = 64;
00491         }
00492     } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
00493         if (*(unsigned char *)c3 == 'G') {
00494             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00495                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00496                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00497                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00498                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00499                     ftnlen)2, (ftnlen)2) == 0) {
00500                 nb = 32;
00501             }
00502         } else if (*(unsigned char *)c3 == 'M') {
00503             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00504                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00505                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00506                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00507                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00508                     ftnlen)2, (ftnlen)2) == 0) {
00509                 nb = 32;
00510             }
00511         }
00512     } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
00513         if (*(unsigned char *)c3 == 'G') {
00514             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00515                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00516                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00517                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00518                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00519                     ftnlen)2, (ftnlen)2) == 0) {
00520                 nb = 32;
00521             }
00522         } else if (*(unsigned char *)c3 == 'M') {
00523             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00524                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00525                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00526                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00527                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00528                     ftnlen)2, (ftnlen)2) == 0) {
00529                 nb = 32;
00530             }
00531         }
00532     } else if (s_cmp(c2, "GB", (ftnlen)2, (ftnlen)2) == 0) {
00533         if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00534             if (sname) {
00535                 if (*n4 <= 64) {
00536                     nb = 1;
00537                 } else {
00538                     nb = 32;
00539                 }
00540             } else {
00541                 if (*n4 <= 64) {
00542                     nb = 1;
00543                 } else {
00544                     nb = 32;
00545                 }
00546             }
00547         }
00548     } else if (s_cmp(c2, "PB", (ftnlen)2, (ftnlen)2) == 0) {
00549         if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00550             if (sname) {
00551                 if (*n2 <= 64) {
00552                     nb = 1;
00553                 } else {
00554                     nb = 32;
00555                 }
00556             } else {
00557                 if (*n2 <= 64) {
00558                     nb = 1;
00559                 } else {
00560                     nb = 32;
00561                 }
00562             }
00563         }
00564     } else if (s_cmp(c2, "TR", (ftnlen)2, (ftnlen)2) == 0) {
00565         if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
00566             if (sname) {
00567                 nb = 64;
00568             } else {
00569                 nb = 64;
00570             }
00571         }
00572     } else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) {
00573         if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) {
00574             if (sname) {
00575                 nb = 64;
00576             } else {
00577                 nb = 64;
00578             }
00579         }
00580     } else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) {
00581         if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) {
00582             nb = 1;
00583         }
00584     }
00585     ret_val = nb;
00586     return ret_val;
00587 
00588 L200:
00589 
00590 /*     ISPEC = 2:  minimum block size */
00591 
00592     nbmin = 2;
00593     if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
00594         if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
00595                 ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
00596                 ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
00597                  {
00598             if (sname) {
00599                 nbmin = 2;
00600             } else {
00601                 nbmin = 2;
00602             }
00603         } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
00604             if (sname) {
00605                 nbmin = 2;
00606             } else {
00607                 nbmin = 2;
00608             }
00609         } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
00610             if (sname) {
00611                 nbmin = 2;
00612             } else {
00613                 nbmin = 2;
00614             }
00615         } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) {
00616             if (sname) {
00617                 nbmin = 2;
00618             } else {
00619                 nbmin = 2;
00620             }
00621         }
00622     } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
00623         if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) {
00624             if (sname) {
00625                 nbmin = 8;
00626             } else {
00627                 nbmin = 8;
00628             }
00629         } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00630             nbmin = 2;
00631         }
00632     } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
00633         if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00634             nbmin = 2;
00635         }
00636     } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
00637         if (*(unsigned char *)c3 == 'G') {
00638             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00639                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00640                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00641                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00642                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00643                     ftnlen)2, (ftnlen)2) == 0) {
00644                 nbmin = 2;
00645             }
00646         } else if (*(unsigned char *)c3 == 'M') {
00647             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00648                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00649                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00650                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00651                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00652                     ftnlen)2, (ftnlen)2) == 0) {
00653                 nbmin = 2;
00654             }
00655         }
00656     } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
00657         if (*(unsigned char *)c3 == 'G') {
00658             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00659                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00660                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00661                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00662                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00663                     ftnlen)2, (ftnlen)2) == 0) {
00664                 nbmin = 2;
00665             }
00666         } else if (*(unsigned char *)c3 == 'M') {
00667             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00668                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00669                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00670                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00671                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00672                     ftnlen)2, (ftnlen)2) == 0) {
00673                 nbmin = 2;
00674             }
00675         }
00676     }
00677     ret_val = nbmin;
00678     return ret_val;
00679 
00680 L300:
00681 
00682 /*     ISPEC = 3:  crossover point */
00683 
00684     nx = 0;
00685     if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) {
00686         if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
00687                 ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, (
00688                 ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0)
00689                  {
00690             if (sname) {
00691                 nx = 128;
00692             } else {
00693                 nx = 128;
00694             }
00695         } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) {
00696             if (sname) {
00697                 nx = 128;
00698             } else {
00699                 nx = 128;
00700             }
00701         } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) {
00702             if (sname) {
00703                 nx = 128;
00704             } else {
00705                 nx = 128;
00706             }
00707         }
00708     } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) {
00709         if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00710             nx = 32;
00711         }
00712     } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) {
00713         if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) {
00714             nx = 32;
00715         }
00716     } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) {
00717         if (*(unsigned char *)c3 == 'G') {
00718             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00719                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00720                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00721                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00722                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00723                     ftnlen)2, (ftnlen)2) == 0) {
00724                 nx = 128;
00725             }
00726         }
00727     } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) {
00728         if (*(unsigned char *)c3 == 'G') {
00729             if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
00730                     (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, (
00731                     ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) ==
00732                      0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(
00733                     c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
00734                     ftnlen)2, (ftnlen)2) == 0) {
00735                 nx = 128;
00736             }
00737         }
00738     }
00739     ret_val = nx;
00740     return ret_val;
00741 
00742 L400:
00743 
00744 /*     ISPEC = 4:  number of shifts (used by xHSEQR) */
00745 
00746     ret_val = 6;
00747     return ret_val;
00748 
00749 L500:
00750 
00751 /*     ISPEC = 5:  minimum column dimension (not used) */
00752 
00753     ret_val = 2;
00754     return ret_val;
00755 
00756 L600:
00757 
00758 /*     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD) */
00759 
00760     ret_val = (integer) ((real) f2cmin(*n1,*n2) * 1.6f);
00761     return ret_val;
00762 
00763 L700:
00764 
00765 /*     ISPEC = 7:  number of processors (not used) */
00766 
00767     ret_val = 1;
00768     return ret_val;
00769 
00770 L800:
00771 
00772 /*     ISPEC = 8:  crossover point for multishift (used by xHSEQR) */
00773 
00774     ret_val = 50;
00775     return ret_val;
00776 
00777 L900:
00778 
00779 /*     ISPEC = 9:  maximum size of the subproblems at the bottom of the   
00780                    computation tree in the divide-and-conquer algorithm   
00781                    (used by xGELSD and xGESDD) */
00782 
00783     ret_val = 25;
00784     return ret_val;
00785 
00786 L1000:
00787 
00788 /*     ISPEC = 10: ieee NaN arithmetic can be trusted not to trap   
00789 
00790        ILAENV = 0 */
00791     ret_val = 1;
00792     if (ret_val == 1) {
00793         ret_val = ieeeck_(&c__0, &c_b162, &c_b163);
00794     }
00795     return ret_val;
00796 
00797 L1100:
00798 
00799 /*     ISPEC = 11: infinity arithmetic can be trusted not to trap   
00800 
00801        ILAENV = 0 */
00802     ret_val = 1;
00803     if (ret_val == 1) {
00804         ret_val = ieeeck_(&c__1, &c_b162, &c_b163);
00805     }
00806     return ret_val;
00807 
00808 /*     End of ILAENV */
00809 
00810 } /* ilaenv_ */
00811 
00812 
00813 
00814 logical lsame_(const char *ca, const char *cb)
00815 {
00816 /*  -- LAPACK auxiliary routine (version 3.0) --   
00817        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
00818        Courant Institute, Argonne National Lab, and Rice University   
00819        September 30, 1994   
00820 
00821 
00822     Purpose   
00823     =======   
00824 
00825     LSAME returns .TRUE. if CA is the same letter as CB regardless of   
00826     case.   
00827 
00828     Arguments   
00829     =========   
00830 
00831     CA      (input) CHARACTER*1   
00832     CB      (input) CHARACTER*1   
00833             CA and CB specify the single characters to be compared.   
00834 
00835    ===================================================================== 
00836   
00837 
00838 
00839        Test if the characters are equal */
00840     /* System generated locals */
00841     logical ret_val;
00842     /* Local variables */
00843     static integer inta, intb, zcode;
00844 
00845 
00846     ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
00847     if (ret_val) {
00848         return ret_val;
00849     }
00850 
00851 /*     Now test for equivalence if both characters are alphabetic. */
00852 
00853     zcode = 'Z';
00854 
00855 /*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime   
00856        machines, on which ICHAR returns a value with bit 8 set.   
00857        ICHAR('A') on Prime machines returns 193 which is the same as   
00858        ICHAR('A') on an EBCDIC machine. */
00859 
00860     inta = *(unsigned char *)ca;
00861     intb = *(unsigned char *)cb;
00862 
00863     if (zcode == 90 || zcode == 122) {
00864 
00865 /*        ASCII is assumed - ZCODE is the ASCII code of either lower o
00866 r   
00867           upper case 'Z'. */
00868 
00869         if (inta >= 97 && inta <= 122) {
00870             inta += -32;
00871         }
00872         if (intb >= 97 && intb <= 122) {
00873             intb += -32;
00874         }
00875 
00876     } else if (zcode == 233 || zcode == 169) {
00877 
00878 /*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower
00879  or   
00880           upper case 'Z'. */
00881 
00882         if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta 
00883                 >= 162 && inta <= 169) {
00884             inta += 64;
00885         }
00886         if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb 
00887                 >= 162 && intb <= 169) {
00888             intb += 64;
00889         }
00890 
00891     } else if (zcode == 218 || zcode == 250) {
00892 
00893 /*        ASCII is assumed, on Prime machines - ZCODE is the ASCII cod
00894 e   
00895           plus 128 of either lower or upper case 'Z'. */
00896 
00897         if (inta >= 225 && inta <= 250) {
00898             inta += -32;
00899         }
00900         if (intb >= 225 && intb <= 250) {
00901             intb += -32;
00902         }
00903     }
00904     ret_val = inta == intb;
00905 
00906 /*     RETURN   
00907 
00908        End of LSAME */
00909 
00910     return ret_val;
00911 } /* lsame_ */
00912 
00913 
00914 
00915 #ifdef KR_headers
00916 double pow_ri(ap, bp) real *ap; integer *bp;
00917 #else
00918 double pow_ri(real *ap, integer *bp)
00919 #endif
00920 {
00921 double pow, x;
00922 integer n;
00923 unsigned long u;
00924 
00925 pow = 1;
00926 x = *ap;
00927 n = *bp;
00928 
00929 if(n != 0)
00930         {
00931         if(n < 0)
00932                 {
00933                 n = -n;
00934                 x = 1/x;
00935                 }
00936         for(u = n; ; )
00937                 {
00938                 if(u & 01)
00939                         pow *= x;
00940                 if(u >>= 1)
00941                         x *= x;
00942                 else
00943                         break;
00944                 }
00945         }
00946 return(pow);
00947 }
00948 
00949 #ifdef KR_headers
00950 integer pow_ii(ap, bp) integer *ap, *bp;
00951 #else
00952 integer pow_ii(integer *ap, integer *bp)
00953 #endif
00954 {
00955         integer pow, x, n;
00956         unsigned long u;
00957 
00958         x = *ap;
00959         n = *bp;
00960 
00961         if (n <= 0) {
00962                 if (n == 0 || x == 1)
00963                         return 1;
00964                 if (x != -1)
00965                         return x != 0 ? 1/x : 0;
00966                 n = -n;
00967                 }
00968         u = n;
00969         for(pow = 1; ; )
00970                 {
00971                 if(u & 01)
00972                         pow *= x;
00973                 if(u >>= 1)
00974                         x *= x;
00975                 else
00976                         break;
00977                 }
00978         return(pow);
00979         }
00980 
00981 #ifdef KR_headers
00982 double r_sign(a,b) real *a, *b;
00983 #else
00984 double r_sign(real *a, real *b)
00985 #endif
00986 {
00987 double x;
00988 x = (*a >= 0 ? *a : - *a);
00989 return( *b >= 0 ? x : -x);
00990 }
00991 
00992 
00993 
00994 /* Subroutine */ int saxpy_(integer *n, real *sa, real *sx, integer *incx, 
00995         real *sy, integer *incy)
00996 {
00997     /* System generated locals */
00998     integer i__1;
00999     /* Local variables */
01000     static integer i__, m, ix, iy, mp1;
01001 /*     constant times a vector plus a vector.   
01002        uses unrolled loop for increments equal to one.   
01003        jack dongarra, linpack, 3/11/78.   
01004        modified 12/3/93, array(1) declarations changed to array(*)   
01005        Parameter adjustments */
01006     --sy;
01007     --sx;
01008     /* Function Body */
01009     if (*n <= 0) {
01010         return 0;
01011     }
01012     if (*sa == 0.f) {
01013         return 0;
01014     }
01015     if (*incx == 1 && *incy == 1) {
01016         goto L20;
01017     }
01018 /*        code for unequal increments or equal increments   
01019             not equal to 1 */
01020     ix = 1;
01021     iy = 1;
01022     if (*incx < 0) {
01023         ix = (-(*n) + 1) * *incx + 1;
01024     }
01025     if (*incy < 0) {
01026         iy = (-(*n) + 1) * *incy + 1;
01027     }
01028     i__1 = *n;
01029     for (i__ = 1; i__ <= i__1; ++i__) {
01030         sy[iy] += *sa * sx[ix];
01031         ix += *incx;
01032         iy += *incy;
01033 /* L10: */
01034     }
01035     return 0;
01036 /*        code for both increments equal to 1   
01037           clean-up loop */
01038 L20:
01039     m = *n % 4;
01040     if (m == 0) {
01041         goto L40;
01042     }
01043     i__1 = m;
01044     for (i__ = 1; i__ <= i__1; ++i__) {
01045         sy[i__] += *sa * sx[i__];
01046 /* L30: */
01047     }
01048     if (*n < 4) {
01049         return 0;
01050     }
01051 L40:
01052     mp1 = m + 1;
01053     i__1 = *n;
01054     for (i__ = mp1; i__ <= i__1; i__ += 4) {
01055         sy[i__] += *sa * sx[i__];
01056         sy[i__ + 1] += *sa * sx[i__ + 1];
01057         sy[i__ + 2] += *sa * sx[i__ + 2];
01058         sy[i__ + 3] += *sa * sx[i__ + 3];
01059 /* L50: */
01060     }
01061     return 0;
01062 } /* saxpy_ */
01063 
01064 
01065 
01066 /* compare two strings */
01067 
01068 #ifdef KR_headers
01069 integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb;
01070 #else
01071 integer s_cmp(char *a0, const char *b0, ftnlen la, ftnlen lb)
01072 #endif
01073 {
01074 register unsigned char *a, *aend, *b, *bend;
01075 a = (unsigned char *)a0;
01076 b = (unsigned char *)b0;
01077 aend = a + la;
01078 bend = b + lb;
01079 
01080 if(la <= lb)
01081         {
01082         while(a < aend)
01083                 if(*a != *b)
01084                         return( *a - *b );
01085                 else
01086                         { ++a; ++b; }
01087 
01088         while(b < bend)
01089                 if(*b != ' ')
01090                         return( ' ' - *b );
01091                 else    ++b;
01092         }
01093 
01094 else
01095         {
01096         while(b < bend)
01097                 if(*a == *b)
01098                         { ++a; ++b; }
01099                 else
01100                         return( *a - *b );
01101         while(a < aend)
01102                 if(*a != ' ')
01103                         return(*a - ' ');
01104                 else    ++a;
01105         }
01106 return(0);
01107 }
01108 /* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the
01109  * target of an assignment to appear on its right-hand side (contrary
01110  * to the Fortran 77 Standard, but in accordance with Fortran 90),
01111  * as in  a(2:5) = a(4:7) .
01112  */
01113 
01114 
01115 
01116 /* assign strings:  a = b */
01117 
01118 #ifdef KR_headers
01119 VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb;
01120 #else
01121 void s_copy(char *a, const char *b, ftnlen la, ftnlen lb)
01122 #endif
01123 {
01124         register char *aend;
01125         const register char *bend;
01126 
01127         aend = a + la;
01128 
01129         if(la <= lb)
01130 #ifndef NO_OVERWRITE
01131                 if (a <= b || a >= b + la)
01132 #endif
01133                         while(a < aend)
01134                                 *a++ = *b++;
01135 #ifndef NO_OVERWRITE
01136                 else
01137                         for(b += la; a < aend; )
01138                                 *--aend = *--b;
01139 #endif
01140 
01141         else {
01142                 bend = b + lb;
01143 #ifndef NO_OVERWRITE
01144                 if (a <= b || a >= bend)
01145 #endif
01146                         while(b < bend)
01147                                 *a++ = *b++;
01148 #ifndef NO_OVERWRITE
01149                 else {
01150                         a += lb;
01151                         while(b < bend)
01152                                 *--a = *--bend;
01153                         a += lb;
01154                         }
01155 #endif
01156                 while(a < aend)
01157                         *a++ = ' ';
01158                 }
01159         }
01160 
01161 
01162 
01163 /* Subroutine */ int scopy_(integer *n, real *sx, integer *incx, real *sy, 
01164         integer *incy)
01165 {
01166     /* System generated locals */
01167     integer i__1;
01168     /* Local variables */
01169     static integer i__, m, ix, iy, mp1;
01170 /*     copies a vector, x, to a vector, y.   
01171        uses unrolled loops for increments equal to 1.   
01172        jack dongarra, linpack, 3/11/78.   
01173        modified 12/3/93, array(1) declarations changed to array(*)   
01174        Parameter adjustments */
01175     --sy;
01176     --sx;
01177     /* Function Body */
01178     if (*n <= 0) {
01179         return 0;
01180     }
01181     if (*incx == 1 && *incy == 1) {
01182         goto L20;
01183     }
01184 /*        code for unequal increments or equal increments   
01185             not equal to 1 */
01186     ix = 1;
01187     iy = 1;
01188     if (*incx < 0) {
01189         ix = (-(*n) + 1) * *incx + 1;
01190     }
01191     if (*incy < 0) {
01192         iy = (-(*n) + 1) * *incy + 1;
01193     }
01194     i__1 = *n;
01195     for (i__ = 1; i__ <= i__1; ++i__) {
01196         sy[iy] = sx[ix];
01197         ix += *incx;
01198         iy += *incy;
01199 /* L10: */
01200     }
01201     return 0;
01202 /*        code for both increments equal to 1   
01203           clean-up loop */
01204 L20:
01205     m = *n % 7;
01206     if (m == 0) {
01207         goto L40;
01208     }
01209     i__1 = m;
01210     for (i__ = 1; i__ <= i__1; ++i__) {
01211         sy[i__] = sx[i__];
01212 /* L30: */
01213     }
01214     if (*n < 7) {
01215         return 0;
01216     }
01217 L40:
01218     mp1 = m + 1;
01219     i__1 = *n;
01220     for (i__ = mp1; i__ <= i__1; i__ += 7) {
01221         sy[i__] = sx[i__];
01222         sy[i__ + 1] = sx[i__ + 1];
01223         sy[i__ + 2] = sx[i__ + 2];
01224         sy[i__ + 3] = sx[i__ + 3];
01225         sy[i__ + 4] = sx[i__ + 4];
01226         sy[i__ + 5] = sx[i__ + 5];
01227         sy[i__ + 6] = sx[i__ + 6];
01228 /* L50: */
01229     }
01230     return 0;
01231 } /* scopy_ */
01232 
01233 
01234 
01235 
01236 doublereal sdot_(integer *n, real *sx, integer *incx, real *sy, integer *incy)
01237 {
01238     /* System generated locals */
01239     integer i__1;
01240     real ret_val;
01241     /* Local variables */
01242     static integer i__, m;
01243     static real stemp;
01244     static integer ix, iy, mp1;
01245 /*     forms the dot product of two vectors.   
01246        uses unrolled loops for increments equal to one.   
01247        jack dongarra, linpack, 3/11/78.   
01248        modified 12/3/93, array(1) declarations changed to array(*)   
01249        Parameter adjustments */
01250     --sy;
01251     --sx;
01252     /* Function Body */
01253     stemp = 0.f;
01254     ret_val = 0.f;
01255     if (*n <= 0) {
01256         return ret_val;
01257     }
01258     if (*incx == 1 && *incy == 1) {
01259         goto L20;
01260     }
01261 /*        code for unequal increments or equal increments   
01262             not equal to 1 */
01263     ix = 1;
01264     iy = 1;
01265     if (*incx < 0) {
01266         ix = (-(*n) + 1) * *incx + 1;
01267     }
01268     if (*incy < 0) {
01269         iy = (-(*n) + 1) * *incy + 1;
01270     }
01271     i__1 = *n;
01272     for (i__ = 1; i__ <= i__1; ++i__) {
01273         stemp += sx[ix] * sy[iy];
01274         ix += *incx;
01275         iy += *incy;
01276 /* L10: */
01277     }
01278     ret_val = stemp;
01279     return ret_val;
01280 /*        code for both increments equal to 1   
01281           clean-up loop */
01282 L20:
01283     m = *n % 5;
01284     if (m == 0) {
01285         goto L40;
01286     }
01287     i__1 = m;
01288     for (i__ = 1; i__ <= i__1; ++i__) {
01289         stemp += sx[i__] * sy[i__];
01290 /* L30: */
01291     }
01292     if (*n < 5) {
01293         goto L60;
01294     }
01295 L40:
01296     mp1 = m + 1;
01297     i__1 = *n;
01298     for (i__ = mp1; i__ <= i__1; i__ += 5) {
01299         stemp = stemp + sx[i__] * sy[i__] + sx[i__ + 1] * sy[i__ + 1] + sx[
01300                 i__ + 2] * sy[i__ + 2] + sx[i__ + 3] * sy[i__ + 3] + sx[i__ + 
01301                 4] * sy[i__ + 4];
01302 /* L50: */
01303     }
01304 L60:
01305     ret_val = stemp;
01306     return ret_val;
01307 } /* sdot_ */
01308 
01309 
01310 
01311 
01312 /* Subroutine */ int sgemm_(const char *transa, const char *transb, integer *m, integer *
01313         n, integer *k, real *alpha, real *a, integer *lda, real *b, integer *
01314         ldb, real *beta, real *c__, integer *ldc)
01315 {
01316     /* System generated locals */
01317     integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
01318             i__3;
01319     /* Local variables */
01320     static integer info;
01321     static logical nota, notb;
01322     static real temp;
01323     static integer i__, j, l, ncola;
01324     extern logical lsame_(const char *, const char *);
01325     static integer nrowa, nrowb;
01326     extern /* Subroutine */ int xerbla_(const char *, integer *);
01327 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
01328 #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
01329 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
01330 /*  Purpose   
01331     =======   
01332     SGEMM  performs one of the matrix-matrix operations   
01333        C := alpha*op( A )*op( B ) + beta*C,   
01334     where  op( X ) is one of   
01335        op( X ) = X   or   op( X ) = X',   
01336     alpha and beta are scalars, and A, B and C are matrices, with op( A )   
01337     an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.   
01338     Parameters   
01339     ==========   
01340     TRANSA - CHARACTER*1.   
01341              On entry, TRANSA specifies the form of op( A ) to be used in   
01342              the matrix multiplication as follows:   
01343                 TRANSA = 'N' or 'n',  op( A ) = A.   
01344                 TRANSA = 'T' or 't',  op( A ) = A'.   
01345                 TRANSA = 'C' or 'c',  op( A ) = A'.   
01346              Unchanged on exit.   
01347     TRANSB - CHARACTER*1.   
01348              On entry, TRANSB specifies the form of op( B ) to be used in   
01349              the matrix multiplication as follows:   
01350                 TRANSB = 'N' or 'n',  op( B ) = B.   
01351                 TRANSB = 'T' or 't',  op( B ) = B'.   
01352                 TRANSB = 'C' or 'c',  op( B ) = B'.   
01353              Unchanged on exit.   
01354     M      - INTEGER.   
01355              On entry,  M  specifies  the number  of rows  of the  matrix   
01356              op( A )  and of the  matrix  C.  M  must  be at least  zero.   
01357              Unchanged on exit.   
01358     N      - INTEGER.   
01359              On entry,  N  specifies the number  of columns of the matrix   
01360              op( B ) and the number of columns of the matrix C. N must be   
01361              at least zero.   
01362              Unchanged on exit.   
01363     K      - INTEGER.   
01364              On entry,  K  specifies  the number of columns of the matrix   
01365              op( A ) and the number of rows of the matrix op( B ). K must   
01366              be at least  zero.   
01367              Unchanged on exit.   
01368     ALPHA  - REAL            .   
01369              On entry, ALPHA specifies the scalar alpha.   
01370              Unchanged on exit.   
01371     A      - REAL             array of DIMENSION ( LDA, ka ), where ka is   
01372              k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.   
01373              Before entry with  TRANSA = 'N' or 'n',  the leading  m by k   
01374              part of the array  A  must contain the matrix  A,  otherwise   
01375              the leading  k by m  part of the array  A  must contain  the   
01376              matrix A.   
01377              Unchanged on exit.   
01378     LDA    - INTEGER.   
01379              On entry, LDA specifies the first dimension of A as declared   
01380              in the calling (sub) program. When  TRANSA = 'N' or 'n' then   
01381              LDA must be at least  f2cmax( 1, m ), otherwise  LDA must be at   
01382              least  f2cmax( 1, k ).   
01383              Unchanged on exit.   
01384     B      - REAL             array of DIMENSION ( LDB, kb ), where kb is   
01385              n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.   
01386              Before entry with  TRANSB = 'N' or 'n',  the leading  k by n   
01387              part of the array  B  must contain the matrix  B,  otherwise   
01388              the leading  n by k  part of the array  B  must contain  the   
01389              matrix B.   
01390              Unchanged on exit.   
01391     LDB    - INTEGER.   
01392              On entry, LDB specifies the first dimension of B as declared   
01393              in the calling (sub) program. When  TRANSB = 'N' or 'n' then   
01394              LDB must be at least  f2cmax( 1, k ), otherwise  LDB must be at   
01395              least  f2cmax( 1, n ).   
01396              Unchanged on exit.   
01397     BETA   - REAL            .   
01398              On entry,  BETA  specifies the scalar  beta.  When  BETA  is   
01399              supplied as zero then C need not be set on input.   
01400              Unchanged on exit.   
01401     C      - REAL             array of DIMENSION ( LDC, n ).   
01402              Before entry, the leading  m by n  part of the array  C must   
01403              contain the matrix  C,  except when  beta  is zero, in which   
01404              case C need not be set on entry.   
01405              On exit, the array  C  is overwritten by the  m by n  matrix   
01406              ( alpha*op( A )*op( B ) + beta*C ).   
01407     LDC    - INTEGER.   
01408              On entry, LDC specifies the first dimension of C as declared   
01409              in  the  calling  (sub)  program.   LDC  must  be  at  least   
01410              f2cmax( 1, m ).   
01411              Unchanged on exit.   
01412     Level 3 Blas routine.   
01413     -- Written on 8-February-1989.   
01414        Jack Dongarra, Argonne National Laboratory.   
01415        Iain Duff, AERE Harwell.   
01416        Jeremy Du Croz, Numerical Algorithms Group Ltd.   
01417        Sven Hammarling, Numerical Algorithms Group Ltd.   
01418        Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not   
01419        transposed and set  NROWA, NCOLA and  NROWB  as the number of rows   
01420        and  columns of  A  and the  number of  rows  of  B  respectively.   
01421        Parameter adjustments */
01422     a_dim1 = *lda;
01423     a_offset = 1 + a_dim1 * 1;
01424     a -= a_offset;
01425     b_dim1 = *ldb;
01426     b_offset = 1 + b_dim1 * 1;
01427     b -= b_offset;
01428     c_dim1 = *ldc;
01429     c_offset = 1 + c_dim1 * 1;
01430     c__ -= c_offset;
01431     /* Function Body */
01432     nota = lsame_(transa, "N");
01433     notb = lsame_(transb, "N");
01434     if (nota) {
01435         nrowa = *m;
01436         ncola = *k;
01437     } else {
01438         nrowa = *k;
01439         ncola = *m;
01440     }
01441     if (notb) {
01442         nrowb = *k;
01443     } else {
01444         nrowb = *n;
01445     }
01446 /*     Test the input parameters. */
01447     info = 0;
01448     if (! nota && ! lsame_(transa, "C") && ! lsame_(
01449             transa, "T")) {
01450         info = 1;
01451     } else if (! notb && ! lsame_(transb, "C") && ! 
01452             lsame_(transb, "T")) {
01453         info = 2;
01454     } else if (*m < 0) {
01455         info = 3;
01456     } else if (*n < 0) {
01457         info = 4;
01458     } else if (*k < 0) {
01459         info = 5;
01460     } else if (*lda < f2cmax(1,nrowa)) {
01461         info = 8;
01462     } else if (*ldb < f2cmax(1,nrowb)) {
01463         info = 10;
01464     } else if (*ldc < f2cmax(1,*m)) {
01465         info = 13;
01466     }
01467     if (info != 0) {
01468         xerbla_("SGEMM ", &info);
01469         return 0;
01470     }
01471 /*     Quick return if possible. */
01472     if (*m == 0 || *n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
01473         return 0;
01474     }
01475 /*     And if  alpha.eq.zero. */
01476     if (*alpha == 0.f) {
01477         if (*beta == 0.f) {
01478             i__1 = *n;
01479             for (j = 1; j <= i__1; ++j) {
01480                 i__2 = *m;
01481                 for (i__ = 1; i__ <= i__2; ++i__) {
01482                     c___ref(i__, j) = 0.f;
01483 /* L10: */
01484                 }
01485 /* L20: */
01486             }
01487         } else {
01488             i__1 = *n;
01489             for (j = 1; j <= i__1; ++j) {
01490                 i__2 = *m;
01491                 for (i__ = 1; i__ <= i__2; ++i__) {
01492                     c___ref(i__, j) = *beta * c___ref(i__, j);
01493 /* L30: */
01494                 }
01495 /* L40: */
01496             }
01497         }
01498         return 0;
01499     }
01500 /*     Start the operations. */
01501     if (notb) {
01502         if (nota) {
01503 /*           Form  C := alpha*A*B + beta*C. */
01504             i__1 = *n;
01505             for (j = 1; j <= i__1; ++j) {
01506                 if (*beta == 0.f) {
01507                     i__2 = *m;
01508                     for (i__ = 1; i__ <= i__2; ++i__) {
01509                         c___ref(i__, j) = 0.f;
01510 /* L50: */
01511                     }
01512                 } else if (*beta != 1.f) {
01513                     i__2 = *m;
01514                     for (i__ = 1; i__ <= i__2; ++i__) {
01515                         c___ref(i__, j) = *beta * c___ref(i__, j);
01516 /* L60: */
01517                     }
01518                 }
01519                 i__2 = *k;
01520                 for (l = 1; l <= i__2; ++l) {
01521                     if (b_ref(l, j) != 0.f) {
01522                         temp = *alpha * b_ref(l, j);
01523                         i__3 = *m;
01524                         for (i__ = 1; i__ <= i__3; ++i__) {
01525                             c___ref(i__, j) = c___ref(i__, j) + temp * a_ref(
01526                                     i__, l);
01527 /* L70: */
01528                         }
01529                     }
01530 /* L80: */
01531                 }
01532 /* L90: */
01533             }
01534         } else {
01535 /*           Form  C := alpha*A'*B + beta*C */
01536             i__1 = *n;
01537             for (j = 1; j <= i__1; ++j) {
01538                 i__2 = *m;
01539                 for (i__ = 1; i__ <= i__2; ++i__) {
01540                     temp = 0.f;
01541                     i__3 = *k;
01542                     for (l = 1; l <= i__3; ++l) {
01543                         temp += a_ref(l, i__) * b_ref(l, j);
01544 /* L100: */
01545                     }
01546                     if (*beta == 0.f) {
01547                         c___ref(i__, j) = *alpha * temp;
01548                     } else {
01549                         c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__,
01550                                  j);
01551                     }
01552 /* L110: */
01553                 }
01554 /* L120: */
01555             }
01556         }
01557     } else {
01558         if (nota) {
01559 /*           Form  C := alpha*A*B' + beta*C */
01560             i__1 = *n;
01561             for (j = 1; j <= i__1; ++j) {
01562                 if (*beta == 0.f) {
01563                     i__2 = *m;
01564                     for (i__ = 1; i__ <= i__2; ++i__) {
01565                         c___ref(i__, j) = 0.f;
01566 /* L130: */
01567                     }
01568                 } else if (*beta != 1.f) {
01569                     i__2 = *m;
01570                     for (i__ = 1; i__ <= i__2; ++i__) {
01571                         c___ref(i__, j) = *beta * c___ref(i__, j);
01572 /* L140: */
01573                     }
01574                 }
01575                 i__2 = *k;
01576                 for (l = 1; l <= i__2; ++l) {
01577                     if (b_ref(j, l) != 0.f) {
01578                         temp = *alpha * b_ref(j, l);
01579                         i__3 = *m;
01580                         for (i__ = 1; i__ <= i__3; ++i__) {
01581                             c___ref(i__, j) = c___ref(i__, j) + temp * a_ref(
01582                                     i__, l);
01583 /* L150: */
01584                         }
01585                     }
01586 /* L160: */
01587                 }
01588 /* L170: */
01589             }
01590         } else {
01591 /*           Form  C := alpha*A'*B' + beta*C */
01592             i__1 = *n;
01593             for (j = 1; j <= i__1; ++j) {
01594                 i__2 = *m;
01595                 for (i__ = 1; i__ <= i__2; ++i__) {
01596                     temp = 0.f;
01597                     i__3 = *k;
01598                     for (l = 1; l <= i__3; ++l) {
01599                         temp += a_ref(l, i__) * b_ref(j, l);
01600 /* L180: */
01601                     }
01602                     if (*beta == 0.f) {
01603                         c___ref(i__, j) = *alpha * temp;
01604                     } else {
01605                         c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__,
01606                                  j);
01607                     }
01608 /* L190: */
01609                 }
01610 /* L200: */
01611             }
01612         }
01613     }
01614     return 0;
01615 /*     End of SGEMM . */
01616 } /* sgemm_ */
01617 #undef c___ref
01618 #undef b_ref
01619 #undef a_ref
01620 
01621 
01622 
01623 
01624 /* Subroutine */ int sgemv_(const char *trans, integer *m, integer *n, real *alpha, 
01625         real *a, integer *lda, real *x, integer *incx, real *beta, real *y, 
01626         integer *incy)
01627 {
01628     /* System generated locals */
01629     integer a_dim1, a_offset, i__1, i__2;
01630     /* Local variables */
01631     static integer info;
01632     static real temp;
01633     static integer lenx, leny, i__, j;
01634     extern logical lsame_(const char *, const char *);
01635     static integer ix, iy, jx, jy, kx, ky;
01636     extern /* Subroutine */ int xerbla_(const char *, integer *);
01637 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
01638 /*  Purpose   
01639     =======   
01640     SGEMV  performs one of the matrix-vector operations   
01641        y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,   
01642     where alpha and beta are scalars, x and y are vectors and A is an   
01643     m by n matrix.   
01644     Parameters   
01645     ==========   
01646     TRANS  - CHARACTER*1.   
01647              On entry, TRANS specifies the operation to be performed as   
01648              follows:   
01649                 TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.   
01650                 TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.   
01651                 TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y.   
01652              Unchanged on exit.   
01653     M      - INTEGER.   
01654              On entry, M specifies the number of rows of the matrix A.   
01655              M must be at least zero.   
01656              Unchanged on exit.   
01657     N      - INTEGER.   
01658              On entry, N specifies the number of columns of the matrix A.   
01659              N must be at least zero.   
01660              Unchanged on exit.   
01661     ALPHA  - REAL            .   
01662              On entry, ALPHA specifies the scalar alpha.   
01663              Unchanged on exit.   
01664     A      - REAL             array of DIMENSION ( LDA, n ).   
01665              Before entry, the leading m by n part of the array A must   
01666              contain the matrix of coefficients.   
01667              Unchanged on exit.   
01668     LDA    - INTEGER.   
01669              On entry, LDA specifies the first dimension of A as declared   
01670              in the calling (sub) program. LDA must be at least   
01671              f2cmax( 1, m ).   
01672              Unchanged on exit.   
01673     X      - REAL             array of DIMENSION at least   
01674              ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'   
01675              and at least   
01676              ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.   
01677              Before entry, the incremented array X must contain the   
01678              vector x.   
01679              Unchanged on exit.   
01680     INCX   - INTEGER.   
01681              On entry, INCX specifies the increment for the elements of   
01682              X. INCX must not be zero.   
01683              Unchanged on exit.   
01684     BETA   - REAL            .   
01685              On entry, BETA specifies the scalar beta. When BETA is   
01686              supplied as zero then Y need not be set on input.   
01687              Unchanged on exit.   
01688     Y      - REAL             array of DIMENSION at least   
01689              ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'   
01690              and at least   
01691              ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.   
01692              Before entry with BETA non-zero, the incremented array Y   
01693              must contain the vector y. On exit, Y is overwritten by the   
01694              updated vector y.   
01695     INCY   - INTEGER.   
01696              On entry, INCY specifies the increment for the elements of   
01697              Y. INCY must not be zero.   
01698              Unchanged on exit.   
01699     Level 2 Blas routine.   
01700     -- Written on 22-October-1986.   
01701        Jack Dongarra, Argonne National Lab.   
01702        Jeremy Du Croz, Nag Central Office.   
01703        Sven Hammarling, Nag Central Office.   
01704        Richard Hanson, Sandia National Labs.   
01705        Test the input parameters.   
01706        Parameter adjustments */
01707     a_dim1 = *lda;
01708     a_offset = 1 + a_dim1 * 1;
01709     a -= a_offset;
01710     --x;
01711     --y;
01712     /* Function Body */
01713     info = 0;
01714     if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
01715             ) {
01716         info = 1;
01717     } else if (*m < 0) {
01718         info = 2;
01719     } else if (*n < 0) {
01720         info = 3;
01721     } else if (*lda < f2cmax(1,*m)) {
01722         info = 6;
01723     } else if (*incx == 0) {
01724         info = 8;
01725     } else if (*incy == 0) {
01726         info = 11;
01727     }
01728     if (info != 0) {
01729         xerbla_("SGEMV ", &info);
01730         return 0;
01731     }
01732 /*     Quick return if possible. */
01733     if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
01734         return 0;
01735     }
01736 /*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set   
01737        up the start points in  X  and  Y. */
01738     if (lsame_(trans, "N")) {
01739         lenx = *n;
01740         leny = *m;
01741     } else {
01742         lenx = *m;
01743         leny = *n;
01744     }
01745     if (*incx > 0) {
01746         kx = 1;
01747     } else {
01748         kx = 1 - (lenx - 1) * *incx;
01749     }
01750     if (*incy > 0) {
01751         ky = 1;
01752     } else {
01753         ky = 1 - (leny - 1) * *incy;
01754     }
01755 /*     Start the operations. In this version the elements of A are   
01756        accessed sequentially with one pass through A.   
01757        First form  y := beta*y. */
01758     if (*beta != 1.f) {
01759         if (*incy == 1) {
01760             if (*beta == 0.f) {
01761                 i__1 = leny;
01762                 for (i__ = 1; i__ <= i__1; ++i__) {
01763                     y[i__] = 0.f;
01764 /* L10: */
01765                 }
01766             } else {
01767                 i__1 = leny;
01768                 for (i__ = 1; i__ <= i__1; ++i__) {
01769                     y[i__] = *beta * y[i__];
01770 /* L20: */
01771                 }
01772             }
01773         } else {
01774             iy = ky;
01775             if (*beta == 0.f) {
01776                 i__1 = leny;
01777                 for (i__ = 1; i__ <= i__1; ++i__) {
01778                     y[iy] = 0.f;
01779                     iy += *incy;
01780 /* L30: */
01781                 }
01782             } else {
01783                 i__1 = leny;
01784                 for (i__ = 1; i__ <= i__1; ++i__) {
01785                     y[iy] = *beta * y[iy];
01786                     iy += *incy;
01787 /* L40: */
01788                 }
01789             }
01790         }
01791     }
01792     if (*alpha == 0.f) {
01793         return 0;
01794     }
01795     if (lsame_(trans, "N")) {
01796 /*        Form  y := alpha*A*x + y. */
01797         jx = kx;
01798         if (*incy == 1) {
01799             i__1 = *n;
01800             for (j = 1; j <= i__1; ++j) {
01801                 if (x[jx] != 0.f) {
01802                     temp = *alpha * x[jx];
01803                     i__2 = *m;
01804                     for (i__ = 1; i__ <= i__2; ++i__) {
01805                         y[i__] += temp * a_ref(i__, j);
01806 /* L50: */
01807                     }
01808                 }
01809                 jx += *incx;
01810 /* L60: */
01811             }
01812         } else {
01813             i__1 = *n;
01814             for (j = 1; j <= i__1; ++j) {
01815                 if (x[jx] != 0.f) {
01816                     temp = *alpha * x[jx];
01817                     iy = ky;
01818                     i__2 = *m;
01819                     for (i__ = 1; i__ <= i__2; ++i__) {
01820                         y[iy] += temp * a_ref(i__, j);
01821                         iy += *incy;
01822 /* L70: */
01823                     }
01824                 }
01825                 jx += *incx;
01826 /* L80: */
01827             }
01828         }
01829     } else {
01830 /*        Form  y := alpha*A'*x + y. */
01831         jy = ky;
01832         if (*incx == 1) {
01833             i__1 = *n;
01834             for (j = 1; j <= i__1; ++j) {
01835                 temp = 0.f;
01836                 i__2 = *m;
01837                 for (i__ = 1; i__ <= i__2; ++i__) {
01838                     temp += a_ref(i__, j) * x[i__];
01839 /* L90: */
01840                 }
01841                 y[jy] += *alpha * temp;
01842                 jy += *incy;
01843 /* L100: */
01844             }
01845         } else {
01846             i__1 = *n;
01847             for (j = 1; j <= i__1; ++j) {
01848                 temp = 0.f;
01849                 ix = kx;
01850                 i__2 = *m;
01851                 for (i__ = 1; i__ <= i__2; ++i__) {
01852                     temp += a_ref(i__, j) * x[ix];
01853                     ix += *incx;
01854 /* L110: */
01855                 }
01856                 y[jy] += *alpha * temp;
01857                 jy += *incy;
01858 /* L120: */
01859             }
01860         }
01861     }
01862     return 0;
01863 /*     End of SGEMV . */
01864 } /* sgemv_ */
01865 #undef a_ref
01866 
01867 
01868 
01869 
01870 /* Subroutine */ int sger_(integer *m, integer *n, real *alpha, real *x, 
01871         integer *incx, real *y, integer *incy, real *a, integer *lda)
01872 {
01873     /* System generated locals */
01874     integer a_dim1, a_offset, i__1, i__2;
01875     /* Local variables */
01876     static integer info;
01877     static real temp;
01878     static integer i__, j, ix, jy, kx;
01879     extern /* Subroutine */ int xerbla_(const char *, integer *);
01880 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
01881 /*  Purpose   
01882     =======   
01883     SGER   performs the rank 1 operation   
01884        A := alpha*x*y' + A,   
01885     where alpha is a scalar, x is an m element vector, y is an n element   
01886     vector and A is an m by n matrix.   
01887     Parameters   
01888     ==========   
01889     M      - INTEGER.   
01890              On entry, M specifies the number of rows of the matrix A.   
01891              M must be at least zero.   
01892              Unchanged on exit.   
01893     N      - INTEGER.   
01894              On entry, N specifies the number of columns of the matrix A.   
01895              N must be at least zero.   
01896              Unchanged on exit.   
01897     ALPHA  - REAL            .   
01898              On entry, ALPHA specifies the scalar alpha.   
01899              Unchanged on exit.   
01900     X      - REAL             array of dimension at least   
01901              ( 1 + ( m - 1 )*abs( INCX ) ).   
01902              Before entry, the incremented array X must contain the m   
01903              element vector x.   
01904              Unchanged on exit.   
01905     INCX   - INTEGER.   
01906              On entry, INCX specifies the increment for the elements of   
01907              X. INCX must not be zero.   
01908              Unchanged on exit.   
01909     Y      - REAL             array of dimension at least   
01910              ( 1 + ( n - 1 )*abs( INCY ) ).   
01911              Before entry, the incremented array Y must contain the n   
01912              element vector y.   
01913              Unchanged on exit.   
01914     INCY   - INTEGER.   
01915              On entry, INCY specifies the increment for the elements of   
01916              Y. INCY must not be zero.   
01917              Unchanged on exit.   
01918     A      - REAL             array of DIMENSION ( LDA, n ).   
01919              Before entry, the leading m by n part of the array A must   
01920              contain the matrix of coefficients. On exit, A is   
01921              overwritten by the updated matrix.   
01922     LDA    - INTEGER.   
01923              On entry, LDA specifies the first dimension of A as declared   
01924              in the calling (sub) program. LDA must be at least   
01925              f2cmax( 1, m ).   
01926              Unchanged on exit.   
01927     Level 2 Blas routine.   
01928     -- Written on 22-October-1986.   
01929        Jack Dongarra, Argonne National Lab.   
01930        Jeremy Du Croz, Nag Central Office.   
01931        Sven Hammarling, Nag Central Office.   
01932        Richard Hanson, Sandia National Labs.   
01933        Test the input parameters.   
01934        Parameter adjustments */
01935     --x;
01936     --y;
01937     a_dim1 = *lda;
01938     a_offset = 1 + a_dim1 * 1;
01939     a -= a_offset;
01940     /* Function Body */
01941     info = 0;
01942     if (*m < 0) {
01943         info = 1;
01944     } else if (*n < 0) {
01945         info = 2;
01946     } else if (*incx == 0) {
01947         info = 5;
01948     } else if (*incy == 0) {
01949         info = 7;
01950     } else if (*lda < f2cmax(1,*m)) {
01951         info = 9;
01952     }
01953     if (info != 0) {
01954         xerbla_("SGER  ", &info);
01955         return 0;
01956     }
01957 /*     Quick return if possible. */
01958     if (*m == 0 || *n == 0 || *alpha == 0.f) {
01959         return 0;
01960     }
01961 /*     Start the operations. In this version the elements of A are   
01962        accessed sequentially with one pass through A. */
01963     if (*incy > 0) {
01964         jy = 1;
01965     } else {
01966         jy = 1 - (*n - 1) * *incy;
01967     }
01968     if (*incx == 1) {
01969         i__1 = *n;
01970         for (j = 1; j <= i__1; ++j) {
01971             if (y[jy] != 0.f) {
01972                 temp = *alpha * y[jy];
01973                 i__2 = *m;
01974                 for (i__ = 1; i__ <= i__2; ++i__) {
01975                     a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp;
01976 /* L10: */
01977                 }
01978             }
01979             jy += *incy;
01980 /* L20: */
01981         }
01982     } else {
01983         if (*incx > 0) {
01984             kx = 1;
01985         } else {
01986             kx = 1 - (*m - 1) * *incx;
01987         }
01988         i__1 = *n;
01989         for (j = 1; j <= i__1; ++j) {
01990             if (y[jy] != 0.f) {
01991                 temp = *alpha * y[jy];
01992                 ix = kx;
01993                 i__2 = *m;
01994                 for (i__ = 1; i__ <= i__2; ++i__) {
01995                     a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp;
01996                     ix += *incx;
01997 /* L30: */
01998                 }
01999             }
02000             jy += *incy;
02001 /* L40: */
02002         }
02003     }
02004     return 0;
02005 /*     End of SGER  . */
02006 } /* sger_ */
02007 #undef a_ref
02008 
02009 
02010 
02011 
02012 /* Subroutine */ int slae2_(real *a, real *b, real *c__, real *rt1, real *rt2)
02013 {
02014 /*  -- LAPACK auxiliary routine (version 3.0) --   
02015        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
02016        Courant Institute, Argonne National Lab, and Rice University   
02017        October 31, 1992   
02018 
02019 
02020     Purpose   
02021     =======   
02022 
02023     SLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix   
02024        [  A   B  ]   
02025        [  B   C  ].   
02026     On return, RT1 is the eigenvalue of larger absolute value, and RT2   
02027     is the eigenvalue of smaller absolute value.   
02028 
02029     Arguments   
02030     =========   
02031 
02032     A       (input) REAL   
02033             The (1,1) element of the 2-by-2 matrix.   
02034 
02035     B       (input) REAL   
02036             The (1,2) and (2,1) elements of the 2-by-2 matrix.   
02037 
02038     C       (input) REAL   
02039             The (2,2) element of the 2-by-2 matrix.   
02040 
02041     RT1     (output) REAL   
02042             The eigenvalue of larger absolute value.   
02043 
02044     RT2     (output) REAL   
02045             The eigenvalue of smaller absolute value.   
02046 
02047     Further Details   
02048     ===============   
02049 
02050     RT1 is accurate to a few ulps barring over/underflow.   
02051 
02052     RT2 may be inaccurate if there is massive cancellation in the   
02053     determinant A*C-B*B; higher precision or correctly rounded or   
02054     correctly truncated arithmetic would be needed to compute RT2   
02055     accurately in all cases.   
02056 
02057     Overflow is possible only if RT1 is within a factor of 5 of overflow.   
02058     Underflow is harmless if the input data is 0 or exceeds   
02059        underflow_threshold / macheps.   
02060 
02061    =====================================================================   
02062 
02063 
02064        Compute the eigenvalues */
02065     /* System generated locals */
02066     real r__1;
02067     /* Builtin functions */
02068 //    double sqrt(doublereal);
02069     /* Local variables */
02070     static real acmn, acmx, ab, df, tb, sm, rt, adf;
02071 
02072 
02073     sm = *a + *c__;
02074     df = *a - *c__;
02075     adf = dabs(df);
02076     tb = *b + *b;
02077     ab = dabs(tb);
02078     if (dabs(*a) > dabs(*c__)) {
02079         acmx = *a;
02080         acmn = *c__;
02081     } else {
02082         acmx = *c__;
02083         acmn = *a;
02084     }
02085     if (adf > ab) {
02086 /* Computing 2nd power */
02087         r__1 = ab / adf;
02088         rt = adf * sqrt(r__1 * r__1 + 1.f);
02089     } else if (adf < ab) {
02090 /* Computing 2nd power */
02091         r__1 = adf / ab;
02092         rt = ab * sqrt(r__1 * r__1 + 1.f);
02093     } else {
02094 
02095 /*        Includes case AB=ADF=0 */
02096 
02097         rt = ab * sqrt(2.f);
02098     }
02099     if (sm < 0.f) {
02100         *rt1 = (sm - rt) * .5f;
02101 
02102 /*        Order of execution important.   
02103           To get fully accurate smaller eigenvalue,   
02104           next line needs to be executed in higher precision. */
02105 
02106         *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
02107     } else if (sm > 0.f) {
02108         *rt1 = (sm + rt) * .5f;
02109 
02110 /*        Order of execution important.   
02111           To get fully accurate smaller eigenvalue,   
02112           next line needs to be executed in higher precision. */
02113 
02114         *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
02115     } else {
02116 
02117 /*        Includes case RT1 = RT2 = 0 */
02118 
02119         *rt1 = rt * .5f;
02120         *rt2 = rt * -.5f;
02121     }
02122     return 0;
02123 
02124 /*     End of SLAE2 */
02125 
02126 } /* slae2_ */
02127 
02128 
02129 
02130 
02131 /* Subroutine */ int slaev2_(real *a, real *b, real *c__, real *rt1, real *
02132         rt2, real *cs1, real *sn1)
02133 {
02134 /*  -- LAPACK auxiliary routine (version 3.0) --   
02135        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
02136        Courant Institute, Argonne National Lab, and Rice University   
02137        October 31, 1992   
02138 
02139 
02140     Purpose   
02141     =======   
02142 
02143     SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix   
02144        [  A   B  ]   
02145        [  B   C  ].   
02146     On return, RT1 is the eigenvalue of larger absolute value, RT2 is the   
02147     eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right   
02148     eigenvector for RT1, giving the decomposition   
02149 
02150        [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]   
02151        [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].   
02152 
02153     Arguments   
02154     =========   
02155 
02156     A       (input) REAL   
02157             The (1,1) element of the 2-by-2 matrix.   
02158 
02159     B       (input) REAL   
02160             The (1,2) element and the conjugate of the (2,1) element of   
02161             the 2-by-2 matrix.   
02162 
02163     C       (input) REAL   
02164             The (2,2) element of the 2-by-2 matrix.   
02165 
02166     RT1     (output) REAL   
02167             The eigenvalue of larger absolute value.   
02168 
02169     RT2     (output) REAL   
02170             The eigenvalue of smaller absolute value.   
02171 
02172     CS1     (output) REAL   
02173     SN1     (output) REAL   
02174             The vector (CS1, SN1) is a unit right eigenvector for RT1.   
02175 
02176     Further Details   
02177     ===============   
02178 
02179     RT1 is accurate to a few ulps barring over/underflow.   
02180 
02181     RT2 may be inaccurate if there is massive cancellation in the   
02182     determinant A*C-B*B; higher precision or correctly rounded or   
02183     correctly truncated arithmetic would be needed to compute RT2   
02184     accurately in all cases.   
02185 
02186     CS1 and SN1 are accurate to a few ulps barring over/underflow.   
02187 
02188     Overflow is possible only if RT1 is within a factor of 5 of overflow.   
02189     Underflow is harmless if the input data is 0 or exceeds   
02190        underflow_threshold / macheps.   
02191 
02192    =====================================================================   
02193 
02194 
02195        Compute the eigenvalues */
02196     /* System generated locals */
02197     real r__1;
02198     /* Builtin functions */
02199 //    double sqrt(doublereal);
02200     /* Local variables */
02201     static real acmn, acmx, ab, df, cs, ct, tb, sm, tn, rt, adf, acs;
02202     static integer sgn1, sgn2;
02203 
02204 
02205     sm = *a + *c__;
02206     df = *a - *c__;
02207     adf = dabs(df);
02208     tb = *b + *b;
02209     ab = dabs(tb);
02210     if (dabs(*a) > dabs(*c__)) {
02211         acmx = *a;
02212         acmn = *c__;
02213     } else {
02214         acmx = *c__;
02215         acmn = *a;
02216     }
02217     if (adf > ab) {
02218 /* Computing 2nd power */
02219         r__1 = ab / adf;
02220         rt = adf * sqrt(r__1 * r__1 + 1.f);
02221     } else if (adf < ab) {
02222 /* Computing 2nd power */
02223         r__1 = adf / ab;
02224         rt = ab * sqrt(r__1 * r__1 + 1.f);
02225     } else {
02226 
02227 /*        Includes case AB=ADF=0 */
02228 
02229         rt = ab * sqrt(2.f);
02230     }
02231     if (sm < 0.f) {
02232         *rt1 = (sm - rt) * .5f;
02233         sgn1 = -1;
02234 
02235 /*        Order of execution important.   
02236           To get fully accurate smaller eigenvalue,   
02237           next line needs to be executed in higher precision. */
02238 
02239         *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
02240     } else if (sm > 0.f) {
02241         *rt1 = (sm + rt) * .5f;
02242         sgn1 = 1;
02243 
02244 /*        Order of execution important.   
02245           To get fully accurate smaller eigenvalue,   
02246           next line needs to be executed in higher precision. */
02247 
02248         *rt2 = acmx / *rt1 * acmn - *b / *rt1 * *b;
02249     } else {
02250 
02251 /*        Includes case RT1 = RT2 = 0 */
02252 
02253         *rt1 = rt * .5f;
02254         *rt2 = rt * -.5f;
02255         sgn1 = 1;
02256     }
02257 
02258 /*     Compute the eigenvector */
02259 
02260     if (df >= 0.f) {
02261         cs = df + rt;
02262         sgn2 = 1;
02263     } else {
02264         cs = df - rt;
02265         sgn2 = -1;
02266     }
02267     acs = dabs(cs);
02268     if (acs > ab) {
02269         ct = -tb / cs;
02270         *sn1 = 1.f / sqrt(ct * ct + 1.f);
02271         *cs1 = ct * *sn1;
02272     } else {
02273         if (ab == 0.f) {
02274             *cs1 = 1.f;
02275             *sn1 = 0.f;
02276         } else {
02277             tn = -cs / tb;
02278             *cs1 = 1.f / sqrt(tn * tn + 1.f);
02279             *sn1 = tn * *cs1;
02280         }
02281     }
02282     if (sgn1 == sgn2) {
02283         tn = *cs1;
02284         *cs1 = -(*sn1);
02285         *sn1 = tn;
02286     }
02287     return 0;
02288 
02289 /*     End of SLAEV2 */
02290 
02291 } /* slaev2_ */
02292 
02293 
02294 
02295 doublereal slamch_(const char *cmach)
02296 {
02297 /*  -- LAPACK auxiliary routine (version 3.0) --
02298        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
02299        Courant Institute, Argonne National Lab, and Rice University   
02300        October 31, 1992   
02301 
02302 
02303     Purpose   
02304     =======   
02305 
02306     SLAMCH determines single precision machine parameters.   
02307 
02308     Arguments   
02309     =========   
02310 
02311     CMACH   (input) CHARACTER*1   
02312             Specifies the value to be returned by SLAMCH:   
02313             = 'E' or 'e',   SLAMCH := eps   
02314             = 'S' or 's ,   SLAMCH := sfmin   
02315             = 'B' or 'b',   SLAMCH := base   
02316             = 'P' or 'p',   SLAMCH := eps*base   
02317             = 'N' or 'n',   SLAMCH := t   
02318             = 'R' or 'r',   SLAMCH := rnd   
02319             = 'M' or 'm',   SLAMCH := emin   
02320             = 'U' or 'u',   SLAMCH := rmin   
02321             = 'L' or 'l',   SLAMCH := emax   
02322             = 'O' or 'o',   SLAMCH := rmax   
02323 
02324             where   
02325 
02326             eps   = relative machine precision   
02327             sfmin = safe minimum, such that 1/sfmin does not overflow   
02328             base  = base of the machine   
02329             prec  = eps*base   
02330             t     = number of (base) digits in the mantissa   
02331             rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise   
02332             emin  = minimum exponent before (gradual) underflow   
02333             rmin  = underflow threshold - base**(emin-1)   
02334             emax  = largest exponent before overflow   
02335             rmax  = overflow threshold  - (base**emax)*(1-eps)   
02336 
02337    ===================================================================== 
02338 */
02339 /* >>Start of File<<   
02340        Initialized data */
02341     static logical first = TRUE_;
02342     /* System generated locals */
02343     integer i__1;
02344     real ret_val;
02345     /* Builtin functions */
02346     double pow_ri(real *, integer *);
02347     /* Local variables */
02348     static real base;
02349     static integer beta;
02350     static real emin, prec, emax;
02351     static integer imin, imax;
02352     static logical lrnd;
02353     static real rmin, rmax, t, rmach;
02354     extern logical lsame_(const char *, const char *);
02355     static real small, sfmin;
02356     extern /* Subroutine */ int slamc2_(integer *, integer *, logical *, real 
02357             *, integer *, real *, integer *, real *);
02358     static integer it;
02359     static real rnd, eps;
02360 
02361 
02362 
02363     if (first) {
02364         first = FALSE_;
02365         slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
02366         base = (real) beta;
02367         t = (real) it;
02368         if (lrnd) {
02369             rnd = 1.f;
02370             i__1 = 1 - it;
02371             eps = pow_ri(&base, &i__1) / 2;
02372         } else {
02373             rnd = 0.f;
02374             i__1 = 1 - it;
02375             eps = pow_ri(&base, &i__1);
02376         }
02377         prec = eps * base;
02378         emin = (real) imin;
02379         emax = (real) imax;
02380         sfmin = rmin;
02381         small = 1.f / rmax;
02382         if (small >= sfmin) {
02383 
02384 /*           Use SMALL plus a bit, to avoid the possibility of rou
02385 nding   
02386              causing overflow when computing  1/sfmin. */
02387 
02388             sfmin = small * (eps + 1.f);
02389         }
02390     }
02391 
02392     if (lsame_(cmach, "E")) {
02393         rmach = eps;
02394     } else if (lsame_(cmach, "S")) {
02395         rmach = sfmin;
02396     } else if (lsame_(cmach, "B")) {
02397         rmach = base;
02398     } else if (lsame_(cmach, "P")) {
02399         rmach = prec;
02400     } else if (lsame_(cmach, "N")) {
02401         rmach = t;
02402     } else if (lsame_(cmach, "R")) {
02403         rmach = rnd;
02404     } else if (lsame_(cmach, "M")) {
02405         rmach = emin;
02406     } else if (lsame_(cmach, "U")) {
02407         rmach = rmin;
02408     } else if (lsame_(cmach, "L")) {
02409         rmach = emax;
02410     } else if (lsame_(cmach, "O")) {
02411         rmach = rmax;
02412     }
02413 
02414     ret_val = rmach;
02415     return ret_val;
02416 
02417 /*     End of SLAMCH */
02418 
02419 } /* slamch_ */
02420 
02421 
02422 
02423 /* Subroutine */ int slamc1_(integer *beta, integer *t, logical *rnd, logical 
02424         *ieee1)
02425 {
02426 /*  -- LAPACK auxiliary routine (version 3.0) --
02427        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
02428        Courant Institute, Argonne National Lab, and Rice University   
02429        October 31, 1992   
02430 
02431 
02432     Purpose   
02433     =======   
02434 
02435     SLAMC1 determines the machine parameters given by BETA, T, RND, and   
02436     IEEE1.   
02437 
02438     Arguments   
02439     =========   
02440 
02441     BETA    (output) INTEGER   
02442             The base of the machine.   
02443 
02444     T       (output) INTEGER   
02445             The number of ( BETA ) digits in the mantissa.   
02446 
02447     RND     (output) LOGICAL   
02448             Specifies whether proper rounding  ( RND = .TRUE. )  or   
02449             chopping  ( RND = .FALSE. )  occurs in addition. This may not 
02450   
02451             be a reliable guide to the way in which the machine performs 
02452   
02453             its arithmetic.   
02454 
02455     IEEE1   (output) LOGICAL   
02456             Specifies whether rounding appears to be done in the IEEE   
02457             'round to nearest' style.   
02458 
02459     Further Details   
02460     ===============   
02461 
02462     The routine is based on the routine  ENVRON  by Malcolm and   
02463     incorporates suggestions by Gentleman and Marovich. See   
02464 
02465        Malcolm M. A. (1972) Algorithms to reveal properties of   
02466           floating-point arithmetic. Comms. of the ACM, 15, 949-951.   
02467 
02468        Gentleman W. M. and Marovich S. B. (1974) More on algorithms   
02469           that reveal properties of floating point arithmetic units.   
02470           Comms. of the ACM, 17, 276-277.   
02471 
02472    ===================================================================== 
02473 */
02474     /* Initialized data */
02475     static logical first = TRUE_;
02476     /* System generated locals */
02477     real r__1, r__2;
02478     /* Local variables */
02479     static logical lrnd;
02480     static real a, b, c, f;
02481     static integer lbeta;
02482     static real savec;
02483     static logical lieee1;
02484     static real t1, t2;
02485     extern doublereal slamc3_(real *, real *);
02486     static integer lt;
02487     static real one, qtr;
02488 
02489 
02490 
02491     if (first) {
02492         first = FALSE_;
02493         one = 1.f;
02494 
02495 /*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BE
02496 TA,   
02497           IEEE1, T and RND.   
02498 
02499           Throughout this routine  we use the function  SLAMC3  to ens
02500 ure   
02501           that relevant values are  stored and not held in registers, 
02502  or   
02503           are not affected by optimizers.   
02504 
02505           Compute  a = 2.0**m  with the  smallest positive integer m s
02506 uch   
02507           that   
02508 
02509              fl( a + 1.0 ) = a. */
02510 
02511         a = 1.f;
02512         c = 1.f;
02513 
02514 /* +       WHILE( C.EQ.ONE )LOOP */
02515 L10:
02516         if (c == one) {
02517             a *= 2;
02518             c = slamc3_(&a, &one);
02519             r__1 = -(doublereal)a;
02520             c = slamc3_(&c, &r__1);
02521             goto L10;
02522         }
02523 /* +       END WHILE   
02524 
02525           Now compute  b = 2.0**m  with the smallest positive integer 
02526 m   
02527           such that   
02528 
02529              fl( a + b ) .gt. a. */
02530 
02531         b = 1.f;
02532         c = slamc3_(&a, &b);
02533 
02537         printf("\n");   
02538         
02539 /* +       WHILE( C.EQ.A )LOOP */
02540 L20:
02541         if (c == a) {
02542             b *= 2;
02543             c = slamc3_(&a, &b);
02544             goto L20;
02545         }
02546 /* +       END WHILE   
02547 
02548           Now compute the base.  a and c  are neighbouring floating po
02549 int   
02550           numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and
02551  so   
02552           their difference is beta. Adding 0.25 to c is to ensure that
02553  it   
02554           is truncated to beta and not ( beta - 1 ). */
02555 
02556         qtr = one / 4;
02557         savec = c;
02558         r__1 = -(doublereal)a;
02559         c = slamc3_(&c, &r__1);
02560         lbeta = static_cast<integer>(c + qtr);
02561 
02562 /*        Now determine whether rounding or chopping occurs,  by addin
02563 g a   
02564           bit  less  than  beta/2  and a  bit  more  than  beta/2  to 
02565  a. */
02566 
02567         b = (real) lbeta;
02568         r__1 = b / 2;
02569         r__2 = -(doublereal)b / 100;
02570         f = slamc3_(&r__1, &r__2);
02571         c = slamc3_(&f, &a);
02572         if (c == a) {
02573             lrnd = TRUE_;
02574         } else {
02575             lrnd = FALSE_;
02576         }
02577         r__1 = b / 2;
02578         r__2 = b / 100;
02579         f = slamc3_(&r__1, &r__2);
02580         c = slamc3_(&f, &a);
02581         if (lrnd && c == a) {
02582             lrnd = FALSE_;
02583         }
02584 
02585 /*        Try and decide whether rounding is done in the  IEEE  'round
02586  to   
02587           nearest' style. B/2 is half a unit in the last place of the 
02588 two   
02589           numbers A and SAVEC. Furthermore, A is even, i.e. has last  
02590 bit   
02591           zero, and SAVEC is odd. Thus adding B/2 to A should not  cha
02592 nge   
02593           A, but adding B/2 to SAVEC should change SAVEC. */
02594 
02595         r__1 = b / 2;
02596         t1 = slamc3_(&r__1, &a);
02597         r__1 = b / 2;
02598         t2 = slamc3_(&r__1, &savec);
02599         lieee1 = t1 == a && t2 > savec && lrnd;
02600 
02601 /*        Now find  the  mantissa, t.  It should  be the  integer part
02602  of   
02603           log to the base beta of a,  however it is safer to determine
02604   t   
02605           by powering.  So we find t as the smallest positive integer 
02606 for   
02607           which   
02608 
02609              fl( beta**t + 1.0 ) = 1.0. */
02610 
02611         lt = 0;
02612         a = 1.f;
02613         c = 1.f;
02614 
02615 /* +       WHILE( C.EQ.ONE )LOOP */
02616 L30:
02617         if (c == one) {
02618             ++lt;
02619             a *= lbeta;
02620             c = slamc3_(&a, &one);
02621             r__1 = -(doublereal)a;
02622             c = slamc3_(&c, &r__1);
02623             goto L30;
02624         }
02625 /* +       END WHILE */
02626 
02627     }
02628 
02629     *beta = lbeta;
02630     *t = lt;
02631     *rnd = lrnd;
02632     *ieee1 = lieee1;
02633     return 0;
02634 
02635 /*     End of SLAMC1 */
02636 
02637 } /* slamc1_ */
02638 
02639 
02640 
02641 /* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *
02642         eps, integer *emin, real *rmin, integer *emax, real *rmax)
02643 {
02644 /*  -- LAPACK auxiliary routine (version 3.0) --
02645        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
02646        Courant Institute, Argonne National Lab, and Rice University   
02647        October 31, 1992   
02648 
02649 
02650     Purpose   
02651     =======   
02652 
02653     SLAMC2 determines the machine parameters specified in its argument   
02654     list.   
02655 
02656     Arguments   
02657     =========   
02658 
02659     BETA    (output) INTEGER   
02660             The base of the machine.   
02661 
02662     T       (output) INTEGER   
02663             The number of ( BETA ) digits in the mantissa.   
02664 
02665     RND     (output) LOGICAL   
02666             Specifies whether proper rounding  ( RND = .TRUE. )  or   
02667             chopping  ( RND = .FALSE. )  occurs in addition. This may not 
02668   
02669             be a reliable guide to the way in which the machine performs 
02670   
02671             its arithmetic.   
02672 
02673     EPS     (output) REAL   
02674             The smallest positive number such that   
02675 
02676                fl( 1.0 - EPS ) .LT. 1.0,   
02677 
02678             where fl denotes the computed value.   
02679 
02680     EMIN    (output) INTEGER   
02681             The minimum exponent before (gradual) underflow occurs.   
02682 
02683     RMIN    (output) REAL   
02684             The smallest normalized number for the machine, given by   
02685             BASE**( EMIN - 1 ), where  BASE  is the floating point value 
02686   
02687             of BETA.   
02688 
02689     EMAX    (output) INTEGER   
02690             The maximum exponent before overflow occurs.   
02691 
02692     RMAX    (output) REAL   
02693             The largest positive number for the machine, given by   
02694             BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point 
02695   
02696             value of BETA.   
02697 
02698     Further Details   
02699     ===============   
02700 
02701     The computation of  EPS  is based on a routine PARANOIA by   
02702     W. Kahan of the University of California at Berkeley.   
02703 
02704    ===================================================================== 
02705 */
02706     /* Table of constant values */
02707 //    static integer c__1 = 1;  //not used in this function
02708     
02709     /* Initialized data */
02710     static logical first = TRUE_;
02711     static logical iwarn = FALSE_;
02712     /* System generated locals */
02713     integer i__1;
02714     real r__1, r__2, r__3, r__4, r__5;
02715     /* Builtin functions */
02716     double pow_ri(real *, integer *);
02717     /* Local variables */
02718     static logical ieee;
02719     static real half;
02720     static logical lrnd;
02721     static real leps, zero, a, b, c;
02722     static integer i, lbeta;
02723     static real rbase;
02724     static integer lemin, lemax, gnmin;
02725     static real small;
02726     static integer gpmin;
02727     static real third, lrmin, lrmax, sixth;
02728     static logical lieee1;
02729     extern /* Subroutine */ int slamc1_(integer *, integer *, logical *, 
02730             logical *);
02731     extern doublereal slamc3_(real *, real *);
02732     extern /* Subroutine */ int slamc4_(integer *, real *, integer *), 
02733             slamc5_(integer *, integer *, integer *, logical *, integer *, 
02734             real *);
02735     static integer lt, ngnmin, ngpmin;
02736     static real one, two;
02737 
02738 
02739 
02740     if (first) {
02741         first = FALSE_;
02742         zero = 0.f;
02743         one = 1.f;
02744         two = 2.f;
02745 
02746 /*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values
02747  of   
02748           BETA, T, RND, EPS, EMIN and RMIN.   
02749 
02750           Throughout this routine  we use the function  SLAMC3  to ens
02751 ure   
02752           that relevant values are stored  and not held in registers, 
02753  or   
02754           are not affected by optimizers.   
02755 
02756           SLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1. 
02757 */
02758 
02759         slamc1_(&lbeta, &lt, &lrnd, &lieee1);
02760 
02761 /*        Start to find EPS. */
02762 
02763         b = (real) lbeta;
02764         i__1 = -lt;
02765         a = pow_ri(&b, &i__1);
02766         leps = a;
02767 
02768 /*        Try some tricks to see whether or not this is the correct  E
02769 PS. */
02770 
02771         b = two / 3;
02772         half = one / 2;
02773         r__1 = -(doublereal)half;
02774         sixth = slamc3_(&b, &r__1);
02775         third = slamc3_(&sixth, &sixth);
02776         r__1 = -(doublereal)half;
02777         b = slamc3_(&third, &r__1);
02778         b = slamc3_(&b, &sixth);
02779         b = dabs(b);
02780         if (b < leps) {
02781             b = leps;
02782         }
02783 
02784         leps = 1.f;
02785 
02786 /* +       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
02787 L10:
02788         if (leps > b && b > zero) {
02789             leps = b;
02790             r__1 = half * leps;
02791 /* Computing 5th power */
02792             r__3 = two, r__4 = r__3, r__3 *= r__3;
02793 /* Computing 2nd power */
02794             r__5 = leps;
02795             r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
02796             c = slamc3_(&r__1, &r__2);
02797             r__1 = -(doublereal)c;
02798             c = slamc3_(&half, &r__1);
02799             b = slamc3_(&half, &c);
02800             r__1 = -(doublereal)b;
02801             c = slamc3_(&half, &r__1);
02802             b = slamc3_(&half, &c);
02803             goto L10;
02804         }
02805 /* +       END WHILE */
02806 
02807         if (a < leps) {
02808             leps = a;
02809         }
02810 
02811 /*        Computation of EPS complete.   
02812 
02813           Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3
02814 )).   
02815           Keep dividing  A by BETA until (gradual) underflow occurs. T
02816 his   
02817           is detected when we cannot recover the previous A. */
02818 
02819         rbase = one / lbeta;
02820         small = one;
02821         for (i = 1; i <= 3; ++i) {
02822             r__1 = small * rbase;
02823             small = slamc3_(&r__1, &zero);
02824 /* L20: */
02825         }
02826         a = slamc3_(&one, &small);
02827         slamc4_(&ngpmin, &one, &lbeta);
02828         r__1 = -(doublereal)one;
02829         slamc4_(&ngnmin, &r__1, &lbeta);
02830         slamc4_(&gpmin, &a, &lbeta);
02831         r__1 = -(doublereal)a;
02832         slamc4_(&gnmin, &r__1, &lbeta);
02833         ieee = FALSE_;
02834 
02835         if (ngpmin == ngnmin && gpmin == gnmin) {
02836             if (ngpmin == gpmin) {
02837                 lemin = ngpmin;
02838 /*            ( Non twos-complement machines, no gradual under
02839 flow;   
02840                 e.g.,  VAX ) */
02841             } else if (gpmin - ngpmin == 3) {
02842                 lemin = ngpmin - 1 + lt;
02843                 ieee = TRUE_;
02844 /*            ( Non twos-complement machines, with gradual und
02845 erflow;   
02846                 e.g., IEEE standard followers ) */
02847             } else {
02848                 lemin = f2cmin(ngpmin,gpmin);
02849 /*            ( A guess; no known machine ) */
02850                 iwarn = TRUE_;
02851             }
02852 
02853         } else if (ngpmin == gpmin && ngnmin == gnmin) {
02854             if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
02855                 lemin = f2cmax(ngpmin,ngnmin);
02856 /*            ( Twos-complement machines, no gradual underflow
02857 ;   
02858                 e.g., CYBER 205 ) */
02859             } else {
02860                 lemin = f2cmin(ngpmin,ngnmin);
02861 /*            ( A guess; no known machine ) */
02862                 iwarn = TRUE_;
02863             }
02864 
02865         } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
02866                  {
02867             if (gpmin - f2cmin(ngpmin,ngnmin) == 3) {
02868                 lemin = f2cmax(ngpmin,ngnmin) - 1 + lt;
02869 /*            ( Twos-complement machines with gradual underflo
02870 w;   
02871                 no known machine ) */
02872             } else {
02873                 lemin = f2cmin(ngpmin,ngnmin);
02874 /*            ( A guess; no known machine ) */
02875                 iwarn = TRUE_;
02876             }
02877 
02878         } else {
02879 /* Computing MIN */
02880             i__1 = f2cmin(ngpmin,ngnmin), i__1 = f2cmin(i__1,gpmin);
02881             lemin = f2cmin(i__1,gnmin);
02882 /*         ( A guess; no known machine ) */
02883             iwarn = TRUE_;
02884         }
02885 /* **   
02886    Comment out this if block if EMIN is ok */
02887         if (iwarn) {
02888             first = TRUE_;
02889             printf("\n\n WARNING. The value EMIN may be incorrect:- ");
02890             printf("EMIN = %8i\n",lemin);
02891             printf("If, after inspection, the value EMIN looks acceptable");
02892             printf("please comment out \n the IF block as marked within the"); 
02893             printf("code of routine SLAMC2, \n otherwise supply EMIN"); 
02894             printf("explicitly.\n");
02895         }
02896 /* **   
02897 
02898           Assume IEEE arithmetic if we found denormalised  numbers abo
02899 ve,   
02900           or if arithmetic seems to round in the  IEEE style,  determi
02901 ned   
02902           in routine SLAMC1. A true IEEE machine should have both  thi
02903 ngs   
02904           true; however, faulty machines may have one or the other. */
02905 
02906         ieee = ieee || lieee1;
02907 
02908 /*        Compute  RMIN by successive division by  BETA. We could comp
02909 ute   
02910           RMIN as BASE**( EMIN - 1 ),  but some machines underflow dur
02911 ing   
02912           this computation. */
02913 
02914         lrmin = 1.f;
02915         i__1 = 1 - lemin;
02916         for (i = 1; i <= 1-lemin; ++i) {
02917             r__1 = lrmin * rbase;
02918             lrmin = slamc3_(&r__1, &zero);
02919 /* L30: */
02920         }
02921 
02922 /*        Finally, call SLAMC5 to compute EMAX and RMAX. */
02923 
02924         slamc5_(&lbeta, &lt, &lemin, &ieee, &lemax, &lrmax);
02925     }
02926 
02927     *beta = lbeta;
02928     *t = lt;
02929     *rnd = lrnd;
02930     *eps = leps;
02931     *emin = lemin;
02932     *rmin = lrmin;
02933     *emax = lemax;
02934     *rmax = lrmax;
02935 
02936     return 0;
02937 
02938 
02939 /*     End of SLAMC2 */
02940 
02941 } /* slamc2_ */
02942 
02943 
02944 
02945 doublereal slamc3_(real *a, real *b)
02946 {
02947 /*  -- LAPACK auxiliary routine (version 3.0) --
02948        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
02949        Courant Institute, Argonne National Lab, and Rice University   
02950        October 31, 1992   
02951 
02952 
02953     Purpose   
02954     =======   
02955 
02956     SLAMC3  is intended to force  A  and  B  to be stored prior to doing 
02957   
02958     the addition of  A  and  B ,  for use in situations where optimizers 
02959   
02960     might hold one of these in a register.   
02961 
02962     Arguments   
02963     =========   
02964 
02965     A, B    (input) REAL   
02966             The values A and B.   
02967 
02968    ===================================================================== 
02969 */
02970 /* >>Start of File<<   
02971        System generated locals */
02972     real ret_val;
02973 
02974 
02975 
02976     ret_val = *a + *b;
02977 
02978     return ret_val;
02979 
02980 /*     End of SLAMC3 */
02981 
02982 } /* slamc3_ */
02983 
02984 
02985 
02986 /* Subroutine */ int slamc4_(integer *emin, real *start, integer *base)
02987 {
02988 /*  -- LAPACK auxiliary routine (version 3.0) --
02989        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
02990        Courant Institute, Argonne National Lab, and Rice University   
02991        October 31, 1992   
02992 
02993 
02994     Purpose   
02995     =======   
02996 
02997     SLAMC4 is a service routine for SLAMC2.   
02998 
02999     Arguments   
03000     =========   
03001 
03002     EMIN    (output) EMIN   
03003             The minimum exponent before (gradual) underflow, computed by 
03004   
03005             setting A = START and dividing by BASE until the previous A   
03006             can not be recovered.   
03007 
03008     START   (input) REAL   
03009             The starting point for determining EMIN.   
03010 
03011     BASE    (input) INTEGER   
03012             The base of the machine.   
03013 
03014    ===================================================================== 
03015 */
03016     /* System generated locals */
03017     integer i__1;
03018     real r__1;
03019     /* Local variables */
03020     static real zero, a;
03021     static integer i;
03022     static real rbase, b1, b2, c1, c2, d1, d2;
03023     extern doublereal slamc3_(real *, real *);
03024     static real one;
03025 
03026 
03027 
03028     a = *start;
03029     one = 1.f;
03030     rbase = one / *base;
03031     zero = 0.f;
03032     *emin = 1;
03033     r__1 = a * rbase;
03034     b1 = slamc3_(&r__1, &zero);
03035     c1 = a;
03036     c2 = a;
03037     d1 = a;
03038     d2 = a;
03039 /* +    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.   
03040       $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP */
03041 L10:
03042     if (c1 == a && c2 == a && d1 == a && d2 == a) {
03043         --(*emin);
03044         a = b1;
03045         r__1 = a / *base;
03046         b1 = slamc3_(&r__1, &zero);
03047         r__1 = b1 * *base;
03048         c1 = slamc3_(&r__1, &zero);
03049         d1 = zero;
03050         i__1 = *base;
03051         for (i = 1; i <= *base; ++i) {
03052             d1 += b1;
03053 /* L20: */
03054         }
03055         r__1 = a * rbase;
03056         b2 = slamc3_(&r__1, &zero);
03057         r__1 = b2 / rbase;
03058         c2 = slamc3_(&r__1, &zero);
03059         d2 = zero;
03060         i__1 = *base;
03061         for (i = 1; i <= *base; ++i) {
03062             d2 += b2;
03063 /* L30: */
03064         }
03065         goto L10;
03066     }
03067 /* +    END WHILE */
03068 
03069     return 0;
03070 
03071 /*     End of SLAMC4 */
03072 
03073 } /* slamc4_ */
03074 
03075 
03076 
03077 /* Subroutine */ int slamc5_(integer *beta, integer *p, integer *emin, 
03078         logical *ieee, integer *emax, real *rmax)
03079 {
03080 /*  -- LAPACK auxiliary routine (version 3.0) --
03081        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
03082        Courant Institute, Argonne National Lab, and Rice University   
03083        October 31, 1992   
03084 
03085 
03086     Purpose   
03087     =======   
03088 
03089     SLAMC5 attempts to compute RMAX, the largest machine floating-point   
03090     number, without overflow.  It assumes that EMAX + abs(EMIN) sum   
03091     approximately to a power of 2.  It will fail on machines where this   
03092     assumption does not hold, for example, the Cyber 205 (EMIN = -28625, 
03093   
03094     EMAX = 28718).  It will also fail if the value supplied for EMIN is   
03095     too large (i.e. too close to zero), probably with overflow.   
03096 
03097     Arguments   
03098     =========   
03099 
03100     BETA    (input) INTEGER   
03101             The base of floating-point arithmetic.   
03102 
03103     P       (input) INTEGER   
03104             The number of base BETA digits in the mantissa of a   
03105             floating-point value.   
03106 
03107     EMIN    (input) INTEGER   
03108             The minimum exponent before (gradual) underflow.   
03109 
03110     IEEE    (input) LOGICAL   
03111             A logical flag specifying whether or not the arithmetic   
03112             system is thought to comply with the IEEE standard.   
03113 
03114     EMAX    (output) INTEGER   
03115             The largest exponent before overflow   
03116 
03117     RMAX    (output) REAL   
03118             The largest machine floating-point number.   
03119 
03120    ===================================================================== 
03121   
03122 
03123 
03124        First compute LEXP and UEXP, two powers of 2 that bound   
03125        abs(EMIN). We then assume that EMAX + abs(EMIN) will sum   
03126        approximately to the bound that is closest to abs(EMIN).   
03127        (EMAX is the exponent of the required number RMAX). */
03128     /* Table of constant values */
03129     static real c_b5 = 0.f;
03130     
03131     /* System generated locals */
03132     integer i__1;
03133     real r__1;
03134     /* Local variables */
03135     static integer lexp;
03136     static real oldy;
03137     static integer uexp, i;
03138     static real y, z;
03139     static integer nbits;
03140     extern doublereal slamc3_(real *, real *);
03141     static real recbas;
03142     static integer exbits, expsum, try__;
03143 
03144 
03145 
03146     lexp = 1;
03147     exbits = 1;
03148 L10:
03149     try__ = lexp << 1;
03150     if (try__ <= -(*emin)) {
03151         lexp = try__;
03152         ++exbits;
03153         goto L10;
03154     }
03155     if (lexp == -(*emin)) {
03156         uexp = lexp;
03157     } else {
03158         uexp = try__;
03159         ++exbits;
03160     }
03161 
03162 /*     Now -LEXP is less than or equal to EMIN, and -UEXP is greater   
03163        than or equal to EMIN. EXBITS is the number of bits needed to   
03164        store the exponent. */
03165 
03166     if (uexp + *emin > -lexp - *emin) {
03167         expsum = lexp << 1;
03168     } else {
03169         expsum = uexp << 1;
03170     }
03171 
03172 /*     EXPSUM is the exponent range, approximately equal to   
03173        EMAX - EMIN + 1 . */
03174 
03175     *emax = expsum + *emin - 1;
03176     nbits = exbits + 1 + *p;
03177 
03178 /*     NBITS is the total number of bits needed to store a   
03179        floating-point number. */
03180 
03181     if (nbits % 2 == 1 && *beta == 2) {
03182 
03183 /*        Either there are an odd number of bits used to store a   
03184           floating-point number, which is unlikely, or some bits are 
03185   
03186           not used in the representation of numbers, which is possible
03187 ,   
03188           (e.g. Cray machines) or the mantissa has an implicit bit,   
03189           (e.g. IEEE machines, Dec Vax machines), which is perhaps the
03190    
03191           most likely. We have to assume the last alternative.   
03192           If this is true, then we need to reduce EMAX by one because 
03193   
03194           there must be some way of representing zero in an implicit-b
03195 it   
03196           system. On machines like Cray, we are reducing EMAX by one 
03197   
03198           unnecessarily. */
03199 
03200         --(*emax);
03201     }
03202 
03203     if (*ieee) {
03204 
03205 /*        Assume we are on an IEEE machine which reserves one exponent
03206    
03207           for infinity and NaN. */
03208 
03209         --(*emax);
03210     }
03211 
03212 /*     Now create RMAX, the largest machine number, which should   
03213        be equal to (1.0 - BETA**(-P)) * BETA**EMAX .   
03214 
03215        First compute 1.0 - BETA**(-P), being careful that the   
03216        result is less than 1.0 . */
03217 
03218     recbas = 1.f / *beta;
03219     z = *beta - 1.f;
03220     y = 0.f;
03221     i__1 = *p;
03222     for (i = 1; i <= *p; ++i) {
03223         z *= recbas;
03224         if (y < 1.f) {
03225             oldy = y;
03226         }
03227         y = slamc3_(&y, &z);
03228 /* L20: */
03229     }
03230     if (y >= 1.f) {
03231         y = oldy;
03232     }
03233 
03234 /*     Now multiply by BETA**EMAX to get RMAX. */
03235 
03236     i__1 = *emax;
03237     for (i = 1; i <= *emax; ++i) {
03238         r__1 = y * *beta;
03239         y = slamc3_(&r__1, &c_b5);
03240 /* L30: */
03241     }
03242 
03243     *rmax = y;
03244     return 0;
03245 
03246 /*     End of SLAMC5 */
03247 
03248 } /* slamc5_ */
03249 
03250 
03251 
03252 
03253 doublereal slanst_(const char *norm, integer *n, real *d__, real *e)
03254 {
03255 /*  -- LAPACK auxiliary routine (version 3.0) --   
03256        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
03257        Courant Institute, Argonne National Lab, and Rice University   
03258        February 29, 1992   
03259 
03260 
03261     Purpose   
03262     =======   
03263 
03264     SLANST  returns the value of the one norm,  or the Frobenius norm, or   
03265     the  infinity norm,  or the  element of  largest absolute value  of a   
03266     real symmetric tridiagonal matrix A.   
03267 
03268     Description   
03269     ===========   
03270 
03271     SLANST returns the value   
03272 
03273        SLANST = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm'   
03274                 (   
03275                 ( norm1(A),         NORM = '1', 'O' or 'o'   
03276                 (   
03277                 ( normI(A),         NORM = 'I' or 'i'   
03278                 (   
03279                 ( normF(A),         NORM = 'F', 'f', 'E' or 'e'   
03280 
03281     where  norm1  denotes the  one norm of a matrix (maximum column sum),   
03282     normI  denotes the  infinity norm  of a matrix  (maximum row sum) and   
03283     normF  denotes the  Frobenius norm of a matrix (square root of sum of   
03284     squares).  Note that  f2cmax(abs(A(i,j)))  is not a  matrix norm.   
03285 
03286     Arguments   
03287     =========   
03288 
03289     NORM    (input) CHARACTER*1   
03290             Specifies the value to be returned in SLANST as described   
03291             above.   
03292 
03293     N       (input) INTEGER   
03294             The order of the matrix A.  N >= 0.  When N = 0, SLANST is   
03295             set to zero.   
03296 
03297     D       (input) REAL array, dimension (N)   
03298             The diagonal elements of A.   
03299 
03300     E       (input) REAL array, dimension (N-1)   
03301             The (n-1) sub-diagonal or super-diagonal elements of A.   
03302 
03303     =====================================================================   
03304 
03305 
03306        Parameter adjustments */
03307     /* Table of constant values */
03308     static integer c__1 = 1;
03309     
03310     /* System generated locals */
03311     integer i__1;
03312     real ret_val, r__1, r__2, r__3, r__4, r__5;
03313     /* Builtin functions */
03314 //    double sqrt(doublereal);
03315     /* Local variables */
03316     static integer i__;
03317     static real scale;
03318     extern logical lsame_(const char *, const char *);
03319     static real anorm;
03320     extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, 
03321             real *);
03322     static real sum;
03323 
03324 
03325     --e;
03326     --d__;
03327 
03328     /* Function Body */
03329     if (*n <= 0) {
03330         anorm = 0.f;
03331     } else if (lsame_(norm, "M")) {
03332 
03333 /*        Find f2cmax(abs(A(i,j))). */
03334 
03335         anorm = (r__1 = d__[*n], dabs(r__1));
03336         i__1 = *n - 1;
03337         for (i__ = 1; i__ <= i__1; ++i__) {
03338 /* Computing MAX */
03339             r__2 = anorm, r__3 = (r__1 = d__[i__], dabs(r__1));
03340             anorm = df2cmax(r__2,r__3);
03341 /* Computing MAX */
03342             r__2 = anorm, r__3 = (r__1 = e[i__], dabs(r__1));
03343             anorm = df2cmax(r__2,r__3);
03344 /* L10: */
03345         }
03346     } else if (lsame_(norm, "O") || *(unsigned char *)
03347             norm == '1' || lsame_(norm, "I")) {
03348 
03349 /*        Find norm1(A). */
03350 
03351         if (*n == 1) {
03352             anorm = dabs(d__[1]);
03353         } else {
03354 /* Computing MAX */
03355             r__3 = dabs(d__[1]) + dabs(e[1]), r__4 = (r__1 = e[*n - 1], dabs(
03356                     r__1)) + (r__2 = d__[*n], dabs(r__2));
03357             anorm = df2cmax(r__3,r__4);
03358             i__1 = *n - 1;
03359             for (i__ = 2; i__ <= i__1; ++i__) {
03360 /* Computing MAX */
03361                 r__4 = anorm, r__5 = (r__1 = d__[i__], dabs(r__1)) + (r__2 = 
03362                         e[i__], dabs(r__2)) + (r__3 = e[i__ - 1], dabs(r__3));
03363                 anorm = df2cmax(r__4,r__5);
03364 /* L20: */
03365             }
03366         }
03367     } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
03368 
03369 /*        Find normF(A). */
03370 
03371         scale = 0.f;
03372         sum = 1.f;
03373         if (*n > 1) {
03374             i__1 = *n - 1;
03375             slassq_(&i__1, &e[1], &c__1, &scale, &sum);
03376             sum *= 2;
03377         }
03378         slassq_(n, &d__[1], &c__1, &scale, &sum);
03379         anorm = scale * sqrt(sum);
03380     }
03381 
03382     ret_val = anorm;
03383     return ret_val;
03384 
03385 /*     End of SLANST */
03386 
03387 } /* slanst_ */
03388 
03389 
03390 
03391 
03392 doublereal slansy_(const char *norm, char *uplo, integer *n, real *a, integer *lda, 
03393         real *work)
03394 {
03395 /*  -- LAPACK auxiliary routine (version 3.0) --   
03396        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
03397        Courant Institute, Argonne National Lab, and Rice University   
03398        October 31, 1992   
03399 
03400 
03401     Purpose   
03402     =======   
03403 
03404     SLANSY  returns the value of the one norm,  or the Frobenius norm, or   
03405     the  infinity norm,  or the  element of  largest absolute value  of a   
03406     real symmetric matrix A.   
03407 
03408     Description   
03409     ===========   
03410 
03411     SLANSY returns the value   
03412 
03413        SLANSY = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm'   
03414                 (   
03415                 ( norm1(A),         NORM = '1', 'O' or 'o'   
03416                 (   
03417                 ( normI(A),         NORM = 'I' or 'i'   
03418                 (   
03419                 ( normF(A),         NORM = 'F', 'f', 'E' or 'e'   
03420 
03421     where  norm1  denotes the  one norm of a matrix (maximum column sum),   
03422     normI  denotes the  infinity norm  of a matrix  (maximum row sum) and   
03423     normF  denotes the  Frobenius norm of a matrix (square root of sum of   
03424     squares).  Note that  f2cmax(abs(A(i,j)))  is not a  matrix norm.   
03425 
03426     Arguments   
03427     =========   
03428 
03429     NORM    (input) CHARACTER*1   
03430             Specifies the value to be returned in SLANSY as described   
03431             above.   
03432 
03433     UPLO    (input) CHARACTER*1   
03434             Specifies whether the upper or lower triangular part of the   
03435             symmetric matrix A is to be referenced.   
03436             = 'U':  Upper triangular part of A is referenced   
03437             = 'L':  Lower triangular part of A is referenced   
03438 
03439     N       (input) INTEGER   
03440             The order of the matrix A.  N >= 0.  When N = 0, SLANSY is   
03441             set to zero.   
03442 
03443     A       (input) REAL array, dimension (LDA,N)   
03444             The symmetric matrix A.  If UPLO = 'U', the leading n by n   
03445             upper triangular part of A contains the upper triangular part   
03446             of the matrix A, and the strictly lower triangular part of A   
03447             is not referenced.  If UPLO = 'L', the leading n by n lower   
03448             triangular part of A contains the lower triangular part of   
03449             the matrix A, and the strictly upper triangular part of A is   
03450             not referenced.   
03451 
03452     LDA     (input) INTEGER   
03453             The leading dimension of the array A.  LDA >= f2cmax(N,1).   
03454 
03455     WORK    (workspace) REAL array, dimension (LWORK),   
03456             where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,   
03457             WORK is not referenced.   
03458 
03459    =====================================================================   
03460 
03461 
03462        Parameter adjustments */
03463     /* Table of constant values */
03464     static integer c__1 = 1;
03465     
03466     /* System generated locals */
03467     integer a_dim1, a_offset, i__1, i__2;
03468     real ret_val, r__1, r__2, r__3;
03469     /* Builtin functions */
03470 //    double sqrt(doublereal);
03471     /* Local variables */
03472     static real absa;
03473     static integer i__, j;
03474     static real scale;
03475     extern logical lsame_(const char *, const char *);
03476     static real value;
03477     extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, 
03478             real *);
03479     static real sum;
03480 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
03481 
03482 
03483     a_dim1 = *lda;
03484     a_offset = 1 + a_dim1 * 1;
03485     a -= a_offset;
03486     --work;
03487 
03488     /* Function Body */
03489     if (*n == 0) {
03490         value = 0.f;
03491     } else if (lsame_(norm, "M")) {
03492 
03493 /*        Find f2cmax(abs(A(i,j))). */
03494 
03495         value = 0.f;
03496         if (lsame_(uplo, "U")) {
03497             i__1 = *n;
03498             for (j = 1; j <= i__1; ++j) {
03499                 i__2 = j;
03500                 for (i__ = 1; i__ <= i__2; ++i__) {
03501 /* Computing MAX */
03502                     r__2 = value, r__3 = (r__1 = a_ref(i__, j), dabs(r__1));
03503                     value = df2cmax(r__2,r__3);
03504 /* L10: */
03505                 }
03506 /* L20: */
03507             }
03508         } else {
03509             i__1 = *n;
03510             for (j = 1; j <= i__1; ++j) {
03511                 i__2 = *n;
03512                 for (i__ = j; i__ <= i__2; ++i__) {
03513 /* Computing MAX */
03514                     r__2 = value, r__3 = (r__1 = a_ref(i__, j), dabs(r__1));
03515                     value = df2cmax(r__2,r__3);
03516 /* L30: */
03517                 }
03518 /* L40: */
03519             }
03520         }
03521     } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') {
03522 
03523 /*        Find normI(A) ( = norm1(A), since A is symmetric). */
03524 
03525         value = 0.f;
03526         if (lsame_(uplo, "U")) {
03527             i__1 = *n;
03528             for (j = 1; j <= i__1; ++j) {
03529                 sum = 0.f;
03530                 i__2 = j - 1;
03531                 for (i__ = 1; i__ <= i__2; ++i__) {
03532                     absa = (r__1 = a_ref(i__, j), dabs(r__1));
03533                     sum += absa;
03534                     work[i__] += absa;
03535 /* L50: */
03536                 }
03537                 work[j] = sum + (r__1 = a_ref(j, j), dabs(r__1));
03538 /* L60: */
03539             }
03540             i__1 = *n;
03541             for (i__ = 1; i__ <= i__1; ++i__) {
03542 /* Computing MAX */
03543                 r__1 = value, r__2 = work[i__];
03544                 value = df2cmax(r__1,r__2);
03545 /* L70: */
03546             }
03547         } else {
03548             i__1 = *n;
03549             for (i__ = 1; i__ <= i__1; ++i__) {
03550                 work[i__] = 0.f;
03551 /* L80: */
03552             }
03553             i__1 = *n;
03554             for (j = 1; j <= i__1; ++j) {
03555                 sum = work[j] + (r__1 = a_ref(j, j), dabs(r__1));
03556                 i__2 = *n;
03557                 for (i__ = j + 1; i__ <= i__2; ++i__) {
03558                     absa = (r__1 = a_ref(i__, j), dabs(r__1));
03559                     sum += absa;
03560                     work[i__] += absa;
03561 /* L90: */
03562                 }
03563                 value = df2cmax(value,sum);
03564 /* L100: */
03565             }
03566         }
03567     } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
03568 
03569 /*        Find normF(A). */
03570 
03571         scale = 0.f;
03572         sum = 1.f;
03573         if (lsame_(uplo, "U")) {
03574             i__1 = *n;
03575             for (j = 2; j <= i__1; ++j) {
03576                 i__2 = j - 1;
03577                 slassq_(&i__2, &a_ref(1, j), &c__1, &scale, &sum);
03578 /* L110: */
03579             }
03580         } else {
03581             i__1 = *n - 1;
03582             for (j = 1; j <= i__1; ++j) {
03583                 i__2 = *n - j;
03584                 slassq_(&i__2, &a_ref(j + 1, j), &c__1, &scale, &sum);
03585 /* L120: */
03586             }
03587         }
03588         sum *= 2;
03589         i__1 = *lda + 1;
03590         slassq_(n, &a[a_offset], &i__1, &scale, &sum);
03591         value = scale * sqrt(sum);
03592     }
03593 
03594     ret_val = value;
03595     return ret_val;
03596 
03597 /*     End of SLANSY */
03598 
03599 } /* slansy_ */
03600 
03601 #undef a_ref
03602 
03603 
03604 
03605 
03606 
03607 doublereal slapy2_(real *x, real *y)
03608 {
03609 /*  -- LAPACK auxiliary routine (version 3.0) --   
03610        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
03611        Courant Institute, Argonne National Lab, and Rice University   
03612        October 31, 1992   
03613 
03614 
03615     Purpose   
03616     =======   
03617 
03618     SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary   
03619     overflow.   
03620 
03621     Arguments   
03622     =========   
03623 
03624     X       (input) REAL   
03625     Y       (input) REAL   
03626             X and Y specify the values x and y.   
03627 
03628     ===================================================================== */
03629     /* System generated locals */
03630     real ret_val, r__1;
03631     /* Builtin functions */
03632 //    double sqrt(doublereal);
03633     /* Local variables */
03634     static real xabs, yabs, w, z__;
03635 
03636 
03637 
03638     xabs = dabs(*x);
03639     yabs = dabs(*y);
03640     w = df2cmax(xabs,yabs);
03641     z__ = df2cmin(xabs,yabs);
03642     if (z__ == 0.f) {
03643         ret_val = w;
03644     } else {
03645 /* Computing 2nd power */
03646         r__1 = z__ / w;
03647         ret_val = w * sqrt(r__1 * r__1 + 1.f);
03648     }
03649     return ret_val;
03650 
03651 /*     End of SLAPY2 */
03652 
03653 } /* slapy2_ */
03654 
03655 
03656 
03657 
03658 /* Subroutine */ int slarfb_(const char *side, const char *trans, const char *direct, const char *
03659         storev, integer *m, integer *n, integer *k, real *v, integer *ldv, 
03660         real *t, integer *ldt, real *c__, integer *ldc, real *work, integer *
03661         ldwork)
03662 {
03663 /*  -- LAPACK auxiliary routine (version 3.0) --   
03664        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
03665        Courant Institute, Argonne National Lab, and Rice University   
03666        February 29, 1992   
03667 
03668 
03669     Purpose   
03670     =======   
03671 
03672     SLARFB applies a real block reflector H or its transpose H' to a   
03673     real m by n matrix C, from either the left or the right.   
03674 
03675     Arguments   
03676     =========   
03677 
03678     SIDE    (input) CHARACTER*1   
03679             = 'L': apply H or H' from the Left   
03680             = 'R': apply H or H' from the Right   
03681 
03682     TRANS   (input) CHARACTER*1   
03683             = 'N': apply H (No transpose)   
03684             = 'T': apply H' (Transpose)   
03685 
03686     DIRECT  (input) CHARACTER*1   
03687             Indicates how H is formed from a product of elementary   
03688             reflectors   
03689             = 'F': H = H(1) H(2) . . . H(k) (Forward)   
03690             = 'B': H = H(k) . . . H(2) H(1) (Backward)   
03691 
03692     STOREV  (input) CHARACTER*1   
03693             Indicates how the vectors which define the elementary   
03694             reflectors are stored:   
03695             = 'C': Columnwise   
03696             = 'R': Rowwise   
03697 
03698     M       (input) INTEGER   
03699             The number of rows of the matrix C.   
03700 
03701     N       (input) INTEGER   
03702             The number of columns of the matrix C.   
03703 
03704     K       (input) INTEGER   
03705             The order of the matrix T (= the number of elementary   
03706             reflectors whose product defines the block reflector).   
03707 
03708     V       (input) REAL array, dimension   
03709                                   (LDV,K) if STOREV = 'C'   
03710                                   (LDV,M) if STOREV = 'R' and SIDE = 'L'   
03711                                   (LDV,N) if STOREV = 'R' and SIDE = 'R'   
03712             The matrix V. See further details.   
03713 
03714     LDV     (input) INTEGER   
03715             The leading dimension of the array V.   
03716             If STOREV = 'C' and SIDE = 'L', LDV >= f2cmax(1,M);   
03717             if STOREV = 'C' and SIDE = 'R', LDV >= f2cmax(1,N);   
03718             if STOREV = 'R', LDV >= K.   
03719 
03720     T       (input) REAL array, dimension (LDT,K)   
03721             The triangular k by k matrix T in the representation of the   
03722             block reflector.   
03723 
03724     LDT     (input) INTEGER   
03725             The leading dimension of the array T. LDT >= K.   
03726 
03727     C       (input/output) REAL array, dimension (LDC,N)   
03728             On entry, the m by n matrix C.   
03729             On exit, C is overwritten by H*C or H'*C or C*H or C*H'.   
03730 
03731     LDC     (input) INTEGER   
03732             The leading dimension of the array C. LDA >= f2cmax(1,M).   
03733 
03734     WORK    (workspace) REAL array, dimension (LDWORK,K)   
03735 
03736     LDWORK  (input) INTEGER   
03737             The leading dimension of the array WORK.   
03738             If SIDE = 'L', LDWORK >= f2cmax(1,N);   
03739             if SIDE = 'R', LDWORK >= f2cmax(1,M).   
03740 
03741     =====================================================================   
03742 
03743 
03744        Quick return if possible   
03745 
03746        Parameter adjustments */
03747     /* Table of constant values */
03748     static integer c__1 = 1;
03749     static real c_b14 = 1.f;
03750     static real c_b25 = -1.f;
03751     
03752     /* System generated locals */
03753     integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, 
03754             work_offset, i__1, i__2;
03755     /* Local variables */
03756     static integer i__, j;
03757     extern logical lsame_(const char *, const char *);
03758     extern /* Subroutine */ int sgemm_(const char *, const char *, integer *, integer *, 
03759             integer *, real *, real *, integer *, real *, integer *, real *, 
03760             real *, integer *), scopy_(integer *, real *, 
03761             integer *, real *, integer *), strmm_(const char *, const char *, const char *, 
03762             const char *, integer *, integer *, real *, real *, integer *, real *, 
03763             integer *);
03764     static char transt[1];
03765 #define work_ref(a_1,a_2) work[(a_2)*work_dim1 + a_1]
03766 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
03767 #define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
03768 
03769 
03770     v_dim1 = *ldv;
03771     v_offset = 1 + v_dim1 * 1;
03772     v -= v_offset;
03773     t_dim1 = *ldt;
03774     t_offset = 1 + t_dim1 * 1;
03775     t -= t_offset;
03776     c_dim1 = *ldc;
03777     c_offset = 1 + c_dim1 * 1;
03778     c__ -= c_offset;
03779     work_dim1 = *ldwork;
03780     work_offset = 1 + work_dim1 * 1;
03781     work -= work_offset;
03782 
03783     /* Function Body */
03784     if (*m <= 0 || *n <= 0) {
03785         return 0;
03786     }
03787 
03788     if (lsame_(trans, "N")) {
03789         *(unsigned char *)transt = 'T';
03790     } else {
03791         *(unsigned char *)transt = 'N';
03792     }
03793 
03794     if (lsame_(storev, "C")) {
03795 
03796         if (lsame_(direct, "F")) {
03797 
03798 /*           Let  V =  ( V1 )    (first K rows)   
03799                        ( V2 )   
03800              where  V1  is unit lower triangular. */
03801 
03802             if (lsame_(side, "L")) {
03803 
03804 /*              Form  H * C  or  H' * C  where  C = ( C1 )   
03805                                                     ( C2 )   
03806 
03807                 W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)   
03808 
03809                 W := C1' */
03810 
03811                 i__1 = *k;
03812                 for (j = 1; j <= i__1; ++j) {
03813                     scopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1);
03814 /* L10: */
03815                 }
03816 
03817 /*              W := W * V1 */
03818 
03819                 strmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
03820                          &v[v_offset], ldv, &work[work_offset], ldwork);
03821                 if (*m > *k) {
03822 
03823 /*                 W := W + C2'*V2 */
03824 
03825                     i__1 = *m - *k;
03826                     sgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
03827                             c___ref(*k + 1, 1), ldc, &v_ref(*k + 1, 1), ldv, &
03828                             c_b14, &work[work_offset], ldwork);
03829                 }
03830 
03831 /*              W := W * T'  or  W * T */
03832 
03833                 strmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
03834                         t_offset], ldt, &work[work_offset], ldwork);
03835 
03836 /*              C := C - V * W' */
03837 
03838                 if (*m > *k) {
03839 
03840 /*                 C2 := C2 - V2 * W' */
03841 
03842                     i__1 = *m - *k;
03843                     sgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
03844                             v_ref(*k + 1, 1), ldv, &work[work_offset], ldwork,
03845                              &c_b14, &c___ref(*k + 1, 1), ldc);
03846                 }
03847 
03848 /*              W := W * V1' */
03849 
03850                 strmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
03851                         v[v_offset], ldv, &work[work_offset], ldwork);
03852 
03853 /*              C1 := C1 - W' */
03854 
03855                 i__1 = *k;
03856                 for (j = 1; j <= i__1; ++j) {
03857                     i__2 = *n;
03858                     for (i__ = 1; i__ <= i__2; ++i__) {
03859                         c___ref(j, i__) = c___ref(j, i__) - work_ref(i__, j);
03860 /* L20: */
03861                     }
03862 /* L30: */
03863                 }
03864 
03865             } else if (lsame_(side, "R")) {
03866 
03867 /*              Form  C * H  or  C * H'  where  C = ( C1  C2 )   
03868 
03869                 W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)   
03870 
03871                 W := C1 */
03872 
03873                 i__1 = *k;
03874                 for (j = 1; j <= i__1; ++j) {
03875                     scopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1);
03876 /* L40: */
03877                 }
03878 
03879 /*              W := W * V1 */
03880 
03881                 strmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
03882                          &v[v_offset], ldv, &work[work_offset], ldwork);
03883                 if (*n > *k) {
03884 
03885 /*                 W := W + C2 * V2 */
03886 
03887                     i__1 = *n - *k;
03888                     sgemm_("No transpose", "No transpose", m, k, &i__1, &
03889                             c_b14, &c___ref(1, *k + 1), ldc, &v_ref(*k + 1, 1)
03890                             , ldv, &c_b14, &work[work_offset], ldwork);
03891                 }
03892 
03893 /*              W := W * T  or  W * T' */
03894 
03895                 strmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
03896                         t_offset], ldt, &work[work_offset], ldwork);
03897 
03898 /*              C := C - W * V' */
03899 
03900                 if (*n > *k) {
03901 
03902 /*                 C2 := C2 - W * V2' */
03903 
03904                     i__1 = *n - *k;
03905                     sgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
03906                             work[work_offset], ldwork, &v_ref(*k + 1, 1), ldv,
03907                              &c_b14, &c___ref(1, *k + 1), ldc);
03908                 }
03909 
03910 /*              W := W * V1' */
03911 
03912                 strmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
03913                         v[v_offset], ldv, &work[work_offset], ldwork);
03914 
03915 /*              C1 := C1 - W */
03916 
03917                 i__1 = *k;
03918                 for (j = 1; j <= i__1; ++j) {
03919                     i__2 = *m;
03920                     for (i__ = 1; i__ <= i__2; ++i__) {
03921                         c___ref(i__, j) = c___ref(i__, j) - work_ref(i__, j);
03922 /* L50: */
03923                     }
03924 /* L60: */
03925                 }
03926             }
03927 
03928         } else {
03929 
03930 /*           Let  V =  ( V1 )   
03931                        ( V2 )    (last K rows)   
03932              where  V2  is unit upper triangular. */
03933 
03934             if (lsame_(side, "L")) {
03935 
03936 /*              Form  H * C  or  H' * C  where  C = ( C1 )   
03937                                                     ( C2 )   
03938 
03939                 W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)   
03940 
03941                 W := C2' */
03942 
03943                 i__1 = *k;
03944                 for (j = 1; j <= i__1; ++j) {
03945                     scopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j), 
03946                             &c__1);
03947 /* L70: */
03948                 }
03949 
03950 /*              W := W * V2 */
03951 
03952                 strmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
03953                          &v_ref(*m - *k + 1, 1), ldv, &work[work_offset], 
03954                         ldwork);
03955                 if (*m > *k) {
03956 
03957 /*                 W := W + C1'*V1 */
03958 
03959                     i__1 = *m - *k;
03960                     sgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, &
03961                             c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
03962                             work[work_offset], ldwork);
03963                 }
03964 
03965 /*              W := W * T'  or  W * T */
03966 
03967                 strmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
03968                         t_offset], ldt, &work[work_offset], ldwork);
03969 
03970 /*              C := C - V * W' */
03971 
03972                 if (*m > *k) {
03973 
03974 /*                 C1 := C1 - V1 * W' */
03975 
03976                     i__1 = *m - *k;
03977                     sgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, &
03978                             v[v_offset], ldv, &work[work_offset], ldwork, &
03979                             c_b14, &c__[c_offset], ldc)
03980                             ;
03981                 }
03982 
03983 /*              W := W * V2' */
03984 
03985                 strmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
03986                         v_ref(*m - *k + 1, 1), ldv, &work[work_offset], 
03987                         ldwork);
03988 
03989 /*              C2 := C2 - W' */
03990 
03991                 i__1 = *k;
03992                 for (j = 1; j <= i__1; ++j) {
03993                     i__2 = *n;
03994                     for (i__ = 1; i__ <= i__2; ++i__) {
03995                         c___ref(*m - *k + j, i__) = c___ref(*m - *k + j, i__) 
03996                                 - work_ref(i__, j);
03997 /* L80: */
03998                     }
03999 /* L90: */
04000                 }
04001 
04002             } else if (lsame_(side, "R")) {
04003 
04004 /*              Form  C * H  or  C * H'  where  C = ( C1  C2 )   
04005 
04006                 W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)   
04007 
04008                 W := C2 */
04009 
04010                 i__1 = *k;
04011                 for (j = 1; j <= i__1; ++j) {
04012                     scopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j)
04013                             , &c__1);
04014 /* L100: */
04015                 }
04016 
04017 /*              W := W * V2 */
04018 
04019                 strmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
04020                          &v_ref(*n - *k + 1, 1), ldv, &work[work_offset], 
04021                         ldwork);
04022                 if (*n > *k) {
04023 
04024 /*                 W := W + C1 * V1 */
04025 
04026                     i__1 = *n - *k;
04027                     sgemm_("No transpose", "No transpose", m, k, &i__1, &
04028                             c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
04029                             c_b14, &work[work_offset], ldwork);
04030                 }
04031 
04032 /*              W := W * T  or  W * T' */
04033 
04034                 strmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
04035                         t_offset], ldt, &work[work_offset], ldwork);
04036 
04037 /*              C := C - W * V' */
04038 
04039                 if (*n > *k) {
04040 
04041 /*                 C1 := C1 - W * V1' */
04042 
04043                     i__1 = *n - *k;
04044                     sgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, &
04045                             work[work_offset], ldwork, &v[v_offset], ldv, &
04046                             c_b14, &c__[c_offset], ldc)
04047                             ;
04048                 }
04049 
04050 /*              W := W * V2' */
04051 
04052                 strmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
04053                         v_ref(*n - *k + 1, 1), ldv, &work[work_offset], 
04054                         ldwork);
04055 
04056 /*              C2 := C2 - W */
04057 
04058                 i__1 = *k;
04059                 for (j = 1; j <= i__1; ++j) {
04060                     i__2 = *m;
04061                     for (i__ = 1; i__ <= i__2; ++i__) {
04062                         c___ref(i__, *n - *k + j) = c___ref(i__, *n - *k + j) 
04063                                 - work_ref(i__, j);
04064 /* L110: */
04065                     }
04066 /* L120: */
04067                 }
04068             }
04069         }
04070 
04071     } else if (lsame_(storev, "R")) {
04072 
04073         if (lsame_(direct, "F")) {
04074 
04075 /*           Let  V =  ( V1  V2 )    (V1: first K columns)   
04076              where  V1  is unit upper triangular. */
04077 
04078             if (lsame_(side, "L")) {
04079 
04080 /*              Form  H * C  or  H' * C  where  C = ( C1 )   
04081                                                     ( C2 )   
04082 
04083                 W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)   
04084 
04085                 W := C1' */
04086 
04087                 i__1 = *k;
04088                 for (j = 1; j <= i__1; ++j) {
04089                     scopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1);
04090 /* L130: */
04091                 }
04092 
04093 /*              W := W * V1' */
04094 
04095                 strmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, &
04096                         v[v_offset], ldv, &work[work_offset], ldwork);
04097                 if (*m > *k) {
04098 
04099 /*                 W := W + C2'*V2' */
04100 
04101                     i__1 = *m - *k;
04102                     sgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
04103                             c___ref(*k + 1, 1), ldc, &v_ref(1, *k + 1), ldv, &
04104                             c_b14, &work[work_offset], ldwork);
04105                 }
04106 
04107 /*              W := W * T'  or  W * T */
04108 
04109                 strmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[
04110                         t_offset], ldt, &work[work_offset], ldwork);
04111 
04112 /*              C := C - V' * W' */
04113 
04114                 if (*m > *k) {
04115 
04116 /*                 C2 := C2 - V2' * W' */
04117 
04118                     i__1 = *m - *k;
04119                     sgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &
04120                             v_ref(1, *k + 1), ldv, &work[work_offset], ldwork,
04121                              &c_b14, &c___ref(*k + 1, 1), ldc);
04122                 }
04123 
04124 /*              W := W * V1 */
04125 
04126                 strmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14,
04127                          &v[v_offset], ldv, &work[work_offset], ldwork);
04128 
04129 /*              C1 := C1 - W' */
04130 
04131                 i__1 = *k;
04132                 for (j = 1; j <= i__1; ++j) {
04133                     i__2 = *n;
04134                     for (i__ = 1; i__ <= i__2; ++i__) {
04135                         c___ref(j, i__) = c___ref(j, i__) - work_ref(i__, j);
04136 /* L140: */
04137                     }
04138 /* L150: */
04139                 }
04140 
04141             } else if (lsame_(side, "R")) {
04142 
04143 /*              Form  C * H  or  C * H'  where  C = ( C1  C2 )   
04144 
04145                 W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)   
04146 
04147                 W := C1 */
04148 
04149                 i__1 = *k;
04150                 for (j = 1; j <= i__1; ++j) {
04151                     scopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1);
04152 /* L160: */
04153                 }
04154 
04155 /*              W := W * V1' */
04156 
04157                 strmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, &
04158                         v[v_offset], ldv, &work[work_offset], ldwork);
04159                 if (*n > *k) {
04160 
04161 /*                 W := W + C2 * V2' */
04162 
04163                     i__1 = *n - *k;
04164                     sgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
04165                             c___ref(1, *k + 1), ldc, &v_ref(1, *k + 1), ldv, &
04166                             c_b14, &work[work_offset], ldwork);
04167                 }
04168 
04169 /*              W := W * T  or  W * T' */
04170 
04171                 strmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[
04172                         t_offset], ldt, &work[work_offset], ldwork);
04173 
04174 /*              C := C - W * V */
04175 
04176                 if (*n > *k) {
04177 
04178 /*                 C2 := C2 - W * V2 */
04179 
04180                     i__1 = *n - *k;
04181                     sgemm_("No transpose", "No transpose", m, &i__1, k, &
04182                             c_b25, &work[work_offset], ldwork, &v_ref(1, *k + 
04183                             1), ldv, &c_b14, &c___ref(1, *k + 1), ldc);
04184                 }
04185 
04186 /*              W := W * V1 */
04187 
04188                 strmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14,
04189                          &v[v_offset], ldv, &work[work_offset], ldwork);
04190 
04191 /*              C1 := C1 - W */
04192 
04193                 i__1 = *k;
04194                 for (j = 1; j <= i__1; ++j) {
04195                     i__2 = *m;
04196                     for (i__ = 1; i__ <= i__2; ++i__) {
04197                         c___ref(i__, j) = c___ref(i__, j) - work_ref(i__, j);
04198 /* L170: */
04199                     }
04200 /* L180: */
04201                 }
04202 
04203             }
04204 
04205         } else {
04206 
04207 /*           Let  V =  ( V1  V2 )    (V2: last K columns)   
04208              where  V2  is unit lower triangular. */
04209 
04210             if (lsame_(side, "L")) {
04211 
04212 /*              Form  H * C  or  H' * C  where  C = ( C1 )   
04213                                                     ( C2 )   
04214 
04215                 W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)   
04216 
04217                 W := C2' */
04218 
04219                 i__1 = *k;
04220                 for (j = 1; j <= i__1; ++j) {
04221                     scopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j), 
04222                             &c__1);
04223 /* L190: */
04224                 }
04225 
04226 /*              W := W * V2' */
04227 
04228                 strmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, &
04229                         v_ref(1, *m - *k + 1), ldv, &work[work_offset], 
04230                         ldwork);
04231                 if (*m > *k) {
04232 
04233 /*                 W := W + C1'*V1' */
04234 
04235                     i__1 = *m - *k;
04236                     sgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, &
04237                             c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
04238                             work[work_offset], ldwork);
04239                 }
04240 
04241 /*              W := W * T'  or  W * T */
04242 
04243                 strmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[
04244                         t_offset], ldt, &work[work_offset], ldwork);
04245 
04246 /*              C := C - V' * W' */
04247 
04248                 if (*m > *k) {
04249 
04250 /*                 C1 := C1 - V1' * W' */
04251 
04252                     i__1 = *m - *k;
04253                     sgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[
04254                             v_offset], ldv, &work[work_offset], ldwork, &
04255                             c_b14, &c__[c_offset], ldc);
04256                 }
04257 
04258 /*              W := W * V2 */
04259 
04260                 strmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14,
04261                          &v_ref(1, *m - *k + 1), ldv, &work[work_offset], 
04262                         ldwork);
04263 
04264 /*              C2 := C2 - W' */
04265 
04266                 i__1 = *k;
04267                 for (j = 1; j <= i__1; ++j) {
04268                     i__2 = *n;
04269                     for (i__ = 1; i__ <= i__2; ++i__) {
04270                         c___ref(*m - *k + j, i__) = c___ref(*m - *k + j, i__) 
04271                                 - work_ref(i__, j);
04272 /* L200: */
04273                     }
04274 /* L210: */
04275                 }
04276 
04277             } else if (lsame_(side, "R")) {
04278 
04279 /*              Form  C * H  or  C * H'  where  C = ( C1  C2 )   
04280 
04281                 W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)   
04282 
04283                 W := C2 */
04284 
04285                 i__1 = *k;
04286                 for (j = 1; j <= i__1; ++j) {
04287                     scopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j)
04288                             , &c__1);
04289 /* L220: */
04290                 }
04291 
04292 /*              W := W * V2' */
04293 
04294                 strmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, &
04295                         v_ref(1, *n - *k + 1), ldv, &work[work_offset], 
04296                         ldwork);
04297                 if (*n > *k) {
04298 
04299 /*                 W := W + C1 * V1' */
04300 
04301                     i__1 = *n - *k;
04302                     sgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, &
04303                             c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
04304                             work[work_offset], ldwork);
04305                 }
04306 
04307 /*              W := W * T  or  W * T' */
04308 
04309                 strmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[
04310                         t_offset], ldt, &work[work_offset], ldwork);
04311 
04312 /*              C := C - W * V */
04313 
04314                 if (*n > *k) {
04315 
04316 /*                 C1 := C1 - W * V1 */
04317 
04318                     i__1 = *n - *k;
04319                     sgemm_("No transpose", "No transpose", m, &i__1, k, &
04320                             c_b25, &work[work_offset], ldwork, &v[v_offset], 
04321                             ldv, &c_b14, &c__[c_offset], ldc);
04322                 }
04323 
04324 /*              W := W * V2 */
04325 
04326                 strmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14,
04327                          &v_ref(1, *n - *k + 1), ldv, &work[work_offset], 
04328                         ldwork);
04329 
04330 /*              C1 := C1 - W */
04331 
04332                 i__1 = *k;
04333                 for (j = 1; j <= i__1; ++j) {
04334                     i__2 = *m;
04335                     for (i__ = 1; i__ <= i__2; ++i__) {
04336                         c___ref(i__, *n - *k + j) = c___ref(i__, *n - *k + j) 
04337                                 - work_ref(i__, j);
04338 /* L230: */
04339                     }
04340 /* L240: */
04341                 }
04342 
04343             }
04344 
04345         }
04346     }
04347 
04348     return 0;
04349 
04350 /*     End of SLARFB */
04351 
04352 } /* slarfb_ */
04353 
04354 #undef v_ref
04355 #undef c___ref
04356 #undef work_ref
04357 
04358 
04359 
04360 
04361 
04362 /* Subroutine */ int slarf_(const char *side, integer *m, integer *n, real *v, 
04363         integer *incv, real *tau, real *c__, integer *ldc, real *work)
04364 {
04365 /*  -- LAPACK auxiliary routine (version 3.0) --   
04366        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
04367        Courant Institute, Argonne National Lab, and Rice University   
04368        February 29, 1992   
04369 
04370 
04371     Purpose   
04372     =======   
04373 
04374     SLARF applies a real elementary reflector H to a real m by n matrix   
04375     C, from either the left or the right. H is represented in the form   
04376 
04377           H = I - tau * v * v'   
04378 
04379     where tau is a real scalar and v is a real vector.   
04380 
04381     If tau = 0, then H is taken to be the unit matrix.   
04382 
04383     Arguments   
04384     =========   
04385 
04386     SIDE    (input) CHARACTER*1   
04387             = 'L': form  H * C   
04388             = 'R': form  C * H   
04389 
04390     M       (input) INTEGER   
04391             The number of rows of the matrix C.   
04392 
04393     N       (input) INTEGER   
04394             The number of columns of the matrix C.   
04395 
04396     V       (input) REAL array, dimension   
04397                        (1 + (M-1)*abs(INCV)) if SIDE = 'L'   
04398                     or (1 + (N-1)*abs(INCV)) if SIDE = 'R'   
04399             The vector v in the representation of H. V is not used if   
04400             TAU = 0.   
04401 
04402     INCV    (input) INTEGER   
04403             The increment between elements of v. INCV <> 0.   
04404 
04405     TAU     (input) REAL   
04406             The value tau in the representation of H.   
04407 
04408     C       (input/output) REAL array, dimension (LDC,N)   
04409             On entry, the m by n matrix C.   
04410             On exit, C is overwritten by the matrix H * C if SIDE = 'L',   
04411             or C * H if SIDE = 'R'.   
04412 
04413     LDC     (input) INTEGER   
04414             The leading dimension of the array C. LDC >= f2cmax(1,M).   
04415 
04416     WORK    (workspace) REAL array, dimension   
04417                            (N) if SIDE = 'L'   
04418                         or (M) if SIDE = 'R'   
04419 
04420     =====================================================================   
04421 
04422 
04423        Parameter adjustments */
04424     /* Table of constant values */
04425     static real c_b4 = 1.f;
04426     static real c_b5 = 0.f;
04427     static integer c__1 = 1;
04428     
04429     /* System generated locals */
04430     integer c_dim1, c_offset;
04431     real r__1;
04432     /* Local variables */
04433     extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
04434             integer *, real *, integer *, real *, integer *);
04435     extern logical lsame_(const char *, const char *);
04436     extern /* Subroutine */ int sgemv_(const char *, integer *, integer *, real *, 
04437             real *, integer *, real *, integer *, real *, real *, integer *);
04438 
04439 
04440     --v;
04441     c_dim1 = *ldc;
04442     c_offset = 1 + c_dim1 * 1;
04443     c__ -= c_offset;
04444     --work;
04445 
04446     /* Function Body */
04447     if (lsame_(side, "L")) {
04448 
04449 /*        Form  H * C */
04450 
04451         if (*tau != 0.f) {
04452 
04453 /*           w := C' * v */
04454 
04455             sgemv_("Transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], incv,
04456                      &c_b5, &work[1], &c__1);
04457 
04458 /*           C := C - v * w' */
04459 
04460             r__1 = -(*tau);
04461             sger_(m, n, &r__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], 
04462                     ldc);
04463         }
04464     } else {
04465 
04466 /*        Form  C * H */
04467 
04468         if (*tau != 0.f) {
04469 
04470 /*           w := C * v */
04471 
04472             sgemv_("No transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], 
04473                     incv, &c_b5, &work[1], &c__1);
04474 
04475 /*           C := C - w * v' */
04476 
04477             r__1 = -(*tau);
04478             sger_(m, n, &r__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], 
04479                     ldc);
04480         }
04481     }
04482     return 0;
04483 
04484 /*     End of SLARF */
04485 
04486 } /* slarf_ */
04487 
04488 
04489 
04490 
04491 /* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx, 
04492         real *tau)
04493 {
04494 /*  -- LAPACK auxiliary routine (version 3.0) --   
04495        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
04496        Courant Institute, Argonne National Lab, and Rice University   
04497        September 30, 1994   
04498 
04499 
04500     Purpose   
04501     =======   
04502 
04503     SLARFG generates a real elementary reflector H of order n, such   
04504     that   
04505 
04506           H * ( alpha ) = ( beta ),   H' * H = I.   
04507               (   x   )   (   0  )   
04508 
04509     where alpha and beta are scalars, and x is an (n-1)-element real   
04510     vector. H is represented in the form   
04511 
04512           H = I - tau * ( 1 ) * ( 1 v' ) ,   
04513                         ( v )   
04514 
04515     where tau is a real scalar and v is a real (n-1)-element   
04516     vector.   
04517 
04518     If the elements of x are all zero, then tau = 0 and H is taken to be   
04519     the unit matrix.   
04520 
04521     Otherwise  1 <= tau <= 2.   
04522 
04523     Arguments   
04524     =========   
04525 
04526     N       (input) INTEGER   
04527             The order of the elementary reflector.   
04528 
04529     ALPHA   (input/output) REAL   
04530             On entry, the value alpha.   
04531             On exit, it is overwritten with the value beta.   
04532 
04533     X       (input/output) REAL array, dimension   
04534                            (1+(N-2)*abs(INCX))   
04535             On entry, the vector x.   
04536             On exit, it is overwritten with the vector v.   
04537 
04538     INCX    (input) INTEGER   
04539             The increment between elements of X. INCX > 0.   
04540 
04541     TAU     (output) REAL   
04542             The value tau.   
04543 
04544     =====================================================================   
04545 
04546 
04547        Parameter adjustments */
04548     /* System generated locals */
04549     integer i__1;
04550     real r__1;
04551     /* Builtin functions */
04552     double r_sign(real *, real *);
04553     /* Local variables */
04554     static real beta;
04555     extern doublereal snrm2_(integer *, real *, integer *);
04556     static integer j;
04557     extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
04558     static real xnorm;
04559     extern doublereal slapy2_(real *, real *), slamch_(const char *);
04560     static real safmin, rsafmn;
04561     static integer knt;
04562 
04563     --x;
04564 
04565     /* Function Body */
04566     if (*n <= 1) {
04567         *tau = 0.f;
04568         return 0;
04569     }
04570 
04571     i__1 = *n - 1;
04572     xnorm = snrm2_(&i__1, &x[1], incx);
04573 
04574     if (xnorm == 0.f) {
04575 
04576 /*        H  =  I */
04577 
04578         *tau = 0.f;
04579     } else {
04580 
04581 /*        general case */
04582 
04583         r__1 = slapy2_(alpha, &xnorm);
04584         beta = -r_sign(&r__1, alpha);
04585         safmin = slamch_("S") / slamch_("E");
04586         if (dabs(beta) < safmin) {
04587 
04588 /*           XNORM, BETA may be inaccurate; scale X and recompute them */
04589 
04590             rsafmn = 1.f / safmin;
04591             knt = 0;
04592 L10:
04593             ++knt;
04594             i__1 = *n - 1;
04595             sscal_(&i__1, &rsafmn, &x[1], incx);
04596             beta *= rsafmn;
04597             *alpha *= rsafmn;
04598             if (dabs(beta) < safmin) {
04599                 goto L10;
04600             }
04601 
04602 /*           New BETA is at most 1, at least SAFMIN */
04603 
04604             i__1 = *n - 1;
04605             xnorm = snrm2_(&i__1, &x[1], incx);
04606             r__1 = slapy2_(alpha, &xnorm);
04607             beta = -r_sign(&r__1, alpha);
04608             *tau = (beta - *alpha) / beta;
04609             i__1 = *n - 1;
04610             r__1 = 1.f / (*alpha - beta);
04611             sscal_(&i__1, &r__1, &x[1], incx);
04612 
04613 /*           If ALPHA is subnormal, it may lose relative accuracy */
04614 
04615             *alpha = beta;
04616             i__1 = knt;
04617             for (j = 1; j <= i__1; ++j) {
04618                 *alpha *= safmin;
04619 /* L20: */
04620             }
04621         } else {
04622             *tau = (beta - *alpha) / beta;
04623             i__1 = *n - 1;
04624             r__1 = 1.f / (*alpha - beta);
04625             sscal_(&i__1, &r__1, &x[1], incx);
04626             *alpha = beta;
04627         }
04628     }
04629 
04630     return 0;
04631 
04632 /*     End of SLARFG */
04633 
04634 } /* slarfg_ */
04635 
04636 
04637 
04638 
04639 /* Subroutine */ int slarft_(const char *direct, const char *storev, integer *n, integer *
04640         k, real *v, integer *ldv, real *tau, real *t, integer *ldt)
04641 {
04642 /*  -- LAPACK auxiliary routine (version 3.0) --   
04643        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
04644        Courant Institute, Argonne National Lab, and Rice University   
04645        February 29, 1992   
04646 
04647 
04648     Purpose   
04649     =======   
04650 
04651     SLARFT forms the triangular factor T of a real block reflector H   
04652     of order n, which is defined as a product of k elementary reflectors.   
04653 
04654     If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;   
04655 
04656     If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.   
04657 
04658     If STOREV = 'C', the vector which defines the elementary reflector   
04659     H(i) is stored in the i-th column of the array V, and   
04660 
04661        H  =  I - V * T * V'   
04662 
04663     If STOREV = 'R', the vector which defines the elementary reflector   
04664     H(i) is stored in the i-th row of the array V, and   
04665 
04666        H  =  I - V' * T * V   
04667 
04668     Arguments   
04669     =========   
04670 
04671     DIRECT  (input) CHARACTER*1   
04672             Specifies the order in which the elementary reflectors are   
04673             multiplied to form the block reflector:   
04674             = 'F': H = H(1) H(2) . . . H(k) (Forward)   
04675             = 'B': H = H(k) . . . H(2) H(1) (Backward)   
04676 
04677     STOREV  (input) CHARACTER*1   
04678             Specifies how the vectors which define the elementary   
04679             reflectors are stored (see also Further Details):   
04680             = 'C': columnwise   
04681             = 'R': rowwise   
04682 
04683     N       (input) INTEGER   
04684             The order of the block reflector H. N >= 0.   
04685 
04686     K       (input) INTEGER   
04687             The order of the triangular factor T (= the number of   
04688             elementary reflectors). K >= 1.   
04689 
04690     V       (input/output) REAL array, dimension   
04691                                  (LDV,K) if STOREV = 'C'   
04692                                  (LDV,N) if STOREV = 'R'   
04693             The matrix V. See further details.   
04694 
04695     LDV     (input) INTEGER   
04696             The leading dimension of the array V.   
04697             If STOREV = 'C', LDV >= f2cmax(1,N); if STOREV = 'R', LDV >= K.   
04698 
04699     TAU     (input) REAL array, dimension (K)   
04700             TAU(i) must contain the scalar factor of the elementary   
04701             reflector H(i).   
04702 
04703     T       (output) REAL array, dimension (LDT,K)   
04704             The k by k triangular factor T of the block reflector.   
04705             If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is   
04706             lower triangular. The rest of the array is not used.   
04707 
04708     LDT     (input) INTEGER   
04709             The leading dimension of the array T. LDT >= K.   
04710 
04711     Further Details   
04712     ===============   
04713 
04714     The shape of the matrix V and the storage of the vectors which define   
04715     the H(i) is best illustrated by the following example with n = 5 and   
04716     k = 3. The elements equal to 1 are not stored; the corresponding   
04717     array elements are modified but restored on exit. The rest of the   
04718     array is not used.   
04719 
04720     DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':   
04721 
04722                  V = (  1       )                 V = (  1 v1 v1 v1 v1 )   
04723                      ( v1  1    )                     (     1 v2 v2 v2 )   
04724                      ( v1 v2  1 )                     (        1 v3 v3 )   
04725                      ( v1 v2 v3 )   
04726                      ( v1 v2 v3 )   
04727 
04728     DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':   
04729 
04730                  V = ( v1 v2 v3 )                 V = ( v1 v1  1       )   
04731                      ( v1 v2 v3 )                     ( v2 v2 v2  1    )   
04732                      (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )   
04733                      (     1 v3 )   
04734                      (        1 )   
04735 
04736     =====================================================================   
04737 
04738 
04739        Quick return if possible   
04740 
04741        Parameter adjustments */
04742     /* Table of constant values */
04743     static integer c__1 = 1;
04744     static real c_b8 = 0.f;
04745     
04746     /* System generated locals */
04747     integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
04748     real r__1;
04749     /* Local variables */
04750     static integer i__, j;
04751     extern logical lsame_(const char *, const char *);
04752     extern /* Subroutine */ int sgemv_(const char *, integer *, integer *, real *, 
04753             real *, integer *, real *, integer *, real *, real *, integer *), strmv_(const char *, const char *, const char *, integer *, real *, 
04754             integer *, real *, integer *);
04755     static real vii;
04756 #define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1]
04757 #define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1]
04758 
04759 
04760     v_dim1 = *ldv;
04761     v_offset = 1 + v_dim1 * 1;
04762     v -= v_offset;
04763     --tau;
04764     t_dim1 = *ldt;
04765     t_offset = 1 + t_dim1 * 1;
04766     t -= t_offset;
04767 
04768     /* Function Body */
04769     if (*n == 0) {
04770         return 0;
04771     }
04772 
04773     if (lsame_(direct, "F")) {
04774         i__1 = *k;
04775         for (i__ = 1; i__ <= i__1; ++i__) {
04776             if (tau[i__] == 0.f) {
04777 
04778 /*              H(i)  =  I */
04779 
04780                 i__2 = i__;
04781                 for (j = 1; j <= i__2; ++j) {
04782                     t_ref(j, i__) = 0.f;
04783 /* L10: */
04784                 }
04785             } else {
04786 
04787 /*              general case */
04788 
04789                 vii = v_ref(i__, i__);
04790                 v_ref(i__, i__) = 1.f;
04791                 if (lsame_(storev, "C")) {
04792 
04793 /*                 T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */
04794 
04795                     i__2 = *n - i__ + 1;
04796                     i__3 = i__ - 1;
04797                     r__1 = -tau[i__];
04798                     sgemv_("Transpose", &i__2, &i__3, &r__1, &v_ref(i__, 1), 
04799                             ldv, &v_ref(i__, i__), &c__1, &c_b8, &t_ref(1, 
04800                             i__), &c__1);
04801                 } else {
04802 
04803 /*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */
04804 
04805                     i__2 = i__ - 1;
04806                     i__3 = *n - i__ + 1;
04807                     r__1 = -tau[i__];
04808                     sgemv_("No transpose", &i__2, &i__3, &r__1, &v_ref(1, i__)
04809                             , ldv, &v_ref(i__, i__), ldv, &c_b8, &t_ref(1, 
04810                             i__), &c__1);
04811                 }
04812                 v_ref(i__, i__) = vii;
04813 
04814 /*              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
04815 
04816                 i__2 = i__ - 1;
04817                 strmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
04818                         t_offset], ldt, &t_ref(1, i__), &c__1);
04819                 t_ref(i__, i__) = tau[i__];
04820             }
04821 /* L20: */
04822         }
04823     } else {
04824         for (i__ = *k; i__ >= 1; --i__) {
04825             if (tau[i__] == 0.f) {
04826 
04827 /*              H(i)  =  I */
04828 
04829                 i__1 = *k;
04830                 for (j = i__; j <= i__1; ++j) {
04831                     t_ref(j, i__) = 0.f;
04832 /* L30: */
04833                 }
04834             } else {
04835 
04836 /*              general case */
04837 
04838                 if (i__ < *k) {
04839                     if (lsame_(storev, "C")) {
04840                         vii = v_ref(*n - *k + i__, i__);
04841                         v_ref(*n - *k + i__, i__) = 1.f;
04842 
04843 /*                    T(i+1:k,i) :=   
04844                               - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) */
04845 
04846                         i__1 = *n - *k + i__;
04847                         i__2 = *k - i__;
04848                         r__1 = -tau[i__];
04849                         sgemv_("Transpose", &i__1, &i__2, &r__1, &v_ref(1, 
04850                                 i__ + 1), ldv, &v_ref(1, i__), &c__1, &c_b8, &
04851                                 t_ref(i__ + 1, i__), &c__1);
04852                         v_ref(*n - *k + i__, i__) = vii;
04853                     } else {
04854                         vii = v_ref(i__, *n - *k + i__);
04855                         v_ref(i__, *n - *k + i__) = 1.f;
04856 
04857 /*                    T(i+1:k,i) :=   
04858                               - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' */
04859 
04860                         i__1 = *k - i__;
04861                         i__2 = *n - *k + i__;
04862                         r__1 = -tau[i__];
04863                         sgemv_("No transpose", &i__1, &i__2, &r__1, &v_ref(
04864                                 i__ + 1, 1), ldv, &v_ref(i__, 1), ldv, &c_b8, 
04865                                 &t_ref(i__ + 1, i__), &c__1);
04866                         v_ref(i__, *n - *k + i__) = vii;
04867                     }
04868 
04869 /*                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
04870 
04871                     i__1 = *k - i__;
04872                     strmv_("Lower", "No transpose", "Non-unit", &i__1, &t_ref(
04873                             i__ + 1, i__ + 1), ldt, &t_ref(i__ + 1, i__), &
04874                             c__1);
04875                 }
04876                 t_ref(i__, i__) = tau[i__];
04877             }
04878 /* L40: */
04879         }
04880     }
04881     return 0;
04882 
04883 /*     End of SLARFT */
04884 
04885 } /* slarft_ */
04886 
04887 #undef v_ref
04888 #undef t_ref
04889 
04890 
04891 
04892 
04893 
04894 /* Subroutine */ int slartg_(real *f, real *g, real *cs, real *sn, real *r__)
04895 {
04896 /*  -- LAPACK auxiliary routine (version 3.0) --   
04897        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
04898        Courant Institute, Argonne National Lab, and Rice University   
04899        September 30, 1994   
04900 
04901 
04902     Purpose   
04903     =======   
04904 
04905     SLARTG generate a plane rotation so that   
04906 
04907        [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.   
04908        [ -SN  CS  ]     [ G ]     [ 0 ]   
04909 
04910     This is a slower, more accurate version of the BLAS1 routine SROTG,   
04911     with the following other differences:   
04912        F and G are unchanged on return.   
04913        If G=0, then CS=1 and SN=0.   
04914        If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any   
04915           floating point operations (saves work in SBDSQR when   
04916           there are zeros on the diagonal).   
04917 
04918     If F exceeds G in magnitude, CS will be positive.   
04919 
04920     Arguments   
04921     =========   
04922 
04923     F       (input) REAL   
04924             The first component of vector to be rotated.   
04925 
04926     G       (input) REAL   
04927             The second component of vector to be rotated.   
04928 
04929     CS      (output) REAL   
04930             The cosine of the rotation.   
04931 
04932     SN      (output) REAL   
04933             The sine of the rotation.   
04934 
04935     R       (output) REAL   
04936             The nonzero component of the rotated vector.   
04937 
04938     ===================================================================== */
04939     /* Initialized data */
04940     static logical first = TRUE_;
04941     /* System generated locals */
04942     integer i__1;
04943     real r__1, r__2;
04944     /* Builtin functions */
04945 //    double log(doublereal), pow_ri(real *, integer *), sqrt(doublereal);
04946     double pow_ri(real *, integer *);
04947     /* Local variables */
04948     static integer i__;
04949     static real scale;
04950     static integer count;
04951     static real f1, g1, safmn2, safmx2;
04952     extern doublereal slamch_(const char *);
04953     static real safmin, eps;
04954 
04955 
04956 
04957     if (first) {
04958         first = FALSE_;
04959         safmin = slamch_("S");
04960         eps = slamch_("E");
04961         r__1 = slamch_("B");
04962         i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 
04963                 2.f);
04964         safmn2 = pow_ri(&r__1, &i__1);
04965         safmx2 = 1.f / safmn2;
04966     }
04967     if (*g == 0.f) {
04968         *cs = 1.f;
04969         *sn = 0.f;
04970         *r__ = *f;
04971     } else if (*f == 0.f) {
04972         *cs = 0.f;
04973         *sn = 1.f;
04974         *r__ = *g;
04975     } else {
04976         f1 = *f;
04977         g1 = *g;
04978 /* Computing MAX */
04979         r__1 = dabs(f1), r__2 = dabs(g1);
04980         scale = df2cmax(r__1,r__2);
04981         if (scale >= safmx2) {
04982             count = 0;
04983 L10:
04984             ++count;
04985             f1 *= safmn2;
04986             g1 *= safmn2;
04987 /* Computing MAX */
04988             r__1 = dabs(f1), r__2 = dabs(g1);
04989             scale = df2cmax(r__1,r__2);
04990             if (scale >= safmx2) {
04991                 goto L10;
04992             }
04993 /* Computing 2nd power */
04994             r__1 = f1;
04995 /* Computing 2nd power */
04996             r__2 = g1;
04997             *r__ = sqrt(r__1 * r__1 + r__2 * r__2);
04998             *cs = f1 / *r__;
04999             *sn = g1 / *r__;
05000             i__1 = count;
05001             for (i__ = 1; i__ <= i__1; ++i__) {
05002                 *r__ *= safmx2;
05003 /* L20: */
05004             }
05005         } else if (scale <= safmn2) {
05006             count = 0;
05007 L30:
05008             ++count;
05009             f1 *= safmx2;
05010             g1 *= safmx2;
05011 /* Computing MAX */
05012             r__1 = dabs(f1), r__2 = dabs(g1);
05013             scale = df2cmax(r__1,r__2);
05014             if (scale <= safmn2) {
05015                 goto L30;
05016             }
05017 /* Computing 2nd power */
05018             r__1 = f1;
05019 /* Computing 2nd power */
05020             r__2 = g1;
05021             *r__ = sqrt(r__1 * r__1 + r__2 * r__2);
05022             *cs = f1 / *r__;
05023             *sn = g1 / *r__;
05024             i__1 = count;
05025             for (i__ = 1; i__ <= i__1; ++i__) {
05026                 *r__ *= safmn2;
05027 /* L40: */
05028             }
05029         } else {
05030 /* Computing 2nd power */
05031             r__1 = f1;
05032 /* Computing 2nd power */
05033             r__2 = g1;
05034             *r__ = sqrt(r__1 * r__1 + r__2 * r__2);
05035             *cs = f1 / *r__;
05036             *sn = g1 / *r__;
05037         }
05038         if (dabs(*f) > dabs(*g) && *cs < 0.f) {
05039             *cs = -(*cs);
05040             *sn = -(*sn);
05041             *r__ = -(*r__);
05042         }
05043     }
05044     return 0;
05045 
05046 /*     End of SLARTG */
05047 
05048 } /* slartg_ */
05049 
05050 
05051 
05052 
05053 /* Subroutine */ int slascl_(const char *type__, integer *kl, integer *ku, real *
05054         cfrom, real *cto, integer *m, integer *n, real *a, integer *lda, 
05055         integer *info)
05056 {
05057 /*  -- LAPACK auxiliary routine (version 3.0) --   
05058        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
05059        Courant Institute, Argonne National Lab, and Rice University   
05060        February 29, 1992   
05061 
05062 
05063     Purpose   
05064     =======   
05065 
05066     SLASCL multiplies the M by N real matrix A by the real scalar   
05067     CTO/CFROM.  This is done without over/underflow as long as the final   
05068     result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that   
05069     A may be full, upper triangular, lower triangular, upper Hessenberg,   
05070     or banded.   
05071 
05072     Arguments   
05073     =========   
05074 
05075     TYPE    (input) CHARACTER*1   
05076             TYPE indices the storage type of the input matrix.   
05077             = 'G':  A is a full matrix.   
05078             = 'L':  A is a lower triangular matrix.   
05079             = 'U':  A is an upper triangular matrix.   
05080             = 'H':  A is an upper Hessenberg matrix.   
05081             = 'B':  A is a symmetric band matrix with lower bandwidth KL   
05082                     and upper bandwidth KU and with the only the lower   
05083                     half stored.   
05084             = 'Q':  A is a symmetric band matrix with lower bandwidth KL   
05085                     and upper bandwidth KU and with the only the upper   
05086                     half stored.   
05087             = 'Z':  A is a band matrix with lower bandwidth KL and upper   
05088                     bandwidth KU.   
05089 
05090     KL      (input) INTEGER   
05091             The lower bandwidth of A.  Referenced only if TYPE = 'B',   
05092             'Q' or 'Z'.   
05093 
05094     KU      (input) INTEGER   
05095             The upper bandwidth of A.  Referenced only if TYPE = 'B',   
05096             'Q' or 'Z'.   
05097 
05098     CFROM   (input) REAL   
05099     CTO     (input) REAL   
05100             The matrix A is multiplied by CTO/CFROM. A(I,J) is computed   
05101             without over/underflow if the final result CTO*A(I,J)/CFROM   
05102             can be represented without over/underflow.  CFROM must be   
05103             nonzero.   
05104 
05105     M       (input) INTEGER   
05106             The number of rows of the matrix A.  M >= 0.   
05107 
05108     N       (input) INTEGER   
05109             The number of columns of the matrix A.  N >= 0.   
05110 
05111     A       (input/output) REAL array, dimension (LDA,M)   
05112             The matrix to be multiplied by CTO/CFROM.  See TYPE for the   
05113             storage type.   
05114 
05115     LDA     (input) INTEGER   
05116             The leading dimension of the array A.  LDA >= f2cmax(1,M).   
05117 
05118     INFO    (output) INTEGER   
05119             0  - successful exit   
05120             <0 - if INFO = -i, the i-th argument had an illegal value.   
05121 
05122     =====================================================================   
05123 
05124 
05125        Test the input arguments   
05126 
05127        Parameter adjustments */
05128     /* System generated locals */
05129     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
05130     /* Local variables */
05131     static logical done;
05132     static real ctoc;
05133     static integer i__, j;
05134     extern logical lsame_(const char *, const char *);
05135     static integer itype, k1, k2, k3, k4;
05136     static real cfrom1;
05137     extern doublereal slamch_(const char *);
05138     static real cfromc;
05139     extern /* Subroutine */ int xerbla_(const char *, integer *);
05140     static real bignum, smlnum, mul, cto1;
05141 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
05142 
05143     a_dim1 = *lda;
05144     a_offset = 1 + a_dim1 * 1;
05145     a -= a_offset;
05146 
05147     /* Function Body */
05148     *info = 0;
05149 
05150     if (lsame_(type__, "G")) {
05151         itype = 0;
05152     } else if (lsame_(type__, "L")) {
05153         itype = 1;
05154     } else if (lsame_(type__, "U")) {
05155         itype = 2;
05156     } else if (lsame_(type__, "H")) {
05157         itype = 3;
05158     } else if (lsame_(type__, "B")) {
05159         itype = 4;
05160     } else if (lsame_(type__, "Q")) {
05161         itype = 5;
05162     } else if (lsame_(type__, "Z")) {
05163         itype = 6;
05164     } else {
05165         itype = -1;
05166     }
05167 
05168     if (itype == -1) {
05169         *info = -1;
05170     } else if (*cfrom == 0.f) {
05171         *info = -4;
05172     } else if (*m < 0) {
05173         *info = -6;
05174     } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
05175         *info = -7;
05176     } else if (itype <= 3 && *lda < f2cmax(1,*m)) {
05177         *info = -9;
05178     } else if (itype >= 4) {
05179 /* Computing MAX */
05180         i__1 = *m - 1;
05181         if (*kl < 0 || *kl > f2cmax(i__1,0)) {
05182             *info = -2;
05183         } else /* if(complicated condition) */ {
05184 /* Computing MAX */
05185             i__1 = *n - 1;
05186             if (*ku < 0 || *ku > f2cmax(i__1,0) || (itype == 4 || itype == 5) && 
05187                     *kl != *ku) {
05188                 *info = -3;
05189             } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
05190                     ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
05191                 *info = -9;
05192             }
05193         }
05194     }
05195 
05196     if (*info != 0) {
05197         i__1 = -(*info);
05198         xerbla_("SLASCL", &i__1);
05199         return 0;
05200     }
05201 
05202 /*     Quick return if possible */
05203 
05204     if (*n == 0 || *m == 0) {
05205         return 0;
05206     }
05207 
05208 /*     Get machine parameters */
05209 
05210     smlnum = slamch_("S");
05211     bignum = 1.f / smlnum;
05212 
05213     cfromc = *cfrom;
05214     ctoc = *cto;
05215 
05216 L10:
05217     cfrom1 = cfromc * smlnum;
05218     cto1 = ctoc / bignum;
05219     if (dabs(cfrom1) > dabs(ctoc) && ctoc != 0.f) {
05220         mul = smlnum;
05221         done = FALSE_;
05222         cfromc = cfrom1;
05223     } else if (dabs(cto1) > dabs(cfromc)) {
05224         mul = bignum;
05225         done = FALSE_;
05226         ctoc = cto1;
05227     } else {
05228         mul = ctoc / cfromc;
05229         done = TRUE_;
05230     }
05231 
05232     if (itype == 0) {
05233 
05234 /*        Full matrix */
05235 
05236         i__1 = *n;
05237         for (j = 1; j <= i__1; ++j) {
05238             i__2 = *m;
05239             for (i__ = 1; i__ <= i__2; ++i__) {
05240                 a_ref(i__, j) = a_ref(i__, j) * mul;
05241 /* L20: */
05242             }
05243 /* L30: */
05244         }
05245 
05246     } else if (itype == 1) {
05247 
05248 /*        Lower triangular matrix */
05249 
05250         i__1 = *n;
05251         for (j = 1; j <= i__1; ++j) {
05252             i__2 = *m;
05253             for (i__ = j; i__ <= i__2; ++i__) {
05254                 a_ref(i__, j) = a_ref(i__, j) * mul;
05255 /* L40: */
05256             }
05257 /* L50: */
05258         }
05259 
05260     } else if (itype == 2) {
05261 
05262 /*        Upper triangular matrix */
05263 
05264         i__1 = *n;
05265         for (j = 1; j <= i__1; ++j) {
05266             i__2 = f2cmin(j,*m);
05267             for (i__ = 1; i__ <= i__2; ++i__) {
05268                 a_ref(i__, j) = a_ref(i__, j) * mul;
05269 /* L60: */
05270             }
05271 /* L70: */
05272         }
05273 
05274     } else if (itype == 3) {
05275 
05276 /*        Upper Hessenberg matrix */
05277 
05278         i__1 = *n;
05279         for (j = 1; j <= i__1; ++j) {
05280 /* Computing MIN */
05281             i__3 = j + 1;
05282             i__2 = f2cmin(i__3,*m);
05283             for (i__ = 1; i__ <= i__2; ++i__) {
05284                 a_ref(i__, j) = a_ref(i__, j) * mul;
05285 /* L80: */
05286             }
05287 /* L90: */
05288         }
05289 
05290     } else if (itype == 4) {
05291 
05292 /*        Lower half of a symmetric band matrix */
05293 
05294         k3 = *kl + 1;
05295         k4 = *n + 1;
05296         i__1 = *n;
05297         for (j = 1; j <= i__1; ++j) {
05298 /* Computing MIN */
05299             i__3 = k3, i__4 = k4 - j;
05300             i__2 = f2cmin(i__3,i__4);
05301             for (i__ = 1; i__ <= i__2; ++i__) {
05302                 a_ref(i__, j) = a_ref(i__, j) * mul;
05303 /* L100: */
05304             }
05305 /* L110: */
05306         }
05307 
05308     } else if (itype == 5) {
05309 
05310 /*        Upper half of a symmetric band matrix */
05311 
05312         k1 = *ku + 2;
05313         k3 = *ku + 1;
05314         i__1 = *n;
05315         for (j = 1; j <= i__1; ++j) {
05316 /* Computing MAX */
05317             i__2 = k1 - j;
05318             i__3 = k3;
05319             for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) {
05320                 a_ref(i__, j) = a_ref(i__, j) * mul;
05321 /* L120: */
05322             }
05323 /* L130: */
05324         }
05325 
05326     } else if (itype == 6) {
05327 
05328 /*        Band matrix */
05329 
05330         k1 = *kl + *ku + 2;
05331         k2 = *kl + 1;
05332         k3 = (*kl << 1) + *ku + 1;
05333         k4 = *kl + *ku + 1 + *m;
05334         i__1 = *n;
05335         for (j = 1; j <= i__1; ++j) {
05336 /* Computing MAX */
05337             i__3 = k1 - j;
05338 /* Computing MIN */
05339             i__4 = k3, i__5 = k4 - j;
05340             i__2 = f2cmin(i__4,i__5);
05341             for (i__ = f2cmax(i__3,k2); i__ <= i__2; ++i__) {
05342                 a_ref(i__, j) = a_ref(i__, j) * mul;
05343 /* L140: */
05344             }
05345 /* L150: */
05346         }
05347 
05348     }
05349 
05350     if (! done) {
05351         goto L10;
05352     }
05353 
05354     return 0;
05355 
05356 /*     End of SLASCL */
05357 
05358 } /* slascl_ */
05359 
05360 #undef a_ref
05361 
05362 
05363 
05364 
05365 
05366 /* Subroutine */ int slaset_(const char *uplo, integer *m, integer *n, real *alpha, 
05367         real *beta, real *a, integer *lda)
05368 {
05369 /*  -- LAPACK auxiliary routine (version 3.0) --   
05370        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
05371        Courant Institute, Argonne National Lab, and Rice University   
05372        October 31, 1992   
05373 
05374 
05375     Purpose   
05376     =======   
05377 
05378     SLASET initializes an m-by-n matrix A to BETA on the diagonal and   
05379     ALPHA on the offdiagonals.   
05380 
05381     Arguments   
05382     =========   
05383 
05384     UPLO    (input) CHARACTER*1   
05385             Specifies the part of the matrix A to be set.   
05386             = 'U':      Upper triangular part is set; the strictly lower   
05387                         triangular part of A is not changed.   
05388             = 'L':      Lower triangular part is set; the strictly upper   
05389                         triangular part of A is not changed.   
05390             Otherwise:  All of the matrix A is set.   
05391 
05392     M       (input) INTEGER   
05393             The number of rows of the matrix A.  M >= 0.   
05394 
05395     N       (input) INTEGER   
05396             The number of columns of the matrix A.  N >= 0.   
05397 
05398     ALPHA   (input) REAL   
05399             The constant to which the offdiagonal elements are to be set.   
05400 
05401     BETA    (input) REAL   
05402             The constant to which the diagonal elements are to be set.   
05403 
05404     A       (input/output) REAL array, dimension (LDA,N)   
05405             On exit, the leading m-by-n submatrix of A is set as follows:   
05406 
05407             if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,   
05408             if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,   
05409             otherwise,     A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,   
05410 
05411             and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).   
05412 
05413     LDA     (input) INTEGER   
05414             The leading dimension of the array A.  LDA >= f2cmax(1,M).   
05415 
05416    =====================================================================   
05417 
05418 
05419        Parameter adjustments */
05420     /* System generated locals */
05421     integer a_dim1, a_offset, i__1, i__2, i__3;
05422     /* Local variables */
05423     static integer i__, j;
05424     extern logical lsame_(const char *, const char *);
05425 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
05426 
05427     a_dim1 = *lda;
05428     a_offset = 1 + a_dim1 * 1;
05429     a -= a_offset;
05430 
05431     /* Function Body */
05432     if (lsame_(uplo, "U")) {
05433 
05434 /*        Set the strictly upper triangular or trapezoidal part of the   
05435           array to ALPHA. */
05436 
05437         i__1 = *n;
05438         for (j = 2; j <= i__1; ++j) {
05439 /* Computing MIN */
05440             i__3 = j - 1;
05441             i__2 = f2cmin(i__3,*m);
05442             for (i__ = 1; i__ <= i__2; ++i__) {
05443                 a_ref(i__, j) = *alpha;
05444 /* L10: */
05445             }
05446 /* L20: */
05447         }
05448 
05449     } else if (lsame_(uplo, "L")) {
05450 
05451 /*        Set the strictly lower triangular or trapezoidal part of the   
05452           array to ALPHA. */
05453 
05454         i__1 = f2cmin(*m,*n);
05455         for (j = 1; j <= i__1; ++j) {
05456             i__2 = *m;
05457             for (i__ = j + 1; i__ <= i__2; ++i__) {
05458                 a_ref(i__, j) = *alpha;
05459 /* L30: */
05460             }
05461 /* L40: */
05462         }
05463 
05464     } else {
05465 
05466 /*        Set the leading m-by-n submatrix to ALPHA. */
05467 
05468         i__1 = *n;
05469         for (j = 1; j <= i__1; ++j) {
05470             i__2 = *m;
05471             for (i__ = 1; i__ <= i__2; ++i__) {
05472                 a_ref(i__, j) = *alpha;
05473 /* L50: */
05474             }
05475 /* L60: */
05476         }
05477     }
05478 
05479 /*     Set the first f2cmin(M,N) diagonal elements to BETA. */
05480 
05481     i__1 = f2cmin(*m,*n);
05482     for (i__ = 1; i__ <= i__1; ++i__) {
05483         a_ref(i__, i__) = *beta;
05484 /* L70: */
05485     }
05486 
05487     return 0;
05488 
05489 /*     End of SLASET */
05490 
05491 } /* slaset_ */
05492 
05493 #undef a_ref
05494 
05495 
05496 
05497 
05498 
05499 /* Subroutine */ int slasr_(const char *side, const char *pivot, const char *direct, integer *m,
05500          integer *n, real *c__, real *s, real *a, integer *lda)
05501 {
05502 /*  -- LAPACK auxiliary routine (version 3.0) --   
05503        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
05504        Courant Institute, Argonne National Lab, and Rice University   
05505        October 31, 1992   
05506 
05507 
05508     Purpose   
05509     =======   
05510 
05511     SLASR   performs the transformation   
05512 
05513        A := P*A,   when SIDE = 'L' or 'l'  (  Left-hand side )   
05514 
05515        A := A*P',  when SIDE = 'R' or 'r'  ( Right-hand side )   
05516 
05517     where A is an m by n real matrix and P is an orthogonal matrix,   
05518     consisting of a sequence of plane rotations determined by the   
05519     parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'   
05520     and z = n when SIDE = 'R' or 'r' ):   
05521 
05522     When  DIRECT = 'F' or 'f'  ( Forward sequence ) then   
05523 
05524        P = P( z - 1 )*...*P( 2 )*P( 1 ),   
05525 
05526     and when DIRECT = 'B' or 'b'  ( Backward sequence ) then   
05527 
05528        P = P( 1 )*P( 2 )*...*P( z - 1 ),   
05529 
05530     where  P( k ) is a plane rotation matrix for the following planes:   
05531 
05532        when  PIVOT = 'V' or 'v'  ( Variable pivot ),   
05533           the plane ( k, k + 1 )   
05534 
05535        when  PIVOT = 'T' or 't'  ( Top pivot ),   
05536           the plane ( 1, k + 1 )   
05537 
05538        when  PIVOT = 'B' or 'b'  ( Bottom pivot ),   
05539           the plane ( k, z )   
05540 
05541     c( k ) and s( k )  must contain the  cosine and sine that define the   
05542     matrix  P( k ).  The two by two plane rotation part of the matrix   
05543     P( k ), R( k ), is assumed to be of the form   
05544 
05545        R( k ) = (  c( k )  s( k ) ).   
05546                 ( -s( k )  c( k ) )   
05547 
05548     This version vectorises across rows of the array A when SIDE = 'L'.   
05549 
05550     Arguments   
05551     =========   
05552 
05553     SIDE    (input) CHARACTER*1   
05554             Specifies whether the plane rotation matrix P is applied to   
05555             A on the left or the right.   
05556             = 'L':  Left, compute A := P*A   
05557             = 'R':  Right, compute A:= A*P'   
05558 
05559     DIRECT  (input) CHARACTER*1   
05560             Specifies whether P is a forward or backward sequence of   
05561             plane rotations.   
05562             = 'F':  Forward, P = P( z - 1 )*...*P( 2 )*P( 1 )   
05563             = 'B':  Backward, P = P( 1 )*P( 2 )*...*P( z - 1 )   
05564 
05565     PIVOT   (input) CHARACTER*1   
05566             Specifies the plane for which P(k) is a plane rotation   
05567             matrix.   
05568             = 'V':  Variable pivot, the plane (k,k+1)   
05569             = 'T':  Top pivot, the plane (1,k+1)   
05570             = 'B':  Bottom pivot, the plane (k,z)   
05571 
05572     M       (input) INTEGER   
05573             The number of rows of the matrix A.  If m <= 1, an immediate   
05574             return is effected.   
05575 
05576     N       (input) INTEGER   
05577             The number of columns of the matrix A.  If n <= 1, an   
05578             immediate return is effected.   
05579 
05580     C, S    (input) REAL arrays, dimension   
05581                     (M-1) if SIDE = 'L'   
05582                     (N-1) if SIDE = 'R'   
05583             c(k) and s(k) contain the cosine and sine that define the   
05584             matrix P(k).  The two by two plane rotation part of the   
05585             matrix P(k), R(k), is assumed to be of the form   
05586             R( k ) = (  c( k )  s( k ) ).   
05587                      ( -s( k )  c( k ) )   
05588 
05589     A       (input/output) REAL array, dimension (LDA,N)   
05590             The m by n matrix A.  On exit, A is overwritten by P*A if   
05591             SIDE = 'R' or by A*P' if SIDE = 'L'.   
05592 
05593     LDA     (input) INTEGER   
05594             The leading dimension of the array A.  LDA >= f2cmax(1,M).   
05595 
05596     =====================================================================   
05597 
05598 
05599        Test the input parameters   
05600 
05601        Parameter adjustments */
05602     /* System generated locals */
05603     integer a_dim1, a_offset, i__1, i__2;
05604     /* Local variables */
05605     static integer info;
05606     static real temp;
05607     static integer i__, j;
05608     extern logical lsame_(const char *, const char *);
05609     static real ctemp, stemp;
05610     extern /* Subroutine */ int xerbla_(const char *, integer *);
05611 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
05612 
05613     --c__;
05614     --s;
05615     a_dim1 = *lda;
05616     a_offset = 1 + a_dim1 * 1;
05617     a -= a_offset;
05618 
05619     /* Function Body */
05620     info = 0;
05621     if (! (lsame_(side, "L") || lsame_(side, "R"))) {
05622         info = 1;
05623     } else if (! (lsame_(pivot, "V") || lsame_(pivot, 
05624             "T") || lsame_(pivot, "B"))) {
05625         info = 2;
05626     } else if (! (lsame_(direct, "F") || lsame_(direct, 
05627             "B"))) {
05628         info = 3;
05629     } else if (*m < 0) {
05630         info = 4;
05631     } else if (*n < 0) {
05632         info = 5;
05633     } else if (*lda < f2cmax(1,*m)) {
05634         info = 9;
05635     }
05636     if (info != 0) {
05637         xerbla_("SLASR ", &info);
05638         return 0;
05639     }
05640 
05641 /*     Quick return if possible */
05642 
05643     if (*m == 0 || *n == 0) {
05644         return 0;
05645     }
05646     if (lsame_(side, "L")) {
05647 
05648 /*        Form  P * A */
05649 
05650         if (lsame_(pivot, "V")) {
05651             if (lsame_(direct, "F")) {
05652                 i__1 = *m - 1;
05653                 for (j = 1; j <= i__1; ++j) {
05654                     ctemp = c__[j];
05655                     stemp = s[j];
05656                     if (ctemp != 1.f || stemp != 0.f) {
05657                         i__2 = *n;
05658                         for (i__ = 1; i__ <= i__2; ++i__) {
05659                             temp = a_ref(j + 1, i__);
05660                             a_ref(j + 1, i__) = ctemp * temp - stemp * a_ref(
05661                                     j, i__);
05662                             a_ref(j, i__) = stemp * temp + ctemp * a_ref(j, 
05663                                     i__);
05664 /* L10: */
05665                         }
05666                     }
05667 /* L20: */
05668                 }
05669             } else if (lsame_(direct, "B")) {
05670                 for (j = *m - 1; j >= 1; --j) {
05671                     ctemp = c__[j];
05672                     stemp = s[j];
05673                     if (ctemp != 1.f || stemp != 0.f) {
05674                         i__1 = *n;
05675                         for (i__ = 1; i__ <= i__1; ++i__) {
05676                             temp = a_ref(j + 1, i__);
05677                             a_ref(j + 1, i__) = ctemp * temp - stemp * a_ref(
05678                                     j, i__);
05679                             a_ref(j, i__) = stemp * temp + ctemp * a_ref(j, 
05680                                     i__);
05681 /* L30: */
05682                         }
05683                     }
05684 /* L40: */
05685                 }
05686             }
05687         } else if (lsame_(pivot, "T")) {
05688             if (lsame_(direct, "F")) {
05689                 i__1 = *m;
05690                 for (j = 2; j <= i__1; ++j) {
05691                     ctemp = c__[j - 1];
05692                     stemp = s[j - 1];
05693                     if (ctemp != 1.f || stemp != 0.f) {
05694                         i__2 = *n;
05695                         for (i__ = 1; i__ <= i__2; ++i__) {
05696                             temp = a_ref(j, i__);
05697                             a_ref(j, i__) = ctemp * temp - stemp * a_ref(1, 
05698                                     i__);
05699                             a_ref(1, i__) = stemp * temp + ctemp * a_ref(1, 
05700                                     i__);
05701 /* L50: */
05702                         }
05703                     }
05704 /* L60: */
05705                 }
05706             } else if (lsame_(direct, "B")) {
05707                 for (j = *m; j >= 2; --j) {
05708                     ctemp = c__[j - 1];
05709                     stemp = s[j - 1];
05710                     if (ctemp != 1.f || stemp != 0.f) {
05711                         i__1 = *n;
05712                         for (i__ = 1; i__ <= i__1; ++i__) {
05713                             temp = a_ref(j, i__);
05714                             a_ref(j, i__) = ctemp * temp - stemp * a_ref(1, 
05715                                     i__);
05716                             a_ref(1, i__) = stemp * temp + ctemp * a_ref(1, 
05717                                     i__);
05718 /* L70: */
05719                         }
05720                     }
05721 /* L80: */
05722                 }
05723             }
05724         } else if (lsame_(pivot, "B")) {
05725             if (lsame_(direct, "F")) {
05726                 i__1 = *m - 1;
05727                 for (j = 1; j <= i__1; ++j) {
05728                     ctemp = c__[j];
05729                     stemp = s[j];
05730                     if (ctemp != 1.f || stemp != 0.f) {
05731                         i__2 = *n;
05732                         for (i__ = 1; i__ <= i__2; ++i__) {
05733                             temp = a_ref(j, i__);
05734                             a_ref(j, i__) = stemp * a_ref(*m, i__) + ctemp * 
05735                                     temp;
05736                             a_ref(*m, i__) = ctemp * a_ref(*m, i__) - stemp * 
05737                                     temp;
05738 /* L90: */
05739                         }
05740                     }
05741 /* L100: */
05742                 }
05743             } else if (lsame_(direct, "B")) {
05744                 for (j = *m - 1; j >= 1; --j) {
05745                     ctemp = c__[j];
05746                     stemp = s[j];
05747                     if (ctemp != 1.f || stemp != 0.f) {
05748                         i__1 = *n;
05749                         for (i__ = 1; i__ <= i__1; ++i__) {
05750                             temp = a_ref(j, i__);
05751                             a_ref(j, i__) = stemp * a_ref(*m, i__) + ctemp * 
05752                                     temp;
05753                             a_ref(*m, i__) = ctemp * a_ref(*m, i__) - stemp * 
05754                                     temp;
05755 /* L110: */
05756                         }
05757                     }
05758 /* L120: */
05759                 }
05760             }
05761         }
05762     } else if (lsame_(side, "R")) {
05763 
05764 /*        Form A * P' */
05765 
05766         if (lsame_(pivot, "V")) {
05767             if (lsame_(direct, "F")) {
05768                 i__1 = *n - 1;
05769                 for (j = 1; j <= i__1; ++j) {
05770                     ctemp = c__[j];
05771                     stemp = s[j];
05772                     if (ctemp != 1.f || stemp != 0.f) {
05773                         i__2 = *m;
05774                         for (i__ = 1; i__ <= i__2; ++i__) {
05775                             temp = a_ref(i__, j + 1);
05776                             a_ref(i__, j + 1) = ctemp * temp - stemp * a_ref(
05777                                     i__, j);
05778                             a_ref(i__, j) = stemp * temp + ctemp * a_ref(i__, 
05779                                     j);
05780 /* L130: */
05781                         }
05782                     }
05783 /* L140: */
05784                 }
05785             } else if (lsame_(direct, "B")) {
05786                 for (j = *n - 1; j >= 1; --j) {
05787                     ctemp = c__[j];
05788                     stemp = s[j];
05789                     if (ctemp != 1.f || stemp != 0.f) {
05790                         i__1 = *m;
05791                         for (i__ = 1; i__ <= i__1; ++i__) {
05792                             temp = a_ref(i__, j + 1);
05793                             a_ref(i__, j + 1) = ctemp * temp - stemp * a_ref(
05794                                     i__, j);
05795                             a_ref(i__, j) = stemp * temp + ctemp * a_ref(i__, 
05796                                     j);
05797 /* L150: */
05798                         }
05799                     }
05800 /* L160: */
05801                 }
05802             }
05803         } else if (lsame_(pivot, "T")) {
05804             if (lsame_(direct, "F")) {
05805                 i__1 = *n;
05806                 for (j = 2; j <= i__1; ++j) {
05807                     ctemp = c__[j - 1];
05808                     stemp = s[j - 1];
05809                     if (ctemp != 1.f || stemp != 0.f) {
05810                         i__2 = *m;
05811                         for (i__ = 1; i__ <= i__2; ++i__) {
05812                             temp = a_ref(i__, j);
05813                             a_ref(i__, j) = ctemp * temp - stemp * a_ref(i__, 
05814                                     1);
05815                             a_ref(i__, 1) = stemp * temp + ctemp * a_ref(i__, 
05816                                     1);
05817 /* L170: */
05818                         }
05819                     }
05820 /* L180: */
05821                 }
05822             } else if (lsame_(direct, "B")) {
05823                 for (j = *n; j >= 2; --j) {
05824                     ctemp = c__[j - 1];
05825                     stemp = s[j - 1];
05826                     if (ctemp != 1.f || stemp != 0.f) {
05827                         i__1 = *m;
05828                         for (i__ = 1; i__ <= i__1; ++i__) {
05829                             temp = a_ref(i__, j);
05830                             a_ref(i__, j) = ctemp * temp - stemp * a_ref(i__, 
05831                                     1);
05832                             a_ref(i__, 1) = stemp * temp + ctemp * a_ref(i__, 
05833                                     1);
05834 /* L190: */
05835                         }
05836                     }
05837 /* L200: */
05838                 }
05839             }
05840         } else if (lsame_(pivot, "B")) {
05841             if (lsame_(direct, "F")) {
05842                 i__1 = *n - 1;
05843                 for (j = 1; j <= i__1; ++j) {
05844                     ctemp = c__[j];
05845                     stemp = s[j];
05846                     if (ctemp != 1.f || stemp != 0.f) {
05847                         i__2 = *m;
05848                         for (i__ = 1; i__ <= i__2; ++i__) {
05849                             temp = a_ref(i__, j);
05850                             a_ref(i__, j) = stemp * a_ref(i__, *n) + ctemp * 
05851                                     temp;
05852                             a_ref(i__, *n) = ctemp * a_ref(i__, *n) - stemp * 
05853                                     temp;
05854 /* L210: */
05855                         }
05856                     }
05857 /* L220: */
05858                 }
05859             } else if (lsame_(direct, "B")) {
05860                 for (j = *n - 1; j >= 1; --j) {
05861                     ctemp = c__[j];
05862                     stemp = s[j];
05863                     if (ctemp != 1.f || stemp != 0.f) {
05864                         i__1 = *m;
05865                         for (i__ = 1; i__ <= i__1; ++i__) {
05866                             temp = a_ref(i__, j);
05867                             a_ref(i__, j) = stemp * a_ref(i__, *n) + ctemp * 
05868                                     temp;
05869                             a_ref(i__, *n) = ctemp * a_ref(i__, *n) - stemp * 
05870                                     temp;
05871 /* L230: */
05872                         }
05873                     }
05874 /* L240: */
05875                 }
05876             }
05877         }
05878     }
05879 
05880     return 0;
05881 
05882 /*     End of SLASR */
05883 
05884 } /* slasr_ */
05885 
05886 #undef a_ref
05887 
05888 
05889 
05890 
05891 
05892 /* Subroutine */ int slasrt_(const char *id, integer *n, real *d__, integer *info)
05893 {
05894 /*  -- LAPACK routine (version 3.0) --   
05895        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
05896        Courant Institute, Argonne National Lab, and Rice University   
05897        September 30, 1994   
05898 
05899 
05900     Purpose   
05901     =======   
05902 
05903     Sort the numbers in D in increasing order (if ID = 'I') or   
05904     in decreasing order (if ID = 'D' ).   
05905 
05906     Use Quick Sort, reverting to Insertion sort on arrays of   
05907     size <= 20. Dimension of STACK limits N to about 2**32.   
05908 
05909     Arguments   
05910     =========   
05911 
05912     ID      (input) CHARACTER*1   
05913             = 'I': sort D in increasing order;   
05914             = 'D': sort D in decreasing order.   
05915 
05916     N       (input) INTEGER   
05917             The length of the array D.   
05918 
05919     D       (input/output) REAL array, dimension (N)   
05920             On entry, the array to be sorted.   
05921             On exit, D has been sorted into increasing order   
05922             (D(1) <= ... <= D(N) ) or into decreasing order   
05923             (D(1) >= ... >= D(N) ), depending on ID.   
05924 
05925     INFO    (output) INTEGER   
05926             = 0:  successful exit   
05927             < 0:  if INFO = -i, the i-th argument had an illegal value   
05928 
05929     =====================================================================   
05930 
05931 
05932        Test the input paramters.   
05933 
05934        Parameter adjustments */
05935     /* System generated locals */
05936     integer i__1, i__2;
05937     /* Local variables */
05938     static integer endd, i__, j;
05939     extern logical lsame_(const char *, const char *);
05940     static integer stack[64]    /* was [2][32] */;
05941     static real dmnmx, d1, d2, d3;
05942     static integer start;
05943     extern /* Subroutine */ int xerbla_(const char *, integer *);
05944     static integer stkpnt, dir;
05945     static real tmp;
05946 #define stack_ref(a_1,a_2) stack[(a_2)*2 + a_1 - 3]
05947 
05948     --d__;
05949 
05950     /* Function Body */
05951     *info = 0;
05952     dir = -1;
05953     if (lsame_(id, "D")) {
05954         dir = 0;
05955     } else if (lsame_(id, "I")) {
05956         dir = 1;
05957     }
05958     if (dir == -1) {
05959         *info = -1;
05960     } else if (*n < 0) {
05961         *info = -2;
05962     }
05963     if (*info != 0) {
05964         i__1 = -(*info);
05965         xerbla_("SLASRT", &i__1);
05966         return 0;
05967     }
05968 
05969 /*     Quick return if possible */
05970 
05971     if (*n <= 1) {
05972         return 0;
05973     }
05974 
05975     stkpnt = 1;
05976     stack_ref(1, 1) = 1;
05977     stack_ref(2, 1) = *n;
05978 L10:
05979     start = stack_ref(1, stkpnt);
05980     endd = stack_ref(2, stkpnt);
05981     --stkpnt;
05982     if (endd - start <= 20 && endd - start > 0) {
05983 
05984 /*        Do Insertion sort on D( START:ENDD ) */
05985 
05986         if (dir == 0) {
05987 
05988 /*           Sort into decreasing order */
05989 
05990             i__1 = endd;
05991             for (i__ = start + 1; i__ <= i__1; ++i__) {
05992                 i__2 = start + 1;
05993                 for (j = i__; j >= i__2; --j) {
05994                     if (d__[j] > d__[j - 1]) {
05995                         dmnmx = d__[j];
05996                         d__[j] = d__[j - 1];
05997                         d__[j - 1] = dmnmx;
05998                     } else {
05999                         goto L30;
06000                     }
06001 /* L20: */
06002                 }
06003 L30:
06004                 ;
06005             }
06006 
06007         } else {
06008 
06009 /*           Sort into increasing order */
06010 
06011             i__1 = endd;
06012             for (i__ = start + 1; i__ <= i__1; ++i__) {
06013                 i__2 = start + 1;
06014                 for (j = i__; j >= i__2; --j) {
06015                     if (d__[j] < d__[j - 1]) {
06016                         dmnmx = d__[j];
06017                         d__[j] = d__[j - 1];
06018                         d__[j - 1] = dmnmx;
06019                     } else {
06020                         goto L50;
06021                     }
06022 /* L40: */
06023                 }
06024 L50:
06025                 ;
06026             }
06027 
06028         }
06029 
06030     } else if (endd - start > 20) {
06031 
06032 /*        Partition D( START:ENDD ) and stack parts, largest one first   
06033 
06034           Choose partition entry as median of 3 */
06035 
06036         d1 = d__[start];
06037         d2 = d__[endd];
06038         i__ = (start + endd) / 2;
06039         d3 = d__[i__];
06040         if (d1 < d2) {
06041             if (d3 < d1) {
06042                 dmnmx = d1;
06043             } else if (d3 < d2) {
06044                 dmnmx = d3;
06045             } else {
06046                 dmnmx = d2;
06047             }
06048         } else {
06049             if (d3 < d2) {
06050                 dmnmx = d2;
06051             } else if (d3 < d1) {
06052                 dmnmx = d3;
06053             } else {
06054                 dmnmx = d1;
06055             }
06056         }
06057 
06058         if (dir == 0) {
06059 
06060 /*           Sort into decreasing order */
06061 
06062             i__ = start - 1;
06063             j = endd + 1;
06064 L60:
06065 L70:
06066             --j;
06067             if (d__[j] < dmnmx) {
06068                 goto L70;
06069             }
06070 L80:
06071             ++i__;
06072             if (d__[i__] > dmnmx) {
06073                 goto L80;
06074             }
06075             if (i__ < j) {
06076                 tmp = d__[i__];
06077                 d__[i__] = d__[j];
06078                 d__[j] = tmp;
06079                 goto L60;
06080             }
06081             if (j - start > endd - j - 1) {
06082                 ++stkpnt;
06083                 stack_ref(1, stkpnt) = start;
06084                 stack_ref(2, stkpnt) = j;
06085                 ++stkpnt;
06086                 stack_ref(1, stkpnt) = j + 1;
06087                 stack_ref(2, stkpnt) = endd;
06088             } else {
06089                 ++stkpnt;
06090                 stack_ref(1, stkpnt) = j + 1;
06091                 stack_ref(2, stkpnt) = endd;
06092                 ++stkpnt;
06093                 stack_ref(1, stkpnt) = start;
06094                 stack_ref(2, stkpnt) = j;
06095             }
06096         } else {
06097 
06098 /*           Sort into increasing order */
06099 
06100             i__ = start - 1;
06101             j = endd + 1;
06102 L90:
06103 L100:
06104             --j;
06105             if (d__[j] > dmnmx) {
06106                 goto L100;
06107             }
06108 L110:
06109             ++i__;
06110             if (d__[i__] < dmnmx) {
06111                 goto L110;
06112             }
06113             if (i__ < j) {
06114                 tmp = d__[i__];
06115                 d__[i__] = d__[j];
06116                 d__[j] = tmp;
06117                 goto L90;
06118             }
06119             if (j - start > endd - j - 1) {
06120                 ++stkpnt;
06121                 stack_ref(1, stkpnt) = start;
06122                 stack_ref(2, stkpnt) = j;
06123                 ++stkpnt;
06124                 stack_ref(1, stkpnt) = j + 1;
06125                 stack_ref(2, stkpnt) = endd;
06126             } else {
06127                 ++stkpnt;
06128                 stack_ref(1, stkpnt) = j + 1;
06129                 stack_ref(2, stkpnt) = endd;
06130                 ++stkpnt;
06131                 stack_ref(1, stkpnt) = start;
06132                 stack_ref(2, stkpnt) = j;
06133             }
06134         }
06135     }
06136     if (stkpnt > 0) {
06137         goto L10;
06138     }
06139     return 0;
06140 
06141 /*     End of SLASRT */
06142 
06143 } /* slasrt_ */
06144 
06145 #undef stack_ref
06146 
06147 
06148 
06149 
06150 
06151 /* Subroutine */ int slassq_(integer *n, real *x, integer *incx, real *scale, 
06152         real *sumsq)
06153 {
06154 /*  -- LAPACK auxiliary routine (version 3.0) --   
06155        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
06156        Courant Institute, Argonne National Lab, and Rice University   
06157        June 30, 1999   
06158 
06159 
06160     Purpose   
06161     =======   
06162 
06163     SLASSQ  returns the values  scl  and  smsq  such that   
06164 
06165        ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,   
06166 
06167     where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is   
06168     assumed to be non-negative and  scl  returns the value   
06169 
06170        scl = f2cmax( scale, abs( x( i ) ) ).   
06171 
06172     scale and sumsq must be supplied in SCALE and SUMSQ and   
06173     scl and smsq are overwritten on SCALE and SUMSQ respectively.   
06174 
06175     The routine makes only one pass through the vector x.   
06176 
06177     Arguments   
06178     =========   
06179 
06180     N       (input) INTEGER   
06181             The number of elements to be used from the vector X.   
06182 
06183     X       (input) REAL array, dimension (N)   
06184             The vector for which a scaled sum of squares is computed.   
06185                x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.   
06186 
06187     INCX    (input) INTEGER   
06188             The increment between successive values of the vector X.   
06189             INCX > 0.   
06190 
06191     SCALE   (input/output) REAL   
06192             On entry, the value  scale  in the equation above.   
06193             On exit, SCALE is overwritten with  scl , the scaling factor   
06194             for the sum of squares.   
06195 
06196     SUMSQ   (input/output) REAL   
06197             On entry, the value  sumsq  in the equation above.   
06198             On exit, SUMSQ is overwritten with  smsq , the basic sum of   
06199             squares from which  scl  has been factored out.   
06200 
06201    =====================================================================   
06202 
06203 
06204        Parameter adjustments */
06205     /* System generated locals */
06206     integer i__1, i__2;
06207     real r__1;
06208     /* Local variables */
06209     static real absxi;
06210     static integer ix;
06211 
06212     --x;
06213 
06214     /* Function Body */
06215     if (*n > 0) {
06216         i__1 = (*n - 1) * *incx + 1;
06217         i__2 = *incx;
06218         for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
06219             if (x[ix] != 0.f) {
06220                 absxi = (r__1 = x[ix], dabs(r__1));
06221                 if (*scale < absxi) {
06222 /* Computing 2nd power */
06223                     r__1 = *scale / absxi;
06224                     *sumsq = *sumsq * (r__1 * r__1) + 1;
06225                     *scale = absxi;
06226                 } else {
06227 /* Computing 2nd power */
06228                     r__1 = absxi / *scale;
06229                     *sumsq += r__1 * r__1;
06230                 }
06231             }
06232 /* L10: */
06233         }
06234     }
06235     return 0;
06236 
06237 /*     End of SLASSQ */
06238 
06239 } /* slassq_ */
06240 
06241 
06242 
06243 
06244 /* Subroutine */ int slatrd_(char *uplo, integer *n, integer *nb, real *a, 
06245         integer *lda, real *e, real *tau, real *w, integer *ldw)
06246 {
06247 /*  -- LAPACK auxiliary routine (version 3.0) --   
06248        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
06249        Courant Institute, Argonne National Lab, and Rice University   
06250        October 31, 1992   
06251 
06252 
06253     Purpose   
06254     =======   
06255 
06256     SLATRD reduces NB rows and columns of a real symmetric matrix A to   
06257     symmetric tridiagonal form by an orthogonal similarity   
06258     transformation Q' * A * Q, and returns the matrices V and W which are   
06259     needed to apply the transformation to the unreduced part of A.   
06260 
06261     If UPLO = 'U', SLATRD reduces the last NB rows and columns of a   
06262     matrix, of which the upper triangle is supplied;   
06263     if UPLO = 'L', SLATRD reduces the first NB rows and columns of a   
06264     matrix, of which the lower triangle is supplied.   
06265 
06266     This is an auxiliary routine called by SSYTRD.   
06267 
06268     Arguments   
06269     =========   
06270 
06271     UPLO    (input) CHARACTER   
06272             Specifies whether the upper or lower triangular part of the   
06273             symmetric matrix A is stored:   
06274             = 'U': Upper triangular   
06275             = 'L': Lower triangular   
06276 
06277     N       (input) INTEGER   
06278             The order of the matrix A.   
06279 
06280     NB      (input) INTEGER   
06281             The number of rows and columns to be reduced.   
06282 
06283     A       (input/output) REAL array, dimension (LDA,N)   
06284             On entry, the symmetric matrix A.  If UPLO = 'U', the leading   
06285             n-by-n upper triangular part of A contains the upper   
06286             triangular part of the matrix A, and the strictly lower   
06287             triangular part of A is not referenced.  If UPLO = 'L', the   
06288             leading n-by-n lower triangular part of A contains the lower   
06289             triangular part of the matrix A, and the strictly upper   
06290             triangular part of A is not referenced.   
06291             On exit:   
06292             if UPLO = 'U', the last NB columns have been reduced to   
06293               tridiagonal form, with the diagonal elements overwriting   
06294               the diagonal elements of A; the elements above the diagonal   
06295               with the array TAU, represent the orthogonal matrix Q as a   
06296               product of elementary reflectors;   
06297             if UPLO = 'L', the first NB columns have been reduced to   
06298               tridiagonal form, with the diagonal elements overwriting   
06299               the diagonal elements of A; the elements below the diagonal   
06300               with the array TAU, represent the  orthogonal matrix Q as a   
06301               product of elementary reflectors.   
06302             See Further Details.   
06303 
06304     LDA     (input) INTEGER   
06305             The leading dimension of the array A.  LDA >= (1,N).   
06306 
06307     E       (output) REAL array, dimension (N-1)   
06308             If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal   
06309             elements of the last NB columns of the reduced matrix;   
06310             if UPLO = 'L', E(1:nb) contains the subdiagonal elements of   
06311             the first NB columns of the reduced matrix.   
06312 
06313     TAU     (output) REAL array, dimension (N-1)   
06314             The scalar factors of the elementary reflectors, stored in   
06315             TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.   
06316             See Further Details.   
06317 
06318     W       (output) REAL array, dimension (LDW,NB)   
06319             The n-by-nb matrix W required to update the unreduced part   
06320             of A.   
06321 
06322     LDW     (input) INTEGER   
06323             The leading dimension of the array W. LDW >= f2cmax(1,N).   
06324 
06325     Further Details   
06326     ===============   
06327 
06328     If UPLO = 'U', the matrix Q is represented as a product of elementary   
06329     reflectors   
06330 
06331        Q = H(n) H(n-1) . . . H(n-nb+1).   
06332 
06333     Each H(i) has the form   
06334 
06335        H(i) = I - tau * v * v'   
06336 
06337     where tau is a real scalar, and v is a real vector with   
06338     v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),   
06339     and tau in TAU(i-1).   
06340 
06341     If UPLO = 'L', the matrix Q is represented as a product of elementary   
06342     reflectors   
06343 
06344        Q = H(1) H(2) . . . H(nb).   
06345 
06346     Each H(i) has the form   
06347 
06348        H(i) = I - tau * v * v'   
06349 
06350     where tau is a real scalar, and v is a real vector with   
06351     v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),   
06352     and tau in TAU(i).   
06353 
06354     The elements of the vectors v together form the n-by-nb matrix V   
06355     which is needed, with W, to apply the transformation to the unreduced   
06356     part of the matrix, using a symmetric rank-2k update of the form:   
06357     A := A - V*W' - W*V'.   
06358 
06359     The contents of A on exit are illustrated by the following examples   
06360     with n = 5 and nb = 2:   
06361 
06362     if UPLO = 'U':                       if UPLO = 'L':   
06363 
06364       (  a   a   a   v4  v5 )              (  d                  )   
06365       (      a   a   v4  v5 )              (  1   d              )   
06366       (          a   1   v5 )              (  v1  1   a          )   
06367       (              d   1  )              (  v1  v2  a   a      )   
06368       (                  d  )              (  v1  v2  a   a   a  )   
06369 
06370     where d denotes a diagonal element of the reduced matrix, a denotes   
06371     an element of the original matrix that is unchanged, and vi denotes   
06372     an element of the vector defining H(i).   
06373 
06374     =====================================================================   
06375 
06376 
06377        Quick return if possible   
06378 
06379        Parameter adjustments */
06380     /* Table of constant values */
06381     static real c_b5 = -1.f;
06382     static real c_b6 = 1.f;
06383     static integer c__1 = 1;
06384     static real c_b16 = 0.f;
06385     
06386     /* System generated locals */
06387     integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
06388     /* Local variables */
06389     extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
06390     static integer i__;
06391     static real alpha;
06392     extern logical lsame_(const char *, const char *);
06393     extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
06394             sgemv_(const char *, integer *, integer *, real *, real *, integer *, 
06395             real *, integer *, real *, real *, integer *), saxpy_(
06396             integer *, real *, real *, integer *, real *, integer *), ssymv_(
06397             const char *, integer *, real *, real *, integer *, real *, integer *, 
06398             real *, real *, integer *);
06399     static integer iw;
06400     extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, 
06401             real *);
06402 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
06403 #define w_ref(a_1,a_2) w[(a_2)*w_dim1 + a_1]
06404 
06405 
06406     a_dim1 = *lda;
06407     a_offset = 1 + a_dim1 * 1;
06408     a -= a_offset;
06409     --e;
06410     --tau;
06411     w_dim1 = *ldw;
06412     w_offset = 1 + w_dim1 * 1;
06413     w -= w_offset;
06414 
06415     /* Function Body */
06416     if (*n <= 0) {
06417         return 0;
06418     }
06419 
06420     if (lsame_(uplo, "U")) {
06421 
06422 /*        Reduce last NB columns of upper triangle */
06423 
06424         i__1 = *n - *nb + 1;
06425         for (i__ = *n; i__ >= i__1; --i__) {
06426             iw = i__ - *n + *nb;
06427             if (i__ < *n) {
06428 
06429 /*              Update A(1:i,i) */
06430 
06431                 i__2 = *n - i__;
06432                 sgemv_("No transpose", &i__, &i__2, &c_b5, &a_ref(1, i__ + 1),
06433                          lda, &w_ref(i__, iw + 1), ldw, &c_b6, &a_ref(1, i__),
06434                          &c__1);
06435                 i__2 = *n - i__;
06436                 sgemv_("No transpose", &i__, &i__2, &c_b5, &w_ref(1, iw + 1), 
06437                         ldw, &a_ref(i__, i__ + 1), lda, &c_b6, &a_ref(1, i__),
06438                          &c__1);
06439             }
06440             if (i__ > 1) {
06441 
06442 /*              Generate elementary reflector H(i) to annihilate   
06443                 A(1:i-2,i) */
06444 
06445                 i__2 = i__ - 1;
06446                 slarfg_(&i__2, &a_ref(i__ - 1, i__), &a_ref(1, i__), &c__1, &
06447                         tau[i__ - 1]);
06448                 e[i__ - 1] = a_ref(i__ - 1, i__);
06449                 a_ref(i__ - 1, i__) = 1.f;
06450 
06451 /*              Compute W(1:i-1,i) */
06452 
06453                 i__2 = i__ - 1;
06454                 ssymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a_ref(1, 
06455                         i__), &c__1, &c_b16, &w_ref(1, iw), &c__1);
06456                 if (i__ < *n) {
06457                     i__2 = i__ - 1;
06458                     i__3 = *n - i__;
06459                     sgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(1, iw + 1)
06460                             , ldw, &a_ref(1, i__), &c__1, &c_b16, &w_ref(i__ 
06461                             + 1, iw), &c__1);
06462                     i__2 = i__ - 1;
06463                     i__3 = *n - i__;
06464                     sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__ 
06465                             + 1), lda, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
06466                             w_ref(1, iw), &c__1);
06467                     i__2 = i__ - 1;
06468                     i__3 = *n - i__;
06469                     sgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(1, i__ + 
06470                             1), lda, &a_ref(1, i__), &c__1, &c_b16, &w_ref(
06471                             i__ + 1, iw), &c__1);
06472                     i__2 = i__ - 1;
06473                     i__3 = *n - i__;
06474                     sgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(1, iw 
06475                             + 1), ldw, &w_ref(i__ + 1, iw), &c__1, &c_b6, &
06476                             w_ref(1, iw), &c__1);
06477                 }
06478                 i__2 = i__ - 1;
06479                 sscal_(&i__2, &tau[i__ - 1], &w_ref(1, iw), &c__1);
06480                 i__2 = i__ - 1;
06481                 alpha = tau[i__ - 1] * -.5f * sdot_(&i__2, &w_ref(1, iw), &
06482                         c__1, &a_ref(1, i__), &c__1);
06483                 i__2 = i__ - 1;
06484                 saxpy_(&i__2, &alpha, &a_ref(1, i__), &c__1, &w_ref(1, iw), &
06485                         c__1);
06486             }
06487 
06488 /* L10: */
06489         }
06490     } else {
06491 
06492 /*        Reduce first NB columns of lower triangle */
06493 
06494         i__1 = *nb;
06495         for (i__ = 1; i__ <= i__1; ++i__) {
06496 
06497 /*           Update A(i:n,i) */
06498 
06499             i__2 = *n - i__ + 1;
06500             i__3 = i__ - 1;
06501             sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__, 1), lda, &
06502                     w_ref(i__, 1), ldw, &c_b6, &a_ref(i__, i__), &c__1);
06503             i__2 = *n - i__ + 1;
06504             i__3 = i__ - 1;
06505             sgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__, 1), ldw, &
06506                     a_ref(i__, 1), lda, &c_b6, &a_ref(i__, i__), &c__1);
06507             if (i__ < *n) {
06508 
06509 /*              Generate elementary reflector H(i) to annihilate   
06510                 A(i+2:n,i)   
06511 
06512    Computing MIN */
06513                 i__2 = i__ + 2;
06514                 i__3 = *n - i__;
06515                 slarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(f2cmin(i__2,*n), i__)
06516                         , &c__1, &tau[i__]);
06517                 e[i__] = a_ref(i__ + 1, i__);
06518                 a_ref(i__ + 1, i__) = 1.f;
06519 
06520 /*              Compute W(i+1:n,i) */
06521 
06522                 i__2 = *n - i__;
06523                 ssymv_("Lower", &i__2, &c_b6, &a_ref(i__ + 1, i__ + 1), lda, &
06524                         a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(i__ + 1, 
06525                         i__), &c__1);
06526                 i__2 = *n - i__;
06527                 i__3 = i__ - 1;
06528                 sgemv_("Transpose", &i__2, &i__3, &c_b6, &w_ref(i__ + 1, 1), 
06529                         ldw, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1, 
06530                         i__), &c__1);
06531                 i__2 = *n - i__;
06532                 i__3 = i__ - 1;
06533                 sgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, 1)
06534                         , lda, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1, 
06535                         i__), &c__1);
06536                 i__2 = *n - i__;
06537                 i__3 = i__ - 1;
06538                 sgemv_("Transpose", &i__2, &i__3, &c_b6, &a_ref(i__ + 1, 1), 
06539                         lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &w_ref(1, 
06540                         i__), &c__1);
06541                 i__2 = *n - i__;
06542                 i__3 = i__ - 1;
06543                 sgemv_("No transpose", &i__2, &i__3, &c_b5, &w_ref(i__ + 1, 1)
06544                         , ldw, &w_ref(1, i__), &c__1, &c_b6, &w_ref(i__ + 1, 
06545                         i__), &c__1);
06546                 i__2 = *n - i__;
06547                 sscal_(&i__2, &tau[i__], &w_ref(i__ + 1, i__), &c__1);
06548                 i__2 = *n - i__;
06549                 alpha = tau[i__] * -.5f * sdot_(&i__2, &w_ref(i__ + 1, i__), &
06550                         c__1, &a_ref(i__ + 1, i__), &c__1);
06551                 i__2 = *n - i__;
06552                 saxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &w_ref(i__ 
06553                         + 1, i__), &c__1);
06554             }
06555 
06556 /* L20: */
06557         }
06558     }
06559 
06560     return 0;
06561 
06562 /*     End of SLATRD */
06563 
06564 } /* slatrd_ */
06565 
06566 #undef w_ref
06567 #undef a_ref
06568 
06569 
06570 
06571 
06572 
06573 doublereal snrm2_(integer *n, real *x, integer *incx)
06574 {
06575 /*        The following loop is equivalent to this call to the LAPACK   
06576           auxiliary routine:   
06577           CALL SLASSQ( N, X, INCX, SCALE, SSQ ) */
06578     /* System generated locals */
06579     integer i__1, i__2;
06580     real ret_val, r__1;
06581     /* Builtin functions */
06582 //    double sqrt(doublereal);
06583     /* Local variables */
06584     static real norm, scale, absxi;
06585     static integer ix;
06586     static real ssq;
06587 /*  SNRM2 returns the euclidean norm of a vector via the function   
06588     name, so that   
06589        SNRM2 := sqrt( x'*x )   
06590     -- This version written on 25-October-1982.   
06591        Modified on 14-October-1993 to inline the call to SLASSQ.   
06592        Sven Hammarling, Nag Ltd.   
06593        Parameter adjustments */
06594     --x;
06595     /* Function Body */
06596     if (*n < 1 || *incx < 1) {
06597         norm = 0.f;
06598     } else if (*n == 1) {
06599         norm = dabs(x[1]);
06600     } else {
06601         scale = 0.f;
06602         ssq = 1.f;
06603 
06604 
06605         i__1 = (*n - 1) * *incx + 1;
06606         i__2 = *incx;
06607         for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
06608             if (x[ix] != 0.f) {
06609                 absxi = (r__1 = x[ix], dabs(r__1));
06610                 if (scale < absxi) {
06611 /* Computing 2nd power */
06612                     r__1 = scale / absxi;
06613                     ssq = ssq * (r__1 * r__1) + 1.f;
06614                     scale = absxi;
06615                 } else {
06616 /* Computing 2nd power */
06617                     r__1 = absxi / scale;
06618                     ssq += r__1 * r__1;
06619                 }
06620             }
06621 /* L10: */
06622         }
06623         norm = scale * sqrt(ssq);
06624     }
06625 
06626     ret_val = norm;
06627     return ret_val;
06628 
06629 /*     End of SNRM2. */
06630 
06631 } /* snrm2_ */
06632 
06633 
06634 
06635 
06636 /* Subroutine */ int sorg2l_(integer *m, integer *n, integer *k, real *a, 
06637         integer *lda, real *tau, real *work, integer *info)
06638 {
06639 /*  -- LAPACK routine (version 3.0) --   
06640        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
06641        Courant Institute, Argonne National Lab, and Rice University   
06642        February 29, 1992   
06643 
06644 
06645     Purpose   
06646     =======   
06647 
06648     SORG2L generates an m by n real matrix Q with orthonormal columns,   
06649     which is defined as the last n columns of a product of k elementary   
06650     reflectors of order m   
06651 
06652           Q  =  H(k) . . . H(2) H(1)   
06653 
06654     as returned by SGEQLF.   
06655 
06656     Arguments   
06657     =========   
06658 
06659     M       (input) INTEGER   
06660             The number of rows of the matrix Q. M >= 0.   
06661 
06662     N       (input) INTEGER   
06663             The number of columns of the matrix Q. M >= N >= 0.   
06664 
06665     K       (input) INTEGER   
06666             The number of elementary reflectors whose product defines the   
06667             matrix Q. N >= K >= 0.   
06668 
06669     A       (input/output) REAL array, dimension (LDA,N)   
06670             On entry, the (n-k+i)-th column must contain the vector which   
06671             defines the elementary reflector H(i), for i = 1,2,...,k, as   
06672             returned by SGEQLF in the last k columns of its array   
06673             argument A.   
06674             On exit, the m by n matrix Q.   
06675 
06676     LDA     (input) INTEGER   
06677             The first dimension of the array A. LDA >= f2cmax(1,M).   
06678 
06679     TAU     (input) REAL array, dimension (K)   
06680             TAU(i) must contain the scalar factor of the elementary   
06681             reflector H(i), as returned by SGEQLF.   
06682 
06683     WORK    (workspace) REAL array, dimension (N)   
06684 
06685     INFO    (output) INTEGER   
06686             = 0: successful exit   
06687             < 0: if INFO = -i, the i-th argument has an illegal value   
06688 
06689     =====================================================================   
06690 
06691 
06692        Test the input arguments   
06693 
06694        Parameter adjustments */
06695     /* Table of constant values */
06696     static integer c__1 = 1;
06697     
06698     /* System generated locals */
06699     integer a_dim1, a_offset, i__1, i__2, i__3;
06700     real r__1;
06701     /* Local variables */
06702     static integer i__, j, l;
06703     extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
06704             slarf_(const char *, integer *, integer *, real *, integer *, real *, 
06705             real *, integer *, real *);
06706     static integer ii;
06707     extern /* Subroutine */ int xerbla_(const char *, integer *);
06708 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
06709 
06710 
06711     a_dim1 = *lda;
06712     a_offset = 1 + a_dim1 * 1;
06713     a -= a_offset;
06714     --tau;
06715     --work;
06716 
06717     /* Function Body */
06718     *info = 0;
06719     if (*m < 0) {
06720         *info = -1;
06721     } else if (*n < 0 || *n > *m) {
06722         *info = -2;
06723     } else if (*k < 0 || *k > *n) {
06724         *info = -3;
06725     } else if (*lda < f2cmax(1,*m)) {
06726         *info = -5;
06727     }
06728     if (*info != 0) {
06729         i__1 = -(*info);
06730         xerbla_("SORG2L", &i__1);
06731         return 0;
06732     }
06733 
06734 /*     Quick return if possible */
06735 
06736     if (*n <= 0) {
06737         return 0;
06738     }
06739 
06740 /*     Initialise columns 1:n-k to columns of the unit matrix */
06741 
06742     i__1 = *n - *k;
06743     for (j = 1; j <= i__1; ++j) {
06744         i__2 = *m;
06745         for (l = 1; l <= i__2; ++l) {
06746             a_ref(l, j) = 0.f;
06747 /* L10: */
06748         }
06749         a_ref(*m - *n + j, j) = 1.f;
06750 /* L20: */
06751     }
06752 
06753     i__1 = *k;
06754     for (i__ = 1; i__ <= i__1; ++i__) {
06755         ii = *n - *k + i__;
06756 
06757 /*        Apply H(i) to A(1:m-k+i,1:n-k+i) from the left */
06758 
06759         a_ref(*m - *n + ii, ii) = 1.f;
06760         i__2 = *m - *n + ii;
06761         i__3 = ii - 1;
06762         slarf_("Left", &i__2, &i__3, &a_ref(1, ii), &c__1, &tau[i__], &a[
06763                 a_offset], lda, &work[1]);
06764         i__2 = *m - *n + ii - 1;
06765         r__1 = -tau[i__];
06766         sscal_(&i__2, &r__1, &a_ref(1, ii), &c__1);
06767         a_ref(*m - *n + ii, ii) = 1.f - tau[i__];
06768 
06769 /*        Set A(m-k+i+1:m,n-k+i) to zero */
06770 
06771         i__2 = *m;
06772         for (l = *m - *n + ii + 1; l <= i__2; ++l) {
06773             a_ref(l, ii) = 0.f;
06774 /* L30: */
06775         }
06776 /* L40: */
06777     }
06778     return 0;
06779 
06780 /*     End of SORG2L */
06781 
06782 } /* sorg2l_ */
06783 
06784 #undef a_ref
06785 
06786 
06787 
06788 
06789 
06790 /* Subroutine */ int sorg2r_(integer *m, integer *n, integer *k, real *a, 
06791         integer *lda, real *tau, real *work, integer *info)
06792 {
06793 /*  -- LAPACK routine (version 3.0) --   
06794        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
06795        Courant Institute, Argonne National Lab, and Rice University   
06796        February 29, 1992   
06797 
06798 
06799     Purpose   
06800     =======   
06801 
06802     SORG2R generates an m by n real matrix Q with orthonormal columns,   
06803     which is defined as the first n columns of a product of k elementary   
06804     reflectors of order m   
06805 
06806           Q  =  H(1) H(2) . . . H(k)   
06807 
06808     as returned by SGEQRF.   
06809 
06810     Arguments   
06811     =========   
06812 
06813     M       (input) INTEGER   
06814             The number of rows of the matrix Q. M >= 0.   
06815 
06816     N       (input) INTEGER   
06817             The number of columns of the matrix Q. M >= N >= 0.   
06818 
06819     K       (input) INTEGER   
06820             The number of elementary reflectors whose product defines the   
06821             matrix Q. N >= K >= 0.   
06822 
06823     A       (input/output) REAL array, dimension (LDA,N)   
06824             On entry, the i-th column must contain the vector which   
06825             defines the elementary reflector H(i), for i = 1,2,...,k, as   
06826             returned by SGEQRF in the first k columns of its array   
06827             argument A.   
06828             On exit, the m-by-n matrix Q.   
06829 
06830     LDA     (input) INTEGER   
06831             The first dimension of the array A. LDA >= f2cmax(1,M).   
06832 
06833     TAU     (input) REAL array, dimension (K)   
06834             TAU(i) must contain the scalar factor of the elementary   
06835             reflector H(i), as returned by SGEQRF.   
06836 
06837     WORK    (workspace) REAL array, dimension (N)   
06838 
06839     INFO    (output) INTEGER   
06840             = 0: successful exit   
06841             < 0: if INFO = -i, the i-th argument has an illegal value   
06842 
06843     =====================================================================   
06844 
06845 
06846        Test the input arguments   
06847 
06848        Parameter adjustments */
06849     /* Table of constant values */
06850     static integer c__1 = 1;
06851     
06852     /* System generated locals */
06853     integer a_dim1, a_offset, i__1, i__2;
06854     real r__1;
06855     /* Local variables */
06856     static integer i__, j, l;
06857     extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
06858             slarf_(const char *, integer *, integer *, real *, integer *, real *, 
06859             real *, integer *, real *), xerbla_(const char *, integer *);
06860 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
06861 
06862 
06863     a_dim1 = *lda;
06864     a_offset = 1 + a_dim1 * 1;
06865     a -= a_offset;
06866     --tau;
06867     --work;
06868 
06869     /* Function Body */
06870     *info = 0;
06871     if (*m < 0) {
06872         *info = -1;
06873     } else if (*n < 0 || *n > *m) {
06874         *info = -2;
06875     } else if (*k < 0 || *k > *n) {
06876         *info = -3;
06877     } else if (*lda < f2cmax(1,*m)) {
06878         *info = -5;
06879     }
06880     if (*info != 0) {
06881         i__1 = -(*info);
06882         xerbla_("SORG2R", &i__1);
06883         return 0;
06884     }
06885 
06886 /*     Quick return if possible */
06887 
06888     if (*n <= 0) {
06889         return 0;
06890     }
06891 
06892 /*     Initialise columns k+1:n to columns of the unit matrix */
06893 
06894     i__1 = *n;
06895     for (j = *k + 1; j <= i__1; ++j) {
06896         i__2 = *m;
06897         for (l = 1; l <= i__2; ++l) {
06898             a_ref(l, j) = 0.f;
06899 /* L10: */
06900         }
06901         a_ref(j, j) = 1.f;
06902 /* L20: */
06903     }
06904 
06905     for (i__ = *k; i__ >= 1; --i__) {
06906 
06907 /*        Apply H(i) to A(i:m,i:n) from the left */
06908 
06909         if (i__ < *n) {
06910             a_ref(i__, i__) = 1.f;
06911             i__1 = *m - i__ + 1;
06912             i__2 = *n - i__;
06913             slarf_("Left", &i__1, &i__2, &a_ref(i__, i__), &c__1, &tau[i__], &
06914                     a_ref(i__, i__ + 1), lda, &work[1]);
06915         }
06916         if (i__ < *m) {
06917             i__1 = *m - i__;
06918             r__1 = -tau[i__];
06919             sscal_(&i__1, &r__1, &a_ref(i__ + 1, i__), &c__1);
06920         }
06921         a_ref(i__, i__) = 1.f - tau[i__];
06922 
06923 /*        Set A(1:i-1,i) to zero */
06924 
06925         i__1 = i__ - 1;
06926         for (l = 1; l <= i__1; ++l) {
06927             a_ref(l, i__) = 0.f;
06928 /* L30: */
06929         }
06930 /* L40: */
06931     }
06932     return 0;
06933 
06934 /*     End of SORG2R */
06935 
06936 } /* sorg2r_ */
06937 
06938 #undef a_ref
06939 
06940 
06941 
06942 
06943 
06944 /* Subroutine */ int sorgql_(integer *m, integer *n, integer *k, real *a, 
06945         integer *lda, real *tau, real *work, integer *lwork, integer *info)
06946 {
06947 /*  -- LAPACK routine (version 3.0) --   
06948        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
06949        Courant Institute, Argonne National Lab, and Rice University   
06950        June 30, 1999   
06951 
06952 
06953     Purpose   
06954     =======   
06955 
06956     SORGQL generates an M-by-N real matrix Q with orthonormal columns,   
06957     which is defined as the last N columns of a product of K elementary   
06958     reflectors of order M   
06959 
06960           Q  =  H(k) . . . H(2) H(1)   
06961 
06962     as returned by SGEQLF.   
06963 
06964     Arguments   
06965     =========   
06966 
06967     M       (input) INTEGER   
06968             The number of rows of the matrix Q. M >= 0.   
06969 
06970     N       (input) INTEGER   
06971             The number of columns of the matrix Q. M >= N >= 0.   
06972 
06973     K       (input) INTEGER   
06974             The number of elementary reflectors whose product defines the   
06975             matrix Q. N >= K >= 0.   
06976 
06977     A       (input/output) REAL array, dimension (LDA,N)   
06978             On entry, the (n-k+i)-th column must contain the vector which   
06979             defines the elementary reflector H(i), for i = 1,2,...,k, as   
06980             returned by SGEQLF in the last k columns of its array   
06981             argument A.   
06982             On exit, the M-by-N matrix Q.   
06983 
06984     LDA     (input) INTEGER   
06985             The first dimension of the array A. LDA >= f2cmax(1,M).   
06986 
06987     TAU     (input) REAL array, dimension (K)   
06988             TAU(i) must contain the scalar factor of the elementary   
06989             reflector H(i), as returned by SGEQLF.   
06990 
06991     WORK    (workspace/output) REAL array, dimension (LWORK)   
06992             On exit, if INFO = 0, WORK(1) returns the optimal LWORK.   
06993 
06994     LWORK   (input) INTEGER   
06995             The dimension of the array WORK. LWORK >= f2cmax(1,N).   
06996             For optimum performance LWORK >= N*NB, where NB is the   
06997             optimal blocksize.   
06998 
06999             If LWORK = -1, then a workspace query is assumed; the routine   
07000             only calculates the optimal size of the WORK array, returns   
07001             this value as the first entry of the WORK array, and no error   
07002             message related to LWORK is issued by XERBLA.   
07003 
07004     INFO    (output) INTEGER   
07005             = 0:  successful exit   
07006             < 0:  if INFO = -i, the i-th argument has an illegal value   
07007 
07008     =====================================================================   
07009 
07010 
07011        Test the input arguments   
07012 
07013        Parameter adjustments */
07014     /* Table of constant values */
07015     static integer c__1 = 1;
07016     static integer c_n1 = -1;
07017     static integer c__3 = 3;
07018     static integer c__2 = 2;
07019     
07020     /* System generated locals */
07021     integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
07022     /* Local variables */
07023     static integer i__, j, l, nbmin, iinfo;
07024     extern /* Subroutine */ int sorg2l_(integer *, integer *, integer *, real 
07025             *, integer *, real *, real *, integer *);
07026     static integer ib, nb, kk, nx;
07027     extern /* Subroutine */ int slarfb_(const char *, const char *, const char *, const char *, 
07028             integer *, integer *, integer *, real *, integer *, real *, 
07029             integer *, real *, integer *, real *, integer *), xerbla_(const char *, integer *);
07030     extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *, 
07031             integer *, integer *, ftnlen, ftnlen);
07032     extern /* Subroutine */ int slarft_(const char *, const char *, integer *, integer *, 
07033             real *, integer *, real *, real *, integer *);
07034     static integer ldwork, lwkopt;
07035     static logical lquery;
07036     static integer iws;
07037 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
07038 
07039 
07040     a_dim1 = *lda;
07041     a_offset = 1 + a_dim1 * 1;
07042     a -= a_offset;
07043     --tau;
07044     --work;
07045 
07046     /* Function Body */
07047     *info = 0;
07048     nb = ilaenv_(&c__1, "SORGQL", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
07049     lwkopt = f2cmax(1,*n) * nb;
07050     work[1] = (real) lwkopt;
07051     lquery = *lwork == -1;
07052     if (*m < 0) {
07053         *info = -1;
07054     } else if (*n < 0 || *n > *m) {
07055         *info = -2;
07056     } else if (*k < 0 || *k > *n) {
07057         *info = -3;
07058     } else if (*lda < f2cmax(1,*m)) {
07059         *info = -5;
07060     } else if (*lwork < f2cmax(1,*n) && ! lquery) {
07061         *info = -8;
07062     }
07063     if (*info != 0) {
07064         i__1 = -(*info);
07065         xerbla_("SORGQL", &i__1);
07066         return 0;
07067     } else if (lquery) {
07068         return 0;
07069     }
07070 
07071 /*     Quick return if possible */
07072 
07073     if (*n <= 0) {
07074         work[1] = 1.f;
07075         return 0;
07076     }
07077 
07078     nbmin = 2;
07079     nx = 0;
07080     iws = *n;
07081     if (nb > 1 && nb < *k) {
07082 
07083 /*        Determine when to cross over from blocked to unblocked code.   
07084 
07085    Computing MAX */
07086         i__1 = 0, i__2 = ilaenv_(&c__3, "SORGQL", " ", m, n, k, &c_n1, (
07087                 ftnlen)6, (ftnlen)1);
07088         nx = f2cmax(i__1,i__2);
07089         if (nx < *k) {
07090 
07091 /*           Determine if workspace is large enough for blocked code. */
07092 
07093             ldwork = *n;
07094             iws = ldwork * nb;
07095             if (*lwork < iws) {
07096 
07097 /*              Not enough workspace to use optimal NB:  reduce NB and   
07098                 determine the minimum value of NB. */
07099 
07100                 nb = *lwork / ldwork;
07101 /* Computing MAX */
07102                 i__1 = 2, i__2 = ilaenv_(&c__2, "SORGQL", " ", m, n, k, &c_n1,
07103                          (ftnlen)6, (ftnlen)1);
07104                 nbmin = f2cmax(i__1,i__2);
07105             }
07106         }
07107     }
07108 
07109     if (nb >= nbmin && nb < *k && nx < *k) {
07110 
07111 /*        Use blocked code after the first block.   
07112           The last kk columns are handled by the block method.   
07113 
07114    Computing MIN */
07115         i__1 = *k, i__2 = (*k - nx + nb - 1) / nb * nb;
07116         kk = f2cmin(i__1,i__2);
07117 
07118 /*        Set A(m-kk+1:m,1:n-kk) to zero. */
07119 
07120         i__1 = *n - kk;
07121         for (j = 1; j <= i__1; ++j) {
07122             i__2 = *m;
07123             for (i__ = *m - kk + 1; i__ <= i__2; ++i__) {
07124                 a_ref(i__, j) = 0.f;
07125 /* L10: */
07126             }
07127 /* L20: */
07128         }
07129     } else {
07130         kk = 0;
07131     }
07132 
07133 /*     Use unblocked code for the first or only block. */
07134 
07135     i__1 = *m - kk;
07136     i__2 = *n - kk;
07137     i__3 = *k - kk;
07138     sorg2l_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], &iinfo)
07139             ;
07140 
07141     if (kk > 0) {
07142 
07143 /*        Use blocked code */
07144 
07145         i__1 = *k;
07146         i__2 = nb;
07147         for (i__ = *k - kk + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += 
07148                 i__2) {
07149 /* Computing MIN */
07150             i__3 = nb, i__4 = *k - i__ + 1;
07151             ib = f2cmin(i__3,i__4);
07152             if (*n - *k + i__ > 1) {
07153 
07154 /*              Form the triangular factor of the block reflector   
07155                 H = H(i+ib-1) . . . H(i+1) H(i) */
07156 
07157                 i__3 = *m - *k + i__ + ib - 1;
07158                 slarft_("Backward", "Columnwise", &i__3, &ib, &a_ref(1, *n - *
07159                         k + i__), lda, &tau[i__], &work[1], &ldwork);
07160 
07161 /*              Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */
07162 
07163                 i__3 = *m - *k + i__ + ib - 1;
07164                 i__4 = *n - *k + i__ - 1;
07165                 slarfb_("Left", "No transpose", "Backward", "Columnwise", &
07166                         i__3, &i__4, &ib, &a_ref(1, *n - *k + i__), lda, &
07167                         work[1], &ldwork, &a[a_offset], lda, &work[ib + 1], &
07168                         ldwork);
07169             }
07170 
07171 /*           Apply H to rows 1:m-k+i+ib-1 of current block */
07172 
07173             i__3 = *m - *k + i__ + ib - 1;
07174             sorg2l_(&i__3, &ib, &ib, &a_ref(1, *n - *k + i__), lda, &tau[i__],
07175                      &work[1], &iinfo);
07176 
07177 /*           Set rows m-k+i+ib:m of current block to zero */
07178 
07179             i__3 = *n - *k + i__ + ib - 1;
07180             for (j = *n - *k + i__; j <= i__3; ++j) {
07181                 i__4 = *m;
07182                 for (l = *m - *k + i__ + ib; l <= i__4; ++l) {
07183                     a_ref(l, j) = 0.f;
07184 /* L30: */
07185                 }
07186 /* L40: */
07187             }
07188 /* L50: */
07189         }
07190     }
07191 
07192     work[1] = (real) iws;
07193     return 0;
07194 
07195 /*     End of SORGQL */
07196 
07197 } /* sorgql_ */
07198 
07199 #undef a_ref
07200 
07201 
07202 
07203 
07204 
07205 /* Subroutine */ int sorgqr_(integer *m, integer *n, integer *k, real *a, 
07206         integer *lda, real *tau, real *work, integer *lwork, integer *info)
07207 {
07208 /*  -- LAPACK routine (version 3.0) --   
07209        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
07210        Courant Institute, Argonne National Lab, and Rice University   
07211        June 30, 1999   
07212 
07213 
07214     Purpose   
07215     =======   
07216 
07217     SORGQR generates an M-by-N real matrix Q with orthonormal columns,   
07218     which is defined as the first N columns of a product of K elementary   
07219     reflectors of order M   
07220 
07221           Q  =  H(1) H(2) . . . H(k)   
07222 
07223     as returned by SGEQRF.   
07224 
07225     Arguments   
07226     =========   
07227 
07228     M       (input) INTEGER   
07229             The number of rows of the matrix Q. M >= 0.   
07230 
07231     N       (input) INTEGER   
07232             The number of columns of the matrix Q. M >= N >= 0.   
07233 
07234     K       (input) INTEGER   
07235             The number of elementary reflectors whose product defines the   
07236             matrix Q. N >= K >= 0.   
07237 
07238     A       (input/output) REAL array, dimension (LDA,N)   
07239             On entry, the i-th column must contain the vector which   
07240             defines the elementary reflector H(i), for i = 1,2,...,k, as   
07241             returned by SGEQRF in the first k columns of its array   
07242             argument A.   
07243             On exit, the M-by-N matrix Q.   
07244 
07245     LDA     (input) INTEGER   
07246             The first dimension of the array A. LDA >= f2cmax(1,M).   
07247 
07248     TAU     (input) REAL array, dimension (K)   
07249             TAU(i) must contain the scalar factor of the elementary   
07250             reflector H(i), as returned by SGEQRF.   
07251 
07252     WORK    (workspace/output) REAL array, dimension (LWORK)   
07253             On exit, if INFO = 0, WORK(1) returns the optimal LWORK.   
07254 
07255     LWORK   (input) INTEGER   
07256             The dimension of the array WORK. LWORK >= f2cmax(1,N).   
07257             For optimum performance LWORK >= N*NB, where NB is the   
07258             optimal blocksize.   
07259 
07260             If LWORK = -1, then a workspace query is assumed; the routine   
07261             only calculates the optimal size of the WORK array, returns   
07262             this value as the first entry of the WORK array, and no error   
07263             message related to LWORK is issued by XERBLA.   
07264 
07265     INFO    (output) INTEGER   
07266             = 0:  successful exit   
07267             < 0:  if INFO = -i, the i-th argument has an illegal value   
07268 
07269     =====================================================================   
07270 
07271 
07272        Test the input arguments   
07273 
07274        Parameter adjustments */
07275     /* Table of constant values */
07276     static integer c__1 = 1;
07277     static integer c_n1 = -1;
07278     static integer c__3 = 3;
07279     static integer c__2 = 2;
07280     
07281     /* System generated locals */
07282     integer a_dim1, a_offset, i__1, i__2, i__3;
07283     /* Local variables */
07284     static integer i__, j, l, nbmin, iinfo, ib;
07285     extern /* Subroutine */ int sorg2r_(integer *, integer *, integer *, real 
07286             *, integer *, real *, real *, integer *);
07287     static integer nb, ki, kk, nx;
07288     extern /* Subroutine */ int slarfb_(const char *, const char *, const char *, const char *, 
07289             integer *, integer *, integer *, real *, integer *, real *, 
07290             integer *, real *, integer *, real *, integer *), xerbla_(const char *, integer *);
07291     extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *, 
07292             integer *, integer *, ftnlen, ftnlen);
07293     extern /* Subroutine */ int slarft_(const char *, const char *, integer *, integer *, 
07294             real *, integer *, real *, real *, integer *);
07295     static integer ldwork, lwkopt;
07296     static logical lquery;
07297     static integer iws;
07298 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
07299 
07300 
07301     a_dim1 = *lda;
07302     a_offset = 1 + a_dim1 * 1;
07303     a -= a_offset;
07304     --tau;
07305     --work;
07306 
07307     /* Function Body */
07308     *info = 0;
07309     nb = ilaenv_(&c__1, "SORGQR", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
07310     lwkopt = f2cmax(1,*n) * nb;
07311     work[1] = (real) lwkopt;
07312     lquery = *lwork == -1;
07313     if (*m < 0) {
07314         *info = -1;
07315     } else if (*n < 0 || *n > *m) {
07316         *info = -2;
07317     } else if (*k < 0 || *k > *n) {
07318         *info = -3;
07319     } else if (*lda < f2cmax(1,*m)) {
07320         *info = -5;
07321     } else if (*lwork < f2cmax(1,*n) && ! lquery) {
07322         *info = -8;
07323     }
07324     if (*info != 0) {
07325         i__1 = -(*info);
07326         xerbla_("SORGQR", &i__1);
07327         return 0;
07328     } else if (lquery) {
07329         return 0;
07330     }
07331 
07332 /*     Quick return if possible */
07333 
07334     if (*n <= 0) {
07335         work[1] = 1.f;
07336         return 0;
07337     }
07338 
07339     nbmin = 2;
07340     nx = 0;
07341     iws = *n;
07342     if (nb > 1 && nb < *k) {
07343 
07344 /*        Determine when to cross over from blocked to unblocked code.   
07345 
07346    Computing MAX */
07347         i__1 = 0, i__2 = ilaenv_(&c__3, "SORGQR", " ", m, n, k, &c_n1, (
07348                 ftnlen)6, (ftnlen)1);
07349         nx = f2cmax(i__1,i__2);
07350         if (nx < *k) {
07351 
07352 /*           Determine if workspace is large enough for blocked code. */
07353 
07354             ldwork = *n;
07355             iws = ldwork * nb;
07356             if (*lwork < iws) {
07357 
07358 /*              Not enough workspace to use optimal NB:  reduce NB and   
07359                 determine the minimum value of NB. */
07360 
07361                 nb = *lwork / ldwork;
07362 /* Computing MAX */
07363                 i__1 = 2, i__2 = ilaenv_(&c__2, "SORGQR", " ", m, n, k, &c_n1,
07364                          (ftnlen)6, (ftnlen)1);
07365                 nbmin = f2cmax(i__1,i__2);
07366             }
07367         }
07368     }
07369 
07370     if (nb >= nbmin && nb < *k && nx < *k) {
07371 
07372 /*        Use blocked code after the last block.   
07373           The first kk columns are handled by the block method. */
07374 
07375         ki = (*k - nx - 1) / nb * nb;
07376 /* Computing MIN */
07377         i__1 = *k, i__2 = ki + nb;
07378         kk = f2cmin(i__1,i__2);
07379 
07380 /*        Set A(1:kk,kk+1:n) to zero. */
07381 
07382         i__1 = *n;
07383         for (j = kk + 1; j <= i__1; ++j) {
07384             i__2 = kk;
07385             for (i__ = 1; i__ <= i__2; ++i__) {
07386                 a_ref(i__, j) = 0.f;
07387 /* L10: */
07388             }
07389 /* L20: */
07390         }
07391     } else {
07392         kk = 0;
07393     }
07394 
07395 /*     Use unblocked code for the last or only block. */
07396 
07397     if (kk < *n) {
07398         i__1 = *m - kk;
07399         i__2 = *n - kk;
07400         i__3 = *k - kk;
07401         sorg2r_(&i__1, &i__2, &i__3, &a_ref(kk + 1, kk + 1), lda, &tau[kk + 1]
07402                 , &work[1], &iinfo);
07403     }
07404 
07405     if (kk > 0) {
07406 
07407 /*        Use blocked code */
07408 
07409         i__1 = -nb;
07410         for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
07411 /* Computing MIN */
07412             i__2 = nb, i__3 = *k - i__ + 1;
07413             ib = f2cmin(i__2,i__3);
07414             if (i__ + ib <= *n) {
07415 
07416 /*              Form the triangular factor of the block reflector   
07417                 H = H(i) H(i+1) . . . H(i+ib-1) */
07418 
07419                 i__2 = *m - i__ + 1;
07420                 slarft_("Forward", "Columnwise", &i__2, &ib, &a_ref(i__, i__),
07421                          lda, &tau[i__], &work[1], &ldwork);
07422 
07423 /*              Apply H to A(i:m,i+ib:n) from the left */
07424 
07425                 i__2 = *m - i__ + 1;
07426                 i__3 = *n - i__ - ib + 1;
07427                 slarfb_("Left", "No transpose", "Forward", "Columnwise", &
07428                         i__2, &i__3, &ib, &a_ref(i__, i__), lda, &work[1], &
07429                         ldwork, &a_ref(i__, i__ + ib), lda, &work[ib + 1], &
07430                         ldwork);
07431             }
07432 
07433 /*           Apply H to rows i:m of current block */
07434 
07435             i__2 = *m - i__ + 1;
07436             sorg2r_(&i__2, &ib, &ib, &a_ref(i__, i__), lda, &tau[i__], &work[
07437                     1], &iinfo);
07438 
07439 /*           Set rows 1:i-1 of current block to zero */
07440 
07441             i__2 = i__ + ib - 1;
07442             for (j = i__; j <= i__2; ++j) {
07443                 i__3 = i__ - 1;
07444                 for (l = 1; l <= i__3; ++l) {
07445                     a_ref(l, j) = 0.f;
07446 /* L30: */
07447                 }
07448 /* L40: */
07449             }
07450 /* L50: */
07451         }
07452     }
07453 
07454     work[1] = (real) iws;
07455     return 0;
07456 
07457 /*     End of SORGQR */
07458 
07459 } /* sorgqr_ */
07460 
07461 #undef a_ref
07462 
07463 
07464 
07465 
07466 
07467 /* Subroutine */ int sorgtr_(char *uplo, integer *n, real *a, integer *lda, 
07468         real *tau, real *work, integer *lwork, integer *info)
07469 {
07470 /*  -- LAPACK routine (version 3.0) --   
07471        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
07472        Courant Institute, Argonne National Lab, and Rice University   
07473        June 30, 1999   
07474 
07475 
07476     Purpose   
07477     =======   
07478 
07479     SORGTR generates a real orthogonal matrix Q which is defined as the   
07480     product of n-1 elementary reflectors of order N, as returned by   
07481     SSYTRD:   
07482 
07483     if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),   
07484 
07485     if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).   
07486 
07487     Arguments   
07488     =========   
07489 
07490     UPLO    (input) CHARACTER*1   
07491             = 'U': Upper triangle of A contains elementary reflectors   
07492                    from SSYTRD;   
07493             = 'L': Lower triangle of A contains elementary reflectors   
07494                    from SSYTRD.   
07495 
07496     N       (input) INTEGER   
07497             The order of the matrix Q. N >= 0.   
07498 
07499     A       (input/output) REAL array, dimension (LDA,N)   
07500             On entry, the vectors which define the elementary reflectors,   
07501             as returned by SSYTRD.   
07502             On exit, the N-by-N orthogonal matrix Q.   
07503 
07504     LDA     (input) INTEGER   
07505             The leading dimension of the array A. LDA >= f2cmax(1,N).   
07506 
07507     TAU     (input) REAL array, dimension (N-1)   
07508             TAU(i) must contain the scalar factor of the elementary   
07509             reflector H(i), as returned by SSYTRD.   
07510 
07511     WORK    (workspace/output) REAL array, dimension (LWORK)   
07512             On exit, if INFO = 0, WORK(1) returns the optimal LWORK.   
07513 
07514     LWORK   (input) INTEGER   
07515             The dimension of the array WORK. LWORK >= f2cmax(1,N-1).   
07516             For optimum performance LWORK >= (N-1)*NB, where NB is   
07517             the optimal blocksize.   
07518 
07519             If LWORK = -1, then a workspace query is assumed; the routine   
07520             only calculates the optimal size of the WORK array, returns   
07521             this value as the first entry of the WORK array, and no error   
07522             message related to LWORK is issued by XERBLA.   
07523 
07524     INFO    (output) INTEGER   
07525             = 0:  successful exit   
07526             < 0:  if INFO = -i, the i-th argument had an illegal value   
07527 
07528     =====================================================================   
07529 
07530 
07531        Test the input arguments   
07532 
07533        Parameter adjustments */
07534     /* Table of constant values */
07535     static integer c__1 = 1;
07536     static integer c_n1 = -1;
07537     
07538     /* System generated locals */
07539     integer a_dim1, a_offset, i__1, i__2, i__3;
07540     /* Local variables */
07541     static integer i__, j;
07542     extern logical lsame_(const char *, const char *);
07543     static integer iinfo;
07544     static logical upper;
07545     static integer nb;
07546     extern /* Subroutine */ int xerbla_(const char *, integer *);
07547     extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *, 
07548             integer *, integer *, ftnlen, ftnlen);
07549     extern /* Subroutine */ int sorgql_(integer *, integer *, integer *, real 
07550             *, integer *, real *, real *, integer *, integer *), sorgqr_(
07551             integer *, integer *, integer *, real *, integer *, real *, real *
07552             , integer *, integer *);
07553     static logical lquery;
07554     static integer lwkopt;
07555 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
07556 
07557 
07558     a_dim1 = *lda;
07559     a_offset = 1 + a_dim1 * 1;
07560     a -= a_offset;
07561     --tau;
07562     --work;
07563 
07564     /* Function Body */
07565     *info = 0;
07566     lquery = *lwork == -1;
07567     upper = lsame_(uplo, "U");
07568     if (! upper && ! lsame_(uplo, "L")) {
07569         *info = -1;
07570     } else if (*n < 0) {
07571         *info = -2;
07572     } else if (*lda < f2cmax(1,*n)) {
07573         *info = -4;
07574     } else /* if(complicated condition) */ {
07575 /* Computing MAX */
07576         i__1 = 1, i__2 = *n - 1;
07577         if (*lwork < f2cmax(i__1,i__2) && ! lquery) {
07578             *info = -7;
07579         }
07580     }
07581 
07582     if (*info == 0) {
07583         if (upper) {
07584             i__1 = *n - 1;
07585             i__2 = *n - 1;
07586             i__3 = *n - 1;
07587             nb = ilaenv_(&c__1, "SORGQL", " ", &i__1, &i__2, &i__3, &c_n1, (
07588                     ftnlen)6, (ftnlen)1);
07589         } else {
07590             i__1 = *n - 1;
07591             i__2 = *n - 1;
07592             i__3 = *n - 1;
07593             nb = ilaenv_(&c__1, "SORGQR", " ", &i__1, &i__2, &i__3, &c_n1, (
07594                     ftnlen)6, (ftnlen)1);
07595         }
07596 /* Computing MAX */
07597         i__1 = 1, i__2 = *n - 1;
07598         lwkopt = f2cmax(i__1,i__2) * nb;
07599         work[1] = (real) lwkopt;
07600     }
07601 
07602     if (*info != 0) {
07603         i__1 = -(*info);
07604         xerbla_("SORGTR", &i__1);
07605         return 0;
07606     } else if (lquery) {
07607         return 0;
07608     }
07609 
07610 /*     Quick return if possible */
07611 
07612     if (*n == 0) {
07613         work[1] = 1.f;
07614         return 0;
07615     }
07616 
07617     if (upper) {
07618 
07619 /*        Q was determined by a call to SSYTRD with UPLO = 'U'   
07620 
07621           Shift the vectors which define the elementary reflectors one   
07622           column to the left, and set the last row and column of Q to   
07623           those of the unit matrix */
07624 
07625         i__1 = *n - 1;
07626         for (j = 1; j <= i__1; ++j) {
07627             i__2 = j - 1;
07628             for (i__ = 1; i__ <= i__2; ++i__) {
07629                 a_ref(i__, j) = a_ref(i__, j + 1);
07630 /* L10: */
07631             }
07632             a_ref(*n, j) = 0.f;
07633 /* L20: */
07634         }
07635         i__1 = *n - 1;
07636         for (i__ = 1; i__ <= i__1; ++i__) {
07637             a_ref(i__, *n) = 0.f;
07638 /* L30: */
07639         }
07640         a_ref(*n, *n) = 1.f;
07641 
07642 /*        Generate Q(1:n-1,1:n-1) */
07643 
07644         i__1 = *n - 1;
07645         i__2 = *n - 1;
07646         i__3 = *n - 1;
07647         sorgql_(&i__1, &i__2, &i__3, &a[a_offset], lda, &tau[1], &work[1], 
07648                 lwork, &iinfo);
07649 
07650     } else {
07651 
07652 /*        Q was determined by a call to SSYTRD with UPLO = 'L'.   
07653 
07654           Shift the vectors which define the elementary reflectors one   
07655           column to the right, and set the first row and column of Q to   
07656           those of the unit matrix */
07657 
07658         for (j = *n; j >= 2; --j) {
07659             a_ref(1, j) = 0.f;
07660             i__1 = *n;
07661             for (i__ = j + 1; i__ <= i__1; ++i__) {
07662                 a_ref(i__, j) = a_ref(i__, j - 1);
07663 /* L40: */
07664             }
07665 /* L50: */
07666         }
07667         a_ref(1, 1) = 1.f;
07668         i__1 = *n;
07669         for (i__ = 2; i__ <= i__1; ++i__) {
07670             a_ref(i__, 1) = 0.f;
07671 /* L60: */
07672         }
07673         if (*n > 1) {
07674 
07675 /*           Generate Q(2:n,2:n) */
07676 
07677             i__1 = *n - 1;
07678             i__2 = *n - 1;
07679             i__3 = *n - 1;
07680             sorgqr_(&i__1, &i__2, &i__3, &a_ref(2, 2), lda, &tau[1], &work[1],
07681                      lwork, &iinfo);
07682         }
07683     }
07684     work[1] = (real) lwkopt;
07685     return 0;
07686 
07687 /*     End of SORGTR */
07688 
07689 } /* sorgtr_ */
07690 
07691 #undef a_ref
07692 
07693 
07694 
07695 
07696 
07697 /* Subroutine */ int sscal_(integer *n, real *sa, real *sx, integer *incx)
07698 {
07699     /* System generated locals */
07700     integer i__1, i__2;
07701     /* Local variables */
07702     static integer i__, m, nincx, mp1;
07703 /*     scales a vector by a constant.   
07704        uses unrolled loops for increment equal to 1.   
07705        jack dongarra, linpack, 3/11/78.   
07706        modified 3/93 to return if incx .le. 0.   
07707        modified 12/3/93, array(1) declarations changed to array(*)   
07708        Parameter adjustments */
07709     --sx;
07710     /* Function Body */
07711     if (*n <= 0 || *incx <= 0) {
07712         return 0;
07713     }
07714     if (*incx == 1) {
07715         goto L20;
07716     }
07717 /*        code for increment not equal to 1 */
07718     nincx = *n * *incx;
07719     i__1 = nincx;
07720     i__2 = *incx;
07721     for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
07722         sx[i__] = *sa * sx[i__];
07723 /* L10: */
07724     }
07725     return 0;
07726 /*        code for increment equal to 1   
07727           clean-up loop */
07728 L20:
07729     m = *n % 5;
07730     if (m == 0) {
07731         goto L40;
07732     }
07733     i__2 = m;
07734     for (i__ = 1; i__ <= i__2; ++i__) {
07735         sx[i__] = *sa * sx[i__];
07736 /* L30: */
07737     }
07738     if (*n < 5) {
07739         return 0;
07740     }
07741 L40:
07742     mp1 = m + 1;
07743     i__2 = *n;
07744     for (i__ = mp1; i__ <= i__2; i__ += 5) {
07745         sx[i__] = *sa * sx[i__];
07746         sx[i__ + 1] = *sa * sx[i__ + 1];
07747         sx[i__ + 2] = *sa * sx[i__ + 2];
07748         sx[i__ + 3] = *sa * sx[i__ + 3];
07749         sx[i__ + 4] = *sa * sx[i__ + 4];
07750 /* L50: */
07751     }
07752     return 0;
07753 } /* sscal_ */
07754 
07755 
07756 
07757 
07758 /* Subroutine */ int ssteqr_(const char *compz, integer *n, real *d__, real *e, 
07759         real *z__, integer *ldz, real *work, integer *info)
07760 {
07761 /*  -- LAPACK routine (version 3.0) --   
07762        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
07763        Courant Institute, Argonne National Lab, and Rice University   
07764        September 30, 1994   
07765 
07766 
07767     Purpose   
07768     =======   
07769 
07770     SSTEQR computes all eigenvalues and, optionally, eigenvectors of a   
07771     symmetric tridiagonal matrix using the implicit QL or QR method.   
07772     The eigenvectors of a full or band symmetric matrix can also be found   
07773     if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to   
07774     tridiagonal form.   
07775 
07776     Arguments   
07777     =========   
07778 
07779     COMPZ   (input) CHARACTER*1   
07780             = 'N':  Compute eigenvalues only.   
07781             = 'V':  Compute eigenvalues and eigenvectors of the original   
07782                     symmetric matrix.  On entry, Z must contain the   
07783                     orthogonal matrix used to reduce the original matrix   
07784                     to tridiagonal form.   
07785             = 'I':  Compute eigenvalues and eigenvectors of the   
07786                     tridiagonal matrix.  Z is initialized to the identity   
07787                     matrix.   
07788 
07789     N       (input) INTEGER   
07790             The order of the matrix.  N >= 0.   
07791 
07792     D       (input/output) REAL array, dimension (N)   
07793             On entry, the diagonal elements of the tridiagonal matrix.   
07794             On exit, if INFO = 0, the eigenvalues in ascending order.   
07795 
07796     E       (input/output) REAL array, dimension (N-1)   
07797             On entry, the (n-1) subdiagonal elements of the tridiagonal   
07798             matrix.   
07799             On exit, E has been destroyed.   
07800 
07801     Z       (input/output) REAL array, dimension (LDZ, N)   
07802             On entry, if  COMPZ = 'V', then Z contains the orthogonal   
07803             matrix used in the reduction to tridiagonal form.   
07804             On exit, if INFO = 0, then if  COMPZ = 'V', Z contains the   
07805             orthonormal eigenvectors of the original symmetric matrix,   
07806             and if COMPZ = 'I', Z contains the orthonormal eigenvectors   
07807             of the symmetric tridiagonal matrix.   
07808             If COMPZ = 'N', then Z is not referenced.   
07809 
07810     LDZ     (input) INTEGER   
07811             The leading dimension of the array Z.  LDZ >= 1, and if   
07812             eigenvectors are desired, then  LDZ >= f2cmax(1,N).   
07813 
07814     WORK    (workspace) REAL array, dimension (f2cmax(1,2*N-2))   
07815             If COMPZ = 'N', then WORK is not referenced.   
07816 
07817     INFO    (output) INTEGER   
07818             = 0:  successful exit   
07819             < 0:  if INFO = -i, the i-th argument had an illegal value   
07820             > 0:  the algorithm has failed to find all the eigenvalues in   
07821                   a total of 30*N iterations; if INFO = i, then i   
07822                   elements of E have not converged to zero; on exit, D   
07823                   and E contain the elements of a symmetric tridiagonal   
07824                   matrix which is orthogonally similar to the original   
07825                   matrix.   
07826 
07827     =====================================================================   
07828 
07829 
07830        Test the input parameters.   
07831 
07832        Parameter adjustments */
07833     /* Table of constant values */
07834     static real c_b9 = 0.f;
07835     static real c_b10 = 1.f;
07836     static integer c__0 = 0;
07837     static integer c__1 = 1;
07838     static integer c__2 = 2;
07839     
07840     /* System generated locals */
07841     integer z_dim1, z_offset, i__1, i__2;
07842     real r__1, r__2;
07843     /* Builtin functions */
07844 //    double sqrt(doublereal), r_sign(real *, real *);
07845     double r_sign(real *, real *);
07846     /* Local variables */
07847     static integer lend, jtot;
07848     extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
07849             ;
07850     static real b, c__, f, g;
07851     static integer i__, j, k, l, m;
07852     static real p, r__, s;
07853     extern logical lsame_(const char *, const char *);
07854     static real anorm;
07855     extern /* Subroutine */ int slasr_(const char *, const char *, const char *, integer *, 
07856             integer *, real *, real *, real *, integer *);
07857     static integer l1;
07858     extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
07859             integer *);
07860     static integer lendm1, lendp1;
07861     extern /* Subroutine */ int slaev2_(real *, real *, real *, real *, real *
07862             , real *, real *);
07863     extern doublereal slapy2_(real *, real *);
07864     static integer ii, mm, iscale;
07865     extern doublereal slamch_(const char *);
07866     static real safmin;
07867     extern /* Subroutine */ int xerbla_(const char *, integer *);
07868     static real safmax;
07869     extern /* Subroutine */ int slascl_(const char *, integer *, integer *, real *, 
07870             real *, integer *, integer *, real *, integer *, integer *);
07871     static integer lendsv;
07872     extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real *
07873             ), slaset_(const char *, integer *, integer *, real *, real *, real *, 
07874             integer *);
07875     static real ssfmin;
07876     static integer nmaxit, icompz;
07877     static real ssfmax;
07878     extern doublereal slanst_(const char *, integer *, real *, real *);
07879     extern /* Subroutine */ int slasrt_(const char *, integer *, real *, integer *);
07880     static integer lm1, mm1, nm1;
07881     static real rt1, rt2, eps;
07882     static integer lsv;
07883     static real tst, eps2;
07884 #define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
07885 
07886 
07887     --d__;
07888     --e;
07889     z_dim1 = *ldz;
07890     z_offset = 1 + z_dim1 * 1;
07891     z__ -= z_offset;
07892     --work;
07893 
07894     /* Function Body */
07895     *info = 0;
07896 
07897     if (lsame_(compz, "N")) {
07898         icompz = 0;
07899     } else if (lsame_(compz, "V")) {
07900         icompz = 1;
07901     } else if (lsame_(compz, "I")) {
07902         icompz = 2;
07903     } else {
07904         icompz = -1;
07905     }
07906     if (icompz < 0) {
07907         *info = -1;
07908     } else if (*n < 0) {
07909         *info = -2;
07910     } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) {
07911         *info = -6;
07912     }
07913     if (*info != 0) {
07914         i__1 = -(*info);
07915         xerbla_("SSTEQR", &i__1);
07916         return 0;
07917     }
07918 
07919 /*     Quick return if possible */
07920 
07921     if (*n == 0) {
07922         return 0;
07923     }
07924 
07925     if (*n == 1) {
07926         if (icompz == 2) {
07927             z___ref(1, 1) = 1.f;
07928         }
07929         return 0;
07930     }
07931 
07932 /*     Determine the unit roundoff and over/underflow thresholds. */
07933 
07934     eps = slamch_("E");
07935 /* Computing 2nd power */
07936     r__1 = eps;
07937     eps2 = r__1 * r__1;
07938     safmin = slamch_("S");
07939     safmax = 1.f / safmin;
07940     ssfmax = sqrt(safmax) / 3.f;
07941     ssfmin = sqrt(safmin) / eps2;
07942 
07943 /*     Compute the eigenvalues and eigenvectors of the tridiagonal   
07944        matrix. */
07945 
07946     if (icompz == 2) {
07947         slaset_("Full", n, n, &c_b9, &c_b10, &z__[z_offset], ldz);
07948     }
07949 
07950     nmaxit = *n * 30;
07951     jtot = 0;
07952 
07953 /*     Determine where the matrix splits and choose QL or QR iteration   
07954        for each block, according to whether top or bottom diagonal   
07955        element is smaller. */
07956 
07957     l1 = 1;
07958     nm1 = *n - 1;
07959 
07960 L10:
07961     if (l1 > *n) {
07962         goto L160;
07963     }
07964     if (l1 > 1) {
07965         e[l1 - 1] = 0.f;
07966     }
07967     if (l1 <= nm1) {
07968         i__1 = nm1;
07969         for (m = l1; m <= i__1; ++m) {
07970             tst = (r__1 = e[m], dabs(r__1));
07971             if (tst == 0.f) {
07972                 goto L30;
07973             }
07974             if (tst <= sqrt((r__1 = d__[m], dabs(r__1))) * sqrt((r__2 = d__[m 
07975                     + 1], dabs(r__2))) * eps) {
07976                 e[m] = 0.f;
07977                 goto L30;
07978             }
07979 /* L20: */
07980         }
07981     }
07982     m = *n;
07983 
07984 L30:
07985     l = l1;
07986     lsv = l;
07987     lend = m;
07988     lendsv = lend;
07989     l1 = m + 1;
07990     if (lend == l) {
07991         goto L10;
07992     }
07993 
07994 /*     Scale submatrix in rows and columns L to LEND */
07995 
07996     i__1 = lend - l + 1;
07997     anorm = slanst_("I", &i__1, &d__[l], &e[l]);
07998     iscale = 0;
07999     if (anorm == 0.f) {
08000         goto L10;
08001     }
08002     if (anorm > ssfmax) {
08003         iscale = 1;
08004         i__1 = lend - l + 1;
08005         slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, 
08006                 info);
08007         i__1 = lend - l;
08008         slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, 
08009                 info);
08010     } else if (anorm < ssfmin) {
08011         iscale = 2;
08012         i__1 = lend - l + 1;
08013         slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, 
08014                 info);
08015         i__1 = lend - l;
08016         slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, 
08017                 info);
08018     }
08019 
08020 /*     Choose between QL and QR iteration */
08021 
08022     if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
08023         lend = lsv;
08024         l = lendsv;
08025     }
08026 
08027     if (lend > l) {
08028 
08029 /*        QL Iteration   
08030 
08031           Look for small subdiagonal element. */
08032 
08033 L40:
08034         if (l != lend) {
08035             lendm1 = lend - 1;
08036             i__1 = lendm1;
08037             for (m = l; m <= i__1; ++m) {
08038 /* Computing 2nd power */
08039                 r__2 = (r__1 = e[m], dabs(r__1));
08040                 tst = r__2 * r__2;
08041                 if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m 
08042                         + 1], dabs(r__2)) + safmin) {
08043                     goto L60;
08044                 }
08045 /* L50: */
08046             }
08047         }
08048 
08049         m = lend;
08050 
08051 L60:
08052         if (m < lend) {
08053             e[m] = 0.f;
08054         }
08055         p = d__[l];
08056         if (m == l) {
08057             goto L80;
08058         }
08059 
08060 /*        If remaining matrix is 2-by-2, use SLAE2 or SLAEV2   
08061           to compute its eigensystem. */
08062 
08063         if (m == l + 1) {
08064             if (icompz > 0) {
08065                 slaev2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2, &c__, &s);
08066                 work[l] = c__;
08067                 work[*n - 1 + l] = s;
08068                 slasr_("R", "V", "B", n, &c__2, &work[l], &work[*n - 1 + l], &
08069                         z___ref(1, l), ldz);
08070             } else {
08071                 slae2_(&d__[l], &e[l], &d__[l + 1], &rt1, &rt2);
08072             }
08073             d__[l] = rt1;
08074             d__[l + 1] = rt2;
08075             e[l] = 0.f;
08076             l += 2;
08077             if (l <= lend) {
08078                 goto L40;
08079             }
08080             goto L140;
08081         }
08082 
08083         if (jtot == nmaxit) {
08084             goto L140;
08085         }
08086         ++jtot;
08087 
08088 /*        Form shift. */
08089 
08090         g = (d__[l + 1] - p) / (e[l] * 2.f);
08091         r__ = slapy2_(&g, &c_b10);
08092         g = d__[m] - p + e[l] / (g + r_sign(&r__, &g));
08093 
08094         s = 1.f;
08095         c__ = 1.f;
08096         p = 0.f;
08097 
08098 /*        Inner loop */
08099 
08100         mm1 = m - 1;
08101         i__1 = l;
08102         for (i__ = mm1; i__ >= i__1; --i__) {
08103             f = s * e[i__];
08104             b = c__ * e[i__];
08105             slartg_(&g, &f, &c__, &s, &r__);
08106             if (i__ != m - 1) {
08107                 e[i__ + 1] = r__;
08108             }
08109             g = d__[i__ + 1] - p;
08110             r__ = (d__[i__] - g) * s + c__ * 2.f * b;
08111             p = s * r__;
08112             d__[i__ + 1] = g + p;
08113             g = c__ * r__ - b;
08114 
08115 /*           If eigenvectors are desired, then save rotations. */
08116 
08117             if (icompz > 0) {
08118                 work[i__] = c__;
08119                 work[*n - 1 + i__] = -s;
08120             }
08121 
08122 /* L70: */
08123         }
08124 
08125 /*        If eigenvectors are desired, then apply saved rotations. */
08126 
08127         if (icompz > 0) {
08128             mm = m - l + 1;
08129             slasr_("R", "V", "B", n, &mm, &work[l], &work[*n - 1 + l], &
08130                     z___ref(1, l), ldz);
08131         }
08132 
08133         d__[l] -= p;
08134         e[l] = g;
08135         goto L40;
08136 
08137 /*        Eigenvalue found. */
08138 
08139 L80:
08140         d__[l] = p;
08141 
08142         ++l;
08143         if (l <= lend) {
08144             goto L40;
08145         }
08146         goto L140;
08147 
08148     } else {
08149 
08150 /*        QR Iteration   
08151 
08152           Look for small superdiagonal element. */
08153 
08154 L90:
08155         if (l != lend) {
08156             lendp1 = lend + 1;
08157             i__1 = lendp1;
08158             for (m = l; m >= i__1; --m) {
08159 /* Computing 2nd power */
08160                 r__2 = (r__1 = e[m - 1], dabs(r__1));
08161                 tst = r__2 * r__2;
08162                 if (tst <= eps2 * (r__1 = d__[m], dabs(r__1)) * (r__2 = d__[m 
08163                         - 1], dabs(r__2)) + safmin) {
08164                     goto L110;
08165                 }
08166 /* L100: */
08167             }
08168         }
08169 
08170         m = lend;
08171 
08172 L110:
08173         if (m > lend) {
08174             e[m - 1] = 0.f;
08175         }
08176         p = d__[l];
08177         if (m == l) {
08178             goto L130;
08179         }
08180 
08181 /*        If remaining matrix is 2-by-2, use SLAE2 or SLAEV2   
08182           to compute its eigensystem. */
08183 
08184         if (m == l - 1) {
08185             if (icompz > 0) {
08186                 slaev2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2, &c__, &s)
08187                         ;
08188                 work[m] = c__;
08189                 work[*n - 1 + m] = s;
08190                 slasr_("R", "V", "F", n, &c__2, &work[m], &work[*n - 1 + m], &
08191                         z___ref(1, l - 1), ldz);
08192             } else {
08193                 slae2_(&d__[l - 1], &e[l - 1], &d__[l], &rt1, &rt2);
08194             }
08195             d__[l - 1] = rt1;
08196             d__[l] = rt2;
08197             e[l - 1] = 0.f;
08198             l += -2;
08199             if (l >= lend) {
08200                 goto L90;
08201             }
08202             goto L140;
08203         }
08204 
08205         if (jtot == nmaxit) {
08206             goto L140;
08207         }
08208         ++jtot;
08209 
08210 /*        Form shift. */
08211 
08212         g = (d__[l - 1] - p) / (e[l - 1] * 2.f);
08213         r__ = slapy2_(&g, &c_b10);
08214         g = d__[m] - p + e[l - 1] / (g + r_sign(&r__, &g));
08215 
08216         s = 1.f;
08217         c__ = 1.f;
08218         p = 0.f;
08219 
08220 /*        Inner loop */
08221 
08222         lm1 = l - 1;
08223         i__1 = lm1;
08224         for (i__ = m; i__ <= i__1; ++i__) {
08225             f = s * e[i__];
08226             b = c__ * e[i__];
08227             slartg_(&g, &f, &c__, &s, &r__);
08228             if (i__ != m) {
08229                 e[i__ - 1] = r__;
08230             }
08231             g = d__[i__] - p;
08232             r__ = (d__[i__ + 1] - g) * s + c__ * 2.f * b;
08233             p = s * r__;
08234             d__[i__] = g + p;
08235             g = c__ * r__ - b;
08236 
08237 /*           If eigenvectors are desired, then save rotations. */
08238 
08239             if (icompz > 0) {
08240                 work[i__] = c__;
08241                 work[*n - 1 + i__] = s;
08242             }
08243 
08244 /* L120: */
08245         }
08246 
08247 /*        If eigenvectors are desired, then apply saved rotations. */
08248 
08249         if (icompz > 0) {
08250             mm = l - m + 1;
08251             slasr_("R", "V", "F", n, &mm, &work[m], &work[*n - 1 + m], &
08252                     z___ref(1, m), ldz);
08253         }
08254 
08255         d__[l] -= p;
08256         e[lm1] = g;
08257         goto L90;
08258 
08259 /*        Eigenvalue found. */
08260 
08261 L130:
08262         d__[l] = p;
08263 
08264         --l;
08265         if (l >= lend) {
08266             goto L90;
08267         }
08268         goto L140;
08269 
08270     }
08271 
08272 /*     Undo scaling if necessary */
08273 
08274 L140:
08275     if (iscale == 1) {
08276         i__1 = lendsv - lsv + 1;
08277         slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], 
08278                 n, info);
08279         i__1 = lendsv - lsv;
08280         slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &e[lsv], n, 
08281                 info);
08282     } else if (iscale == 2) {
08283         i__1 = lendsv - lsv + 1;
08284         slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], 
08285                 n, info);
08286         i__1 = lendsv - lsv;
08287         slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &e[lsv], n, 
08288                 info);
08289     }
08290 
08291 /*     Check for no convergence to an eigenvalue after a total   
08292        of N*MAXIT iterations. */
08293 
08294     if (jtot < nmaxit) {
08295         goto L10;
08296     }
08297     i__1 = *n - 1;
08298     for (i__ = 1; i__ <= i__1; ++i__) {
08299         if (e[i__] != 0.f) {
08300             ++(*info);
08301         }
08302 /* L150: */
08303     }
08304     goto L190;
08305 
08306 /*     Order eigenvalues and eigenvectors. */
08307 
08308 L160:
08309     if (icompz == 0) {
08310 
08311 /*        Use Quick Sort */
08312 
08313         slasrt_("I", n, &d__[1], info);
08314 
08315     } else {
08316 
08317 /*        Use Selection Sort to minimize swaps of eigenvectors */
08318 
08319         i__1 = *n;
08320         for (ii = 2; ii <= i__1; ++ii) {
08321             i__ = ii - 1;
08322             k = i__;
08323             p = d__[i__];
08324             i__2 = *n;
08325             for (j = ii; j <= i__2; ++j) {
08326                 if (d__[j] < p) {
08327                     k = j;
08328                     p = d__[j];
08329                 }
08330 /* L170: */
08331             }
08332             if (k != i__) {
08333                 d__[k] = d__[i__];
08334                 d__[i__] = p;
08335                 sswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, k), &c__1);
08336             }
08337 /* L180: */
08338         }
08339     }
08340 
08341 L190:
08342     return 0;
08343 
08344 /*     End of SSTEQR */
08345 
08346 } /* ssteqr_ */
08347 
08348 #undef z___ref
08349 
08350 
08351 
08352 
08353 
08354 /* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info)
08355 {
08356 /*  -- LAPACK routine (version 3.0) --   
08357        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
08358        Courant Institute, Argonne National Lab, and Rice University   
08359        June 30, 1999   
08360 
08361 
08362     Purpose   
08363     =======   
08364 
08365     SSTERF computes all eigenvalues of a symmetric tridiagonal matrix   
08366     using the Pal-Walker-Kahan variant of the QL or QR algorithm.   
08367 
08368     Arguments   
08369     =========   
08370 
08371     N       (input) INTEGER   
08372             The order of the matrix.  N >= 0.   
08373 
08374     D       (input/output) REAL array, dimension (N)   
08375             On entry, the n diagonal elements of the tridiagonal matrix.   
08376             On exit, if INFO = 0, the eigenvalues in ascending order.   
08377 
08378     E       (input/output) REAL array, dimension (N-1)   
08379             On entry, the (n-1) subdiagonal elements of the tridiagonal   
08380             matrix.   
08381             On exit, E has been destroyed.   
08382 
08383     INFO    (output) INTEGER   
08384             = 0:  successful exit   
08385             < 0:  if INFO = -i, the i-th argument had an illegal value   
08386             > 0:  the algorithm failed to find all of the eigenvalues in   
08387                   a total of 30*N iterations; if INFO = i, then i   
08388                   elements of E have not converged to zero.   
08389 
08390     =====================================================================   
08391 
08392 
08393        Test the input parameters.   
08394 
08395        Parameter adjustments */
08396     /* Table of constant values */
08397     static integer c__0 = 0;
08398     static integer c__1 = 1;
08399     static real c_b32 = 1.f;
08400     
08401     /* System generated locals */
08402     integer i__1;
08403     real r__1, r__2, r__3;
08404     /* Builtin functions */
08405 //    double sqrt(doublereal), r_sign(real *, real *);
08406     double r_sign(real *, real *);
08407     /* Local variables */
08408     static real oldc;
08409     static integer lend, jtot;
08410     extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
08411             ;
08412     static real c__;
08413     static integer i__, l, m;
08414     static real p, gamma, r__, s, alpha, sigma, anorm;
08415     static integer l1;
08416     static real bb;
08417     extern doublereal slapy2_(real *, real *);
08418     static integer iscale;
08419     static real oldgam;
08420     extern doublereal slamch_(const char *);
08421     static real safmin;
08422     extern /* Subroutine */ int xerbla_(const char *, integer *);
08423     static real safmax;
08424     extern /* Subroutine */ int slascl_(const char *, integer *, integer *, real *, 
08425             real *, integer *, integer *, real *, integer *, integer *);
08426     static integer lendsv;
08427     static real ssfmin;
08428     static integer nmaxit;
08429     static real ssfmax;
08430     extern doublereal slanst_(const char *, integer *, real *, real *);
08431     extern /* Subroutine */ int slasrt_(const char *, integer *, real *, integer *);
08432     static real rt1, rt2, eps, rte;
08433     static integer lsv;
08434     static real eps2;
08435 
08436 
08437     --e;
08438     --d__;
08439 
08440     /* Function Body */
08441     *info = 0;
08442 
08443 /*     Quick return if possible */
08444 
08445     if (*n < 0) {
08446         *info = -1;
08447         i__1 = -(*info);
08448         xerbla_("SSTERF", &i__1);
08449         return 0;
08450     }
08451     if (*n <= 1) {
08452         return 0;
08453     }
08454 
08455 /*     Determine the unit roundoff for this environment. */
08456 
08457     eps = slamch_("E");
08458 /* Computing 2nd power */
08459     r__1 = eps;
08460     eps2 = r__1 * r__1;
08461     safmin = slamch_("S");
08462     safmax = 1.f / safmin;
08463     ssfmax = sqrt(safmax) / 3.f;
08464     ssfmin = sqrt(safmin) / eps2;
08465 
08466 /*     Compute the eigenvalues of the tridiagonal matrix. */
08467 
08468     nmaxit = *n * 30;
08469     sigma = 0.f;
08470     jtot = 0;
08471 
08472 /*     Determine where the matrix splits and choose QL or QR iteration   
08473        for each block, according to whether top or bottom diagonal   
08474        element is smaller. */
08475 
08476     l1 = 1;
08477 
08478 L10:
08479     if (l1 > *n) {
08480         goto L170;
08481     }
08482     if (l1 > 1) {
08483         e[l1 - 1] = 0.f;
08484     }
08485     i__1 = *n - 1;
08486     for (m = l1; m <= i__1; ++m) {
08487         if ((r__3 = e[m], dabs(r__3)) <= sqrt((r__1 = d__[m], dabs(r__1))) * 
08488                 sqrt((r__2 = d__[m + 1], dabs(r__2))) * eps) {
08489             e[m] = 0.f;
08490             goto L30;
08491         }
08492 /* L20: */
08493     }
08494     m = *n;
08495 
08496 L30:
08497     l = l1;
08498     lsv = l;
08499     lend = m;
08500     lendsv = lend;
08501     l1 = m + 1;
08502     if (lend == l) {
08503         goto L10;
08504     }
08505 
08506 /*     Scale submatrix in rows and columns L to LEND */
08507 
08508     i__1 = lend - l + 1;
08509     anorm = slanst_("I", &i__1, &d__[l], &e[l]);
08510     iscale = 0;
08511     if (anorm > ssfmax) {
08512         iscale = 1;
08513         i__1 = lend - l + 1;
08514         slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, 
08515                 info);
08516         i__1 = lend - l;
08517         slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, 
08518                 info);
08519     } else if (anorm < ssfmin) {
08520         iscale = 2;
08521         i__1 = lend - l + 1;
08522         slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, 
08523                 info);
08524         i__1 = lend - l;
08525         slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, 
08526                 info);
08527     }
08528 
08529     i__1 = lend - 1;
08530     for (i__ = l; i__ <= i__1; ++i__) {
08531 /* Computing 2nd power */
08532         r__1 = e[i__];
08533         e[i__] = r__1 * r__1;
08534 /* L40: */
08535     }
08536 
08537 /*     Choose between QL and QR iteration */
08538 
08539     if ((r__1 = d__[lend], dabs(r__1)) < (r__2 = d__[l], dabs(r__2))) {
08540         lend = lsv;
08541         l = lendsv;
08542     }
08543 
08544     if (lend >= l) {
08545 
08546 /*        QL Iteration   
08547 
08548           Look for small subdiagonal element. */
08549 
08550 L50:
08551         if (l != lend) {
08552             i__1 = lend - 1;
08553             for (m = l; m <= i__1; ++m) {
08554                 if ((r__2 = e[m], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
08555                         m + 1], dabs(r__1))) {
08556                     goto L70;
08557                 }
08558 /* L60: */
08559             }
08560         }
08561         m = lend;
08562 
08563 L70:
08564         if (m < lend) {
08565             e[m] = 0.f;
08566         }
08567         p = d__[l];
08568         if (m == l) {
08569             goto L90;
08570         }
08571 
08572 /*        If remaining matrix is 2 by 2, use SLAE2 to compute its   
08573           eigenvalues. */
08574 
08575         if (m == l + 1) {
08576             rte = sqrt(e[l]);
08577             slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
08578             d__[l] = rt1;
08579             d__[l + 1] = rt2;
08580             e[l] = 0.f;
08581             l += 2;
08582             if (l <= lend) {
08583                 goto L50;
08584             }
08585             goto L150;
08586         }
08587 
08588         if (jtot == nmaxit) {
08589             goto L150;
08590         }
08591         ++jtot;
08592 
08593 /*        Form shift. */
08594 
08595         rte = sqrt(e[l]);
08596         sigma = (d__[l + 1] - p) / (rte * 2.f);
08597         r__ = slapy2_(&sigma, &c_b32);
08598         sigma = p - rte / (sigma + r_sign(&r__, &sigma));
08599 
08600         c__ = 1.f;
08601         s = 0.f;
08602         gamma = d__[m] - sigma;
08603         p = gamma * gamma;
08604 
08605 /*        Inner loop */
08606 
08607         i__1 = l;
08608         for (i__ = m - 1; i__ >= i__1; --i__) {
08609             bb = e[i__];
08610             r__ = p + bb;
08611             if (i__ != m - 1) {
08612                 e[i__ + 1] = s * r__;
08613             }
08614             oldc = c__;
08615             c__ = p / r__;
08616             s = bb / r__;
08617             oldgam = gamma;
08618             alpha = d__[i__];
08619             gamma = c__ * (alpha - sigma) - s * oldgam;
08620             d__[i__ + 1] = oldgam + (alpha - gamma);
08621             if (c__ != 0.f) {
08622                 p = gamma * gamma / c__;
08623             } else {
08624                 p = oldc * bb;
08625             }
08626 /* L80: */
08627         }
08628 
08629         e[l] = s * p;
08630         d__[l] = sigma + gamma;
08631         goto L50;
08632 
08633 /*        Eigenvalue found. */
08634 
08635 L90:
08636         d__[l] = p;
08637 
08638         ++l;
08639         if (l <= lend) {
08640             goto L50;
08641         }
08642         goto L150;
08643 
08644     } else {
08645 
08646 /*        QR Iteration   
08647 
08648           Look for small superdiagonal element. */
08649 
08650 L100:
08651         i__1 = lend + 1;
08652         for (m = l; m >= i__1; --m) {
08653             if ((r__2 = e[m - 1], dabs(r__2)) <= eps2 * (r__1 = d__[m] * d__[
08654                     m - 1], dabs(r__1))) {
08655                 goto L120;
08656             }
08657 /* L110: */
08658         }
08659         m = lend;
08660 
08661 L120:
08662         if (m > lend) {
08663             e[m - 1] = 0.f;
08664         }
08665         p = d__[l];
08666         if (m == l) {
08667             goto L140;
08668         }
08669 
08670 /*        If remaining matrix is 2 by 2, use SLAE2 to compute its   
08671           eigenvalues. */
08672 
08673         if (m == l - 1) {
08674             rte = sqrt(e[l - 1]);
08675             slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
08676             d__[l] = rt1;
08677             d__[l - 1] = rt2;
08678             e[l - 1] = 0.f;
08679             l += -2;
08680             if (l >= lend) {
08681                 goto L100;
08682             }
08683             goto L150;
08684         }
08685 
08686         if (jtot == nmaxit) {
08687             goto L150;
08688         }
08689         ++jtot;
08690 
08691 /*        Form shift. */
08692 
08693         rte = sqrt(e[l - 1]);
08694         sigma = (d__[l - 1] - p) / (rte * 2.f);
08695         r__ = slapy2_(&sigma, &c_b32);
08696         sigma = p - rte / (sigma + r_sign(&r__, &sigma));
08697 
08698         c__ = 1.f;
08699         s = 0.f;
08700         gamma = d__[m] - sigma;
08701         p = gamma * gamma;
08702 
08703 /*        Inner loop */
08704 
08705         i__1 = l - 1;
08706         for (i__ = m; i__ <= i__1; ++i__) {
08707             bb = e[i__];
08708             r__ = p + bb;
08709             if (i__ != m) {
08710                 e[i__ - 1] = s * r__;
08711             }
08712             oldc = c__;
08713             c__ = p / r__;
08714             s = bb / r__;
08715             oldgam = gamma;
08716             alpha = d__[i__ + 1];
08717             gamma = c__ * (alpha - sigma) - s * oldgam;
08718             d__[i__] = oldgam + (alpha - gamma);
08719             if (c__ != 0.f) {
08720                 p = gamma * gamma / c__;
08721             } else {
08722                 p = oldc * bb;
08723             }
08724 /* L130: */
08725         }
08726 
08727         e[l - 1] = s * p;
08728         d__[l] = sigma + gamma;
08729         goto L100;
08730 
08731 /*        Eigenvalue found. */
08732 
08733 L140:
08734         d__[l] = p;
08735 
08736         --l;
08737         if (l >= lend) {
08738             goto L100;
08739         }
08740         goto L150;
08741 
08742     }
08743 
08744 /*     Undo scaling if necessary */
08745 
08746 L150:
08747     if (iscale == 1) {
08748         i__1 = lendsv - lsv + 1;
08749         slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], 
08750                 n, info);
08751     }
08752     if (iscale == 2) {
08753         i__1 = lendsv - lsv + 1;
08754         slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], 
08755                 n, info);
08756     }
08757 
08758 /*     Check for no convergence to an eigenvalue after a total   
08759        of N*MAXIT iterations. */
08760 
08761     if (jtot < nmaxit) {
08762         goto L10;
08763     }
08764     i__1 = *n - 1;
08765     for (i__ = 1; i__ <= i__1; ++i__) {
08766         if (e[i__] != 0.f) {
08767             ++(*info);
08768         }
08769 /* L160: */
08770     }
08771     goto L180;
08772 
08773 /*     Sort eigenvalues in increasing order. */
08774 
08775 L170:
08776     slasrt_("I", n, &d__[1], info);
08777 
08778 L180:
08779     return 0;
08780 
08781 /*     End of SSTERF */
08782 
08783 } /* ssterf_ */
08784 
08785 
08786 
08787 
08788 /* Subroutine */ int sswap_(integer *n, real *sx, integer *incx, real *sy, 
08789         integer *incy)
08790 {
08791     /* System generated locals */
08792     integer i__1;
08793     /* Local variables */
08794     static integer i__, m;
08795     static real stemp;
08796     static integer ix, iy, mp1;
08797 /*     interchanges two vectors.   
08798        uses unrolled loops for increments equal to 1.   
08799        jack dongarra, linpack, 3/11/78.   
08800        modified 12/3/93, array(1) declarations changed to array(*)   
08801        Parameter adjustments */
08802     --sy;
08803     --sx;
08804     /* Function Body */
08805     if (*n <= 0) {
08806         return 0;
08807     }
08808     if (*incx == 1 && *incy == 1) {
08809         goto L20;
08810     }
08811 /*       code for unequal increments or equal increments not equal   
08812            to 1 */
08813     ix = 1;
08814     iy = 1;
08815     if (*incx < 0) {
08816         ix = (-(*n) + 1) * *incx + 1;
08817     }
08818     if (*incy < 0) {
08819         iy = (-(*n) + 1) * *incy + 1;
08820     }
08821     i__1 = *n;
08822     for (i__ = 1; i__ <= i__1; ++i__) {
08823         stemp = sx[ix];
08824         sx[ix] = sy[iy];
08825         sy[iy] = stemp;
08826         ix += *incx;
08827         iy += *incy;
08828 /* L10: */
08829     }
08830     return 0;
08831 /*       code for both increments equal to 1   
08832          clean-up loop */
08833 L20:
08834     m = *n % 3;
08835     if (m == 0) {
08836         goto L40;
08837     }
08838     i__1 = m;
08839     for (i__ = 1; i__ <= i__1; ++i__) {
08840         stemp = sx[i__];
08841         sx[i__] = sy[i__];
08842         sy[i__] = stemp;
08843 /* L30: */
08844     }
08845     if (*n < 3) {
08846         return 0;
08847     }
08848 L40:
08849     mp1 = m + 1;
08850     i__1 = *n;
08851     for (i__ = mp1; i__ <= i__1; i__ += 3) {
08852         stemp = sx[i__];
08853         sx[i__] = sy[i__];
08854         sy[i__] = stemp;
08855         stemp = sx[i__ + 1];
08856         sx[i__ + 1] = sy[i__ + 1];
08857         sy[i__ + 1] = stemp;
08858         stemp = sx[i__ + 2];
08859         sx[i__ + 2] = sy[i__ + 2];
08860         sy[i__ + 2] = stemp;
08861 /* L50: */
08862     }
08863     return 0;
08864 } /* sswap_ */
08865 
08866 
08867 
08868 
08869 /* Subroutine */ int ssyev_(char *jobz, char *uplo, integer *n, real *a, 
08870         integer *lda, real *w, real *work, integer *lwork, integer *info)
08871 {
08872 /*  -- LAPACK driver routine (version 3.0) --   
08873        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
08874        Courant Institute, Argonne National Lab, and Rice University   
08875        June 30, 1999   
08876 
08877 
08878     Purpose   
08879     =======   
08880 
08881     SSYEV computes all eigenvalues and, optionally, eigenvectors of a   
08882     real symmetric matrix A.   
08883 
08884     Arguments   
08885     =========   
08886 
08887     JOBZ    (input) CHARACTER*1   
08888             = 'N':  Compute eigenvalues only;   
08889             = 'V':  Compute eigenvalues and eigenvectors.   
08890 
08891     UPLO    (input) CHARACTER*1   
08892             = 'U':  Upper triangle of A is stored;   
08893             = 'L':  Lower triangle of A is stored.   
08894 
08895     N       (input) INTEGER   
08896             The order of the matrix A.  N >= 0.   
08897 
08898     A       (input/output) REAL array, dimension (LDA, N)   
08899             On entry, the symmetric matrix A.  If UPLO = 'U', the   
08900             leading N-by-N upper triangular part of A contains the   
08901             upper triangular part of the matrix A.  If UPLO = 'L',   
08902             the leading N-by-N lower triangular part of A contains   
08903             the lower triangular part of the matrix A.   
08904             On exit, if JOBZ = 'V', then if INFO = 0, A contains the   
08905             orthonormal eigenvectors of the matrix A.   
08906             If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')   
08907             or the upper triangle (if UPLO='U') of A, including the   
08908             diagonal, is destroyed.   
08909 
08910     LDA     (input) INTEGER   
08911             The leading dimension of the array A.  LDA >= f2cmax(1,N).   
08912 
08913     W       (output) REAL array, dimension (N)   
08914             If INFO = 0, the eigenvalues in ascending order.   
08915 
08916     WORK    (workspace/output) REAL array, dimension (LWORK)   
08917             On exit, if INFO = 0, WORK(1) returns the optimal LWORK.   
08918 
08919     LWORK   (input) INTEGER   
08920             The length of the array WORK.  LWORK >= f2cmax(1,3*N-1).   
08921             For optimal efficiency, LWORK >= (NB+2)*N,   
08922             where NB is the blocksize for SSYTRD returned by ILAENV.   
08923 
08924             If LWORK = -1, then a workspace query is assumed; the routine   
08925             only calculates the optimal size of the WORK array, returns   
08926             this value as the first entry of the WORK array, and no error   
08927             message related to LWORK is issued by XERBLA.   
08928 
08929     INFO    (output) INTEGER   
08930             = 0:  successful exit   
08931             < 0:  if INFO = -i, the i-th argument had an illegal value   
08932             > 0:  if INFO = i, the algorithm failed to converge; i   
08933                   off-diagonal elements of an intermediate tridiagonal   
08934                   form did not converge to zero.   
08935 
08936     =====================================================================   
08937 
08938 
08939        Test the input parameters.   
08940 
08941        Parameter adjustments */
08942     /* Table of constant values */
08943     static integer c__1 = 1;
08944     static integer c_n1 = -1;
08945     static integer c__0 = 0;
08946     static real c_b17 = 1.f;
08947     
08948     /* System generated locals */
08949     integer a_dim1, a_offset, i__1, i__2;
08950     real r__1;
08951     /* Builtin functions */
08952 //    double sqrt(doublereal);
08953     /* Local variables */
08954     static integer inde;
08955     static real anrm;
08956     static integer imax;
08957     static real rmin, rmax;
08958     static integer lopt;
08959     static real sigma;
08960     extern logical lsame_(const char *, const char *);
08961     static integer iinfo;
08962     extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
08963     static logical lower, wantz;
08964     static integer nb, iscale;
08965     extern doublereal slamch_(const char *);
08966     static real safmin;
08967     extern integer ilaenv_(integer *, const char *, const char *, integer *, integer *, 
08968             integer *, integer *, ftnlen, ftnlen);
08969     extern /* Subroutine */ int xerbla_(const char *, integer *);
08970     static real bignum;
08971     extern /* Subroutine */ int slascl_(const char *, integer *, integer *, real *, 
08972             real *, integer *, integer *, real *, integer *, integer *);
08973     static integer indtau, indwrk;
08974     extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
08975     extern doublereal slansy_(const char *, char *, integer *, real *, integer *, 
08976             real *);
08977     static integer llwork;
08978     static real smlnum;
08979     static integer lwkopt;
08980     static logical lquery;
08981     extern /* Subroutine */ int sorgtr_(char *, integer *, real *, integer *, 
08982             real *, real *, integer *, integer *), ssteqr_(const char *, 
08983             integer *, real *, real *, real *, integer *, real *, integer *), ssytrd_(char *, integer *, real *, integer *, real *, 
08984             real *, real *, real *, integer *, integer *);
08985     static real eps;
08986 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
08987 
08988 
08989     a_dim1 = *lda;
08990     a_offset = 1 + a_dim1 * 1;
08991     a -= a_offset;
08992     --w;
08993     --work;
08994 
08995     /* Function Body */
08996     wantz = lsame_(jobz, "V");
08997     lower = lsame_(uplo, "L");
08998     lquery = *lwork == -1;
08999 
09000     *info = 0;
09001     if (! (wantz || lsame_(jobz, "N"))) {
09002         *info = -1;
09003     } else if (! (lower || lsame_(uplo, "U"))) {
09004         *info = -2;
09005     } else if (*n < 0) {
09006         *info = -3;
09007     } else if (*lda < f2cmax(1,*n)) {
09008         *info = -5;
09009     } else /* if(complicated condition) */ {
09010 /* Computing MAX */
09011         i__1 = 1, i__2 = *n * 3 - 1;
09012         if (*lwork < f2cmax(i__1,i__2) && ! lquery) {
09013             *info = -8;
09014         }
09015     }
09016 
09017     if (*info == 0) {
09018         nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
09019                  (ftnlen)1);
09020 /* Computing MAX */
09021         i__1 = 1, i__2 = (nb + 2) * *n;
09022         lwkopt = f2cmax(i__1,i__2);
09023         work[1] = (real) lwkopt;
09024     }
09025 
09026     if (*info != 0) {
09027         i__1 = -(*info);
09028         xerbla_("SSYEV ", &i__1);
09029         return 0;
09030     } else if (lquery) {
09031         return 0;
09032     }
09033 
09034 /*     Quick return if possible */
09035 
09036     if (*n == 0) {
09037         work[1] = 1.f;
09038         return 0;
09039     }
09040 
09041     if (*n == 1) {
09042         w[1] = a_ref(1, 1);
09043         work[1] = 3.f;
09044         if (wantz) {
09045             a_ref(1, 1) = 1.f;
09046         }
09047         return 0;
09048     }
09049 
09050 /*     Get machine constants. */
09051 
09052     safmin = slamch_("Safe minimum");
09053     eps = slamch_("Precision");
09054     smlnum = safmin / eps;
09055     bignum = 1.f / smlnum;
09056     rmin = sqrt(smlnum);
09057     rmax = sqrt(bignum);
09058 
09059 /*     Scale matrix to allowable range, if necessary. */
09060 
09061     anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
09062     iscale = 0;
09063     if (anrm > 0.f && anrm < rmin) {
09064         iscale = 1;
09065         sigma = rmin / anrm;
09066     } else if (anrm > rmax) {
09067         iscale = 1;
09068         sigma = rmax / anrm;
09069     }
09070     if (iscale == 1) {
09071         slascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, 
09072                 info);
09073     }
09074 
09075 /*     Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
09076 
09077     inde = 1;
09078     indtau = inde + *n;
09079     indwrk = indtau + *n;
09080     llwork = *lwork - indwrk + 1;
09081     ssytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
09082             work[indwrk], &llwork, &iinfo);
09083     lopt = static_cast<integer>( (*n << 1) + work[indwrk] );
09084 
09085 /*     For eigenvalues only, call SSTERF.  For eigenvectors, first call   
09086        SORGTR to generate the orthogonal matrix, then call SSTEQR. */
09087 
09088     if (! wantz) {
09089         ssterf_(n, &w[1], &work[inde], info);
09090     } else {
09091         sorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
09092                 llwork, &iinfo);
09093         ssteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
09094                  info);
09095     }
09096 
09097 /*     If matrix was scaled, then rescale eigenvalues appropriately. */
09098 
09099     if (iscale == 1) {
09100         if (*info == 0) {
09101             imax = *n;
09102         } else {
09103             imax = *info - 1;
09104         }
09105         r__1 = 1.f / sigma;
09106         sscal_(&imax, &r__1, &w[1], &c__1);
09107     }
09108 
09109 /*     Set WORK(1) to optimal workspace size. */
09110 
09111     work[1] = (real) lwkopt;
09112 
09113     return 0;
09114 
09115 /*     End of SSYEV */
09116 
09117 } /* ssyev_ */
09118 
09119 #undef a_ref
09120 
09121 
09122 
09123 
09124 
09125 /* Subroutine */ int ssymv_(const char *uplo, integer *n, real *alpha, real *a, 
09126         integer *lda, real *x, integer *incx, real *beta, real *y, integer *
09127         incy)
09128 {
09129     /* System generated locals */
09130     integer a_dim1, a_offset, i__1, i__2;
09131     /* Local variables */
09132     static integer info;
09133     static real temp1, temp2;
09134     static integer i__, j;
09135     extern logical lsame_(const char *, const char *);
09136     static integer ix, iy, jx, jy, kx, ky;
09137     extern /* Subroutine */ int xerbla_(const char *, integer *);
09138 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
09139 /*  Purpose   
09140     =======   
09141     SSYMV  performs the matrix-vector  operation   
09142        y := alpha*A*x + beta*y,   
09143     where alpha and beta are scalars, x and y are n element vectors and   
09144     A is an n by n symmetric matrix.   
09145     Parameters   
09146     ==========   
09147     UPLO   - CHARACTER*1.   
09148              On entry, UPLO specifies whether the upper or lower   
09149              triangular part of the array A is to be referenced as   
09150              follows:   
09151                 UPLO = 'U' or 'u'   Only the upper triangular part of A   
09152                                     is to be referenced.   
09153                 UPLO = 'L' or 'l'   Only the lower triangular part of A   
09154                                     is to be referenced.   
09155              Unchanged on exit.   
09156     N      - INTEGER.   
09157              On entry, N specifies the order of the matrix A.   
09158              N must be at least zero.   
09159              Unchanged on exit.   
09160     ALPHA  - REAL            .   
09161              On entry, ALPHA specifies the scalar alpha.   
09162              Unchanged on exit.   
09163     A      - REAL             array of DIMENSION ( LDA, n ).   
09164              Before entry with  UPLO = 'U' or 'u', the leading n by n   
09165              upper triangular part of the array A must contain the upper   
09166              triangular part of the symmetric matrix and the strictly   
09167              lower triangular part of A is not referenced.   
09168              Before entry with UPLO = 'L' or 'l', the leading n by n   
09169              lower triangular part of the array A must contain the lower   
09170              triangular part of the symmetric matrix and the strictly   
09171              upper triangular part of A is not referenced.   
09172              Unchanged on exit.   
09173     LDA    - INTEGER.   
09174              On entry, LDA specifies the first dimension of A as declared   
09175              in the calling (sub) program. LDA must be at least   
09176              f2cmax( 1, n ).   
09177              Unchanged on exit.   
09178     X      - REAL             array of dimension at least   
09179              ( 1 + ( n - 1 )*abs( INCX ) ).   
09180              Before entry, the incremented array X must contain the n   
09181              element vector x.   
09182              Unchanged on exit.   
09183     INCX   - INTEGER.   
09184              On entry, INCX specifies the increment for the elements of   
09185              X. INCX must not be zero.   
09186              Unchanged on exit.   
09187     BETA   - REAL            .   
09188              On entry, BETA specifies the scalar beta. When BETA is   
09189              supplied as zero then Y need not be set on input.   
09190              Unchanged on exit.   
09191     Y      - REAL             array of dimension at least   
09192              ( 1 + ( n - 1 )*abs( INCY ) ).   
09193              Before entry, the incremented array Y must contain the n   
09194              element vector y. On exit, Y is overwritten by the updated   
09195              vector y.   
09196     INCY   - INTEGER.   
09197              On entry, INCY specifies the increment for the elements of   
09198              Y. INCY must not be zero.   
09199              Unchanged on exit.   
09200     Level 2 Blas routine.   
09201     -- Written on 22-October-1986.   
09202        Jack Dongarra, Argonne National Lab.   
09203        Jeremy Du Croz, Nag Central Office.   
09204        Sven Hammarling, Nag Central Office.   
09205        Richard Hanson, Sandia National Labs.   
09206        Test the input parameters.   
09207        Parameter adjustments */
09208     a_dim1 = *lda;
09209     a_offset = 1 + a_dim1 * 1;
09210     a -= a_offset;
09211     --x;
09212     --y;
09213     /* Function Body */
09214     info = 0;
09215     if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
09216         info = 1;
09217     } else if (*n < 0) {
09218         info = 2;
09219     } else if (*lda < f2cmax(1,*n)) {
09220         info = 5;
09221     } else if (*incx == 0) {
09222         info = 7;
09223     } else if (*incy == 0) {
09224         info = 10;
09225     }
09226     if (info != 0) {
09227         xerbla_("SSYMV ", &info);
09228         return 0;
09229     }
09230 /*     Quick return if possible. */
09231     if (*n == 0 || *alpha == 0.f && *beta == 1.f) {
09232         return 0;
09233     }
09234 /*     Set up the start points in  X  and  Y. */
09235     if (*incx > 0) {
09236         kx = 1;
09237     } else {
09238         kx = 1 - (*n - 1) * *incx;
09239     }
09240     if (*incy > 0) {
09241         ky = 1;
09242     } else {
09243         ky = 1 - (*n - 1) * *incy;
09244     }
09245 /*     Start the operations. In this version the elements of A are   
09246        accessed sequentially with one pass through the triangular part   
09247        of A.   
09248        First form  y := beta*y. */
09249     if (*beta != 1.f) {
09250         if (*incy == 1) {
09251             if (*beta == 0.f) {
09252                 i__1 = *n;
09253                 for (i__ = 1; i__ <= i__1; ++i__) {
09254                     y[i__] = 0.f;
09255 /* L10: */
09256                 }
09257             } else {
09258                 i__1 = *n;
09259                 for (i__ = 1; i__ <= i__1; ++i__) {
09260                     y[i__] = *beta * y[i__];
09261 /* L20: */
09262                 }
09263             }
09264         } else {
09265             iy = ky;
09266             if (*beta == 0.f) {
09267                 i__1 = *n;
09268                 for (i__ = 1; i__ <= i__1; ++i__) {
09269                     y[iy] = 0.f;
09270                     iy += *incy;
09271 /* L30: */
09272                 }
09273             } else {
09274                 i__1 = *n;
09275                 for (i__ = 1; i__ <= i__1; ++i__) {
09276                     y[iy] = *beta * y[iy];
09277                     iy += *incy;
09278 /* L40: */
09279                 }
09280             }
09281         }
09282     }
09283     if (*alpha == 0.f) {
09284         return 0;
09285     }
09286     if (lsame_(uplo, "U")) {
09287 /*        Form  y  when A is stored in upper triangle. */
09288         if (*incx == 1 && *incy == 1) {
09289             i__1 = *n;
09290             for (j = 1; j <= i__1; ++j) {
09291                 temp1 = *alpha * x[j];
09292                 temp2 = 0.f;
09293                 i__2 = j - 1;
09294                 for (i__ = 1; i__ <= i__2; ++i__) {
09295                     y[i__] += temp1 * a_ref(i__, j);
09296                     temp2 += a_ref(i__, j) * x[i__];
09297 /* L50: */
09298                 }
09299                 y[j] = y[j] + temp1 * a_ref(j, j) + *alpha * temp2;
09300 /* L60: */
09301             }
09302         } else {
09303             jx = kx;
09304             jy = ky;
09305             i__1 = *n;
09306             for (j = 1; j <= i__1; ++j) {
09307                 temp1 = *alpha * x[jx];
09308                 temp2 = 0.f;
09309                 ix = kx;
09310                 iy = ky;
09311                 i__2 = j - 1;
09312                 for (i__ = 1; i__ <= i__2; ++i__) {
09313                     y[iy] += temp1 * a_ref(i__, j);
09314                     temp2 += a_ref(i__, j) * x[ix];
09315                     ix += *incx;
09316                     iy += *incy;
09317 /* L70: */
09318                 }
09319                 y[jy] = y[jy] + temp1 * a_ref(j, j) + *alpha * temp2;
09320                 jx += *incx;
09321                 jy += *incy;
09322 /* L80: */
09323             }
09324         }
09325     } else {
09326 /*        Form  y  when A is stored in lower triangle. */
09327         if (*incx == 1 && *incy == 1) {
09328             i__1 = *n;
09329             for (j = 1; j <= i__1; ++j) {
09330                 temp1 = *alpha * x[j];
09331                 temp2 = 0.f;
09332                 y[j] += temp1 * a_ref(j, j);
09333                 i__2 = *n;
09334                 for (i__ = j + 1; i__ <= i__2; ++i__) {
09335                     y[i__] += temp1 * a_ref(i__, j);
09336                     temp2 += a_ref(i__, j) * x[i__];
09337 /* L90: */
09338                 }
09339                 y[j] += *alpha * temp2;
09340 /* L100: */
09341             }
09342         } else {
09343             jx = kx;
09344             jy = ky;
09345             i__1 = *n;
09346             for (j = 1; j <= i__1; ++j) {
09347                 temp1 = *alpha * x[jx];
09348                 temp2 = 0.f;
09349                 y[jy] += temp1 * a_ref(j, j);
09350                 ix = jx;
09351                 iy = jy;
09352                 i__2 = *n;
09353                 for (i__ = j + 1; i__ <= i__2; ++i__) {
09354                     ix += *incx;
09355                     iy += *incy;
09356                     y[iy] += temp1 * a_ref(i__, j);
09357                     temp2 += a_ref(i__, j) * x[ix];
09358 /* L110: */
09359                 }
09360                 y[jy] += *alpha * temp2;
09361                 jx += *incx;
09362                 jy += *incy;
09363 /* L120: */
09364             }
09365         }
09366     }
09367     return 0;
09368 /*     End of SSYMV . */
09369 } /* ssymv_ */
09370 #undef a_ref
09371 
09372 
09373 
09374 
09375 /* Subroutine */ int ssyr2_(char *uplo, integer *n, real *alpha, real *x, 
09376         integer *incx, real *y, integer *incy, real *a, integer *lda)
09377 {
09378     /* System generated locals */
09379     integer a_dim1, a_offset, i__1, i__2;
09380     /* Local variables */
09381     static integer info;
09382     static real temp1, temp2;
09383     static integer i__, j;
09384     extern logical lsame_(const char *, const char *);
09385     static integer ix, iy, jx, jy, kx, ky;
09386     extern /* Subroutine */ int xerbla_(const char *, integer *);
09387 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
09388 /*  Purpose   
09389     =======   
09390     SSYR2  performs the symmetric rank 2 operation   
09391        A := alpha*x*y' + alpha*y*x' + A,   
09392     where alpha is a scalar, x and y are n element vectors and A is an n   
09393     by n symmetric matrix.   
09394     Parameters   
09395     ==========   
09396     UPLO   - CHARACTER*1.   
09397              On entry, UPLO specifies whether the upper or lower   
09398              triangular part of the array A is to be referenced as   
09399              follows:   
09400                 UPLO = 'U' or 'u'   Only the upper triangular part of A   
09401                                     is to be referenced.   
09402                 UPLO = 'L' or 'l'   Only the lower triangular part of A   
09403                                     is to be referenced.   
09404              Unchanged on exit.   
09405     N      - INTEGER.   
09406              On entry, N specifies the order of the matrix A.   
09407              N must be at least zero.   
09408              Unchanged on exit.   
09409     ALPHA  - REAL            .   
09410              On entry, ALPHA specifies the scalar alpha.   
09411              Unchanged on exit.   
09412     X      - REAL             array of dimension at least   
09413              ( 1 + ( n - 1 )*abs( INCX ) ).   
09414              Before entry, the incremented array X must contain the n   
09415              element vector x.   
09416              Unchanged on exit.   
09417     INCX   - INTEGER.   
09418              On entry, INCX specifies the increment for the elements of   
09419              X. INCX must not be zero.   
09420              Unchanged on exit.   
09421     Y      - REAL             array of dimension at least   
09422              ( 1 + ( n - 1 )*abs( INCY ) ).   
09423              Before entry, the incremented array Y must contain the n   
09424              element vector y.   
09425              Unchanged on exit.   
09426     INCY   - INTEGER.   
09427              On entry, INCY specifies the increment for the elements of   
09428              Y. INCY must not be zero.   
09429              Unchanged on exit.   
09430     A      - REAL             array of DIMENSION ( LDA, n ).   
09431              Before entry with  UPLO = 'U' or 'u', the leading n by n   
09432              upper triangular part of the array A must contain the upper   
09433              triangular part of the symmetric matrix and the strictly   
09434              lower triangular part of A is not referenced. On exit, the   
09435              upper triangular part of the array A is overwritten by the   
09436              upper triangular part of the updated matrix.   
09437              Before entry with UPLO = 'L' or 'l', the leading n by n   
09438              lower triangular part of the array A must contain the lower   
09439              triangular part of the symmetric matrix and the strictly   
09440              upper triangular part of A is not referenced. On exit, the   
09441              lower triangular part of the array A is overwritten by the   
09442              lower triangular part of the updated matrix.   
09443     LDA    - INTEGER.   
09444              On entry, LDA specifies the first dimension of A as declared   
09445              in the calling (sub) program. LDA must be at least   
09446              f2cmax( 1, n ).   
09447              Unchanged on exit.   
09448     Level 2 Blas routine.   
09449     -- Written on 22-October-1986.   
09450        Jack Dongarra, Argonne National Lab.   
09451        Jeremy Du Croz, Nag Central Office.   
09452        Sven Hammarling, Nag Central Office.   
09453        Richard Hanson, Sandia National Labs.   
09454        Test the input parameters.   
09455        Parameter adjustments */
09456     --x;
09457     --y;
09458     a_dim1 = *lda;
09459     a_offset = 1 + a_dim1 * 1;
09460     a -= a_offset;
09461     /* Function Body */
09462     info = 0;
09463     if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
09464         info = 1;
09465     } else if (*n < 0) {
09466         info = 2;
09467     } else if (*incx == 0) {
09468         info = 5;
09469     } else if (*incy == 0) {
09470         info = 7;
09471     } else if (*lda < f2cmax(1,*n)) {
09472         info = 9;
09473     }
09474     if (info != 0) {
09475         xerbla_("SSYR2 ", &info);
09476         return 0;
09477     }
09478 /*     Quick return if possible. */
09479     if (*n == 0 || *alpha == 0.f) {
09480         return 0;
09481     }
09482 /*     Set up the start points in X and Y if the increments are not both   
09483        unity. */
09484     if (*incx != 1 || *incy != 1) {
09485         if (*incx > 0) {
09486             kx = 1;
09487         } else {
09488             kx = 1 - (*n - 1) * *incx;
09489         }
09490         if (*incy > 0) {
09491             ky = 1;
09492         } else {
09493             ky = 1 - (*n - 1) * *incy;
09494         }
09495         jx = kx;
09496         jy = ky;
09497     }
09498 /*     Start the operations. In this version the elements of A are   
09499        accessed sequentially with one pass through the triangular part   
09500        of A. */
09501     if (lsame_(uplo, "U")) {
09502 /*        Form  A  when A is stored in the upper triangle. */
09503         if (*incx == 1 && *incy == 1) {
09504             i__1 = *n;
09505             for (j = 1; j <= i__1; ++j) {
09506                 if (x[j] != 0.f || y[j] != 0.f) {
09507                     temp1 = *alpha * y[j];
09508                     temp2 = *alpha * x[j];
09509                     i__2 = j;
09510                     for (i__ = 1; i__ <= i__2; ++i__) {
09511                         a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp1 + y[
09512                                 i__] * temp2;
09513 /* L10: */
09514                     }
09515                 }
09516 /* L20: */
09517             }
09518         } else {
09519             i__1 = *n;
09520             for (j = 1; j <= i__1; ++j) {
09521                 if (x[jx] != 0.f || y[jy] != 0.f) {
09522                     temp1 = *alpha * y[jy];
09523                     temp2 = *alpha * x[jx];
09524                     ix = kx;
09525                     iy = ky;
09526                     i__2 = j;
09527                     for (i__ = 1; i__ <= i__2; ++i__) {
09528                         a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp1 + y[iy] 
09529                                 * temp2;
09530                         ix += *incx;
09531                         iy += *incy;
09532 /* L30: */
09533                     }
09534                 }
09535                 jx += *incx;
09536                 jy += *incy;
09537 /* L40: */
09538             }
09539         }
09540     } else {
09541 /*        Form  A  when A is stored in the lower triangle. */
09542         if (*incx == 1 && *incy == 1) {
09543             i__1 = *n;
09544             for (j = 1; j <= i__1; ++j) {
09545                 if (x[j] != 0.f || y[j] != 0.f) {
09546                     temp1 = *alpha * y[j];
09547                     temp2 = *alpha * x[j];
09548                     i__2 = *n;
09549                     for (i__ = j; i__ <= i__2; ++i__) {
09550                         a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp1 + y[
09551                                 i__] * temp2;
09552 /* L50: */
09553                     }
09554                 }
09555 /* L60: */
09556             }
09557         } else {
09558             i__1 = *n;
09559             for (j = 1; j <= i__1; ++j) {
09560                 if (x[jx] != 0.f || y[jy] != 0.f) {
09561                     temp1 = *alpha * y[jy];
09562                     temp2 = *alpha * x[jx];
09563                     ix = jx;
09564                     iy = jy;
09565                     i__2 = *n;
09566                     for (i__ = j; i__ <= i__2; ++i__) {
09567                         a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp1 + y[iy] 
09568                                 * temp2;
09569                         ix += *incx;
09570                         iy += *incy;
09571 /* L70: */
09572                     }
09573                 }
09574                 jx += *incx;
09575                 jy += *incy;
09576 /* L80: */
09577             }
09578         }
09579     }
09580     return 0;
09581 /*     End of SSYR2 . */
09582 } /* ssyr2_ */
09583 #undef a_ref
09584 
09585 
09586 
09587 
09588 /* Subroutine */ int ssyr2k_(char *uplo, const char *trans, integer *n, integer *k, 
09589         real *alpha, real *a, integer *lda, real *b, integer *ldb, real *beta,
09590          real *c__, integer *ldc)
09591 {
09592     /* System generated locals */
09593     integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
09594             i__3;
09595     /* Local variables */
09596     static integer info;
09597     static real temp1, temp2;
09598     static integer i__, j, l;
09599     extern logical lsame_(const char *, const char *);
09600     static integer nrowa;
09601     static logical upper;
09602     extern /* Subroutine */ int xerbla_(const char *, integer *);
09603 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
09604 #define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1]
09605 #define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1]
09606 /*  Purpose   
09607     =======   
09608     SSYR2K  performs one of the symmetric rank 2k operations   
09609        C := alpha*A*B' + alpha*B*A' + beta*C,   
09610     or   
09611        C := alpha*A'*B + alpha*B'*A + beta*C,   
09612     where  alpha and beta  are scalars, C is an  n by n  symmetric matrix   
09613     and  A and B  are  n by k  matrices  in the  first  case  and  k by n   
09614     matrices in the second case.   
09615     Parameters   
09616     ==========   
09617     UPLO   - CHARACTER*1.   
09618              On  entry,   UPLO  specifies  whether  the  upper  or  lower   
09619              triangular  part  of the  array  C  is to be  referenced  as   
09620              follows:   
09621                 UPLO = 'U' or 'u'   Only the  upper triangular part of  C   
09622                                     is to be referenced.   
09623                 UPLO = 'L' or 'l'   Only the  lower triangular part of  C   
09624                                     is to be referenced.   
09625              Unchanged on exit.   
09626     TRANS  - CHARACTER*1.   
09627              On entry,  TRANS  specifies the operation to be performed as   
09628              follows:   
09629                 TRANS = 'N' or 'n'   C := alpha*A*B' + alpha*B*A' +   
09630                                           beta*C.   
09631                 TRANS = 'T' or 't'   C := alpha*A'*B + alpha*B'*A +   
09632                                           beta*C.   
09633                 TRANS = 'C' or 'c'   C := alpha*A'*B + alpha*B'*A +   
09634                                           beta*C.   
09635              Unchanged on exit.   
09636     N      - INTEGER.   
09637              On entry,  N specifies the order of the matrix C.  N must be   
09638              at least zero.   
09639              Unchanged on exit.   
09640     K      - INTEGER.   
09641              On entry with  TRANS = 'N' or 'n',  K  specifies  the number   
09642              of  columns  of the  matrices  A and B,  and on  entry  with   
09643              TRANS = 'T' or 't' or 'C' or 'c',  K  specifies  the  number   
09644              of rows of the matrices  A and B.  K must be at least  zero.   
09645              Unchanged on exit.   
09646     ALPHA  - REAL            .   
09647              On entry, ALPHA specifies the scalar alpha.   
09648              Unchanged on exit.   
09649     A      - REAL             array of DIMENSION ( LDA, ka ), where ka is   
09650              k  when  TRANS = 'N' or 'n',  and is  n  otherwise.   
09651              Before entry with  TRANS = 'N' or 'n',  the  leading  n by k   
09652              part of the array  A  must contain the matrix  A,  otherwise   
09653              the leading  k by n  part of the array  A  must contain  the   
09654              matrix A.   
09655              Unchanged on exit.   
09656     LDA    - INTEGER.   
09657              On entry, LDA specifies the first dimension of A as declared   
09658              in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'   
09659              then  LDA must be at least  f2cmax( 1, n ), otherwise  LDA must   
09660              be at least  f2cmax( 1, k ).   
09661              Unchanged on exit.   
09662     B      - REAL             array of DIMENSION ( LDB, kb ), where kb is   
09663              k  when  TRANS = 'N' or 'n',  and is  n  otherwise.   
09664              Before entry with  TRANS = 'N' or 'n',  the  leading  n by k   
09665              part of the array  B  must contain the matrix  B,  otherwise   
09666              the leading  k by n  part of the array  B  must contain  the   
09667              matrix B.   
09668              Unchanged on exit.   
09669     LDB    - INTEGER.   
09670              On entry, LDB specifies the first dimension of B as declared   
09671              in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'   
09672              then  LDB must be at least  f2cmax( 1, n ), otherwise  LDB must   
09673              be at least  f2cmax( 1, k ).   
09674              Unchanged on exit.   
09675     BETA   - REAL            .   
09676              On entry, BETA specifies the scalar beta.   
09677              Unchanged on exit.   
09678     C      - REAL             array of DIMENSION ( LDC, n ).   
09679              Before entry  with  UPLO = 'U' or 'u',  the leading  n by n   
09680              upper triangular part of the array C must contain the upper   
09681              triangular part  of the  symmetric matrix  and the strictly   
09682              lower triangular part of C is not referenced.  On exit, the   
09683              upper triangular part of the array  C is overwritten by the   
09684              upper triangular part of the updated matrix.   
09685              Before entry  with  UPLO = 'L' or 'l',  the leading  n by n   
09686              lower triangular part of the array C must contain the lower   
09687              triangular part  of the  symmetric matrix  and the strictly   
09688              upper triangular part of C is not referenced.  On exit, the   
09689              lower triangular part of the array  C is overwritten by the   
09690              lower triangular part of the updated matrix.   
09691     LDC    - INTEGER.   
09692              On entry, LDC specifies the first dimension of C as declared   
09693              in  the  calling  (sub)  program.   LDC  must  be  at  least   
09694              f2cmax( 1, n ).   
09695              Unchanged on exit.   
09696     Level 3 Blas routine.   
09697     -- Written on 8-February-1989.   
09698        Jack Dongarra, Argonne National Laboratory.   
09699        Iain Duff, AERE Harwell.   
09700        Jeremy Du Croz, Numerical Algorithms Group Ltd.   
09701        Sven Hammarling, Numerical Algorithms Group Ltd.   
09702        Test the input parameters.   
09703        Parameter adjustments */
09704     a_dim1 = *lda;
09705     a_offset = 1 + a_dim1 * 1;
09706     a -= a_offset;
09707     b_dim1 = *ldb;
09708     b_offset = 1 + b_dim1 * 1;
09709     b -= b_offset;
09710     c_dim1 = *ldc;
09711     c_offset = 1 + c_dim1 * 1;
09712     c__ -= c_offset;
09713     /* Function Body */
09714     if (lsame_(trans, "N")) {
09715         nrowa = *n;
09716     } else {
09717         nrowa = *k;
09718     }
09719     upper = lsame_(uplo, "U");
09720     info = 0;
09721     if (! upper && ! lsame_(uplo, "L")) {
09722         info = 1;
09723     } else if (! lsame_(trans, "N") && ! lsame_(trans, 
09724             "T") && ! lsame_(trans, "C")) {
09725         info = 2;
09726     } else if (*n < 0) {
09727         info = 3;
09728     } else if (*k < 0) {
09729         info = 4;
09730     } else if (*lda < f2cmax(1,nrowa)) {
09731         info = 7;
09732     } else if (*ldb < f2cmax(1,nrowa)) {
09733         info = 9;
09734     } else if (*ldc < f2cmax(1,*n)) {
09735         info = 12;
09736     }
09737     if (info != 0) {
09738         xerbla_("SSYR2K", &info);
09739         return 0;
09740     }
09741 /*     Quick return if possible. */
09742     if (*n == 0 || (*alpha == 0.f || *k == 0) && *beta == 1.f) {
09743         return 0;
09744     }
09745 /*     And when  alpha.eq.zero. */
09746     if (*alpha == 0.f) {
09747         if (upper) {
09748             if (*beta == 0.f) {
09749                 i__1 = *n;
09750                 for (j = 1; j <= i__1; ++j) {
09751                     i__2 = j;
09752                     for (i__ = 1; i__ <= i__2; ++i__) {
09753                         c___ref(i__, j) = 0.f;
09754 /* L10: */
09755                     }
09756 /* L20: */
09757                 }
09758             } else {
09759                 i__1 = *n;
09760                 for (j = 1; j <= i__1; ++j) {
09761                     i__2 = j;
09762                     for (i__ = 1; i__ <= i__2; ++i__) {
09763                         c___ref(i__, j) = *beta * c___ref(i__, j);
09764 /* L30: */
09765                     }
09766 /* L40: */
09767                 }
09768             }
09769         } else {
09770             if (*beta == 0.f) {
09771                 i__1 = *n;
09772                 for (j = 1; j <= i__1; ++j) {
09773                     i__2 = *n;
09774                     for (i__ = j; i__ <= i__2; ++i__) {
09775                         c___ref(i__, j) = 0.f;
09776 /* L50: */
09777                     }
09778 /* L60: */
09779                 }
09780             } else {
09781                 i__1 = *n;
09782                 for (j = 1; j <= i__1; ++j) {
09783                     i__2 = *n;
09784                     for (i__ = j; i__ <= i__2; ++i__) {
09785                         c___ref(i__, j) = *beta * c___ref(i__, j);
09786 /* L70: */
09787                     }
09788 /* L80: */
09789                 }
09790             }
09791         }
09792         return 0;
09793     }
09794 /*     Start the operations. */
09795     if (lsame_(trans, "N")) {
09796 /*        Form  C := alpha*A*B' + alpha*B*A' + C. */
09797         if (upper) {
09798             i__1 = *n;
09799             for (j = 1; j <= i__1; ++j) {
09800                 if (*beta == 0.f) {
09801                     i__2 = j;
09802                     for (i__ = 1; i__ <= i__2; ++i__) {
09803                         c___ref(i__, j) = 0.f;
09804 /* L90: */
09805                     }
09806                 } else if (*beta != 1.f) {
09807                     i__2 = j;
09808                     for (i__ = 1; i__ <= i__2; ++i__) {
09809                         c___ref(i__, j) = *beta * c___ref(i__, j);
09810 /* L100: */
09811                     }
09812                 }
09813                 i__2 = *k;
09814                 for (l = 1; l <= i__2; ++l) {
09815                     if (a_ref(j, l) != 0.f || b_ref(j, l) != 0.f) {
09816                         temp1 = *alpha * b_ref(j, l);
09817                         temp2 = *alpha * a_ref(j, l);
09818                         i__3 = j;
09819                         for (i__ = 1; i__ <= i__3; ++i__) {
09820                             c___ref(i__, j) = c___ref(i__, j) + a_ref(i__, l) 
09821                                     * temp1 + b_ref(i__, l) * temp2;
09822 /* L110: */
09823                         }
09824                     }
09825 /* L120: */
09826                 }
09827 /* L130: */
09828             }
09829         } else {
09830             i__1 = *n;
09831             for (j = 1; j <= i__1; ++j) {
09832                 if (*beta == 0.f) {
09833                     i__2 = *n;
09834                     for (i__ = j; i__ <= i__2; ++i__) {
09835                         c___ref(i__, j) = 0.f;
09836 /* L140: */
09837                     }
09838                 } else if (*beta != 1.f) {
09839                     i__2 = *n;
09840                     for (i__ = j; i__ <= i__2; ++i__) {
09841                         c___ref(i__, j) = *beta * c___ref(i__, j);
09842 /* L150: */
09843                     }
09844                 }
09845                 i__2 = *k;
09846                 for (l = 1; l <= i__2; ++l) {
09847                     if (a_ref(j, l) != 0.f || b_ref(j, l) != 0.f) {
09848                         temp1 = *alpha * b_ref(j, l);
09849                         temp2 = *alpha * a_ref(j, l);
09850                         i__3 = *n;
09851                         for (i__ = j; i__ <= i__3; ++i__) {
09852                             c___ref(i__, j) = c___ref(i__, j) + a_ref(i__, l) 
09853                                     * temp1 + b_ref(i__, l) * temp2;
09854 /* L160: */
09855                         }
09856                     }
09857 /* L170: */
09858                 }
09859 /* L180: */
09860             }
09861         }
09862     } else {
09863 /*        Form  C := alpha*A'*B + alpha*B'*A + C. */
09864         if (upper) {
09865             i__1 = *n;
09866             for (j = 1; j <= i__1; ++j) {
09867                 i__2 = j;
09868                 for (i__ = 1; i__ <= i__2; ++i__) {
09869                     temp1 = 0.f;
09870                     temp2 = 0.f;
09871                     i__3 = *k;
09872                     for (l = 1; l <= i__3; ++l) {
09873                         temp1 += a_ref(l, i__) * b_ref(l, j);
09874                         temp2 += b_ref(l, i__) * a_ref(l, j);
09875 /* L190: */
09876                     }
09877                     if (*beta == 0.f) {
09878                         c___ref(i__, j) = *alpha * temp1 + *alpha * temp2;
09879                     } else {
09880                         c___ref(i__, j) = *beta * c___ref(i__, j) + *alpha * 
09881                                 temp1 + *alpha * temp2;
09882                     }
09883 /* L200: */
09884                 }
09885 /* L210: */
09886             }
09887         } else {
09888             i__1 = *n;
09889             for (j = 1; j <= i__1; ++j) {
09890                 i__2 = *n;
09891                 for (i__ = j; i__ <= i__2; ++i__) {
09892                     temp1 = 0.f;
09893                     temp2 = 0.f;
09894                     i__3 = *k;
09895                     for (l = 1; l <= i__3; ++l) {
09896                         temp1 += a_ref(l, i__) * b_ref(l, j);
09897                         temp2 += b_ref(l, i__) * a_ref(l, j);
09898 /* L220: */
09899                     }
09900                     if (*beta == 0.f) {
09901                         c___ref(i__, j) = *alpha * temp1 + *alpha * temp2;
09902                     } else {
09903                         c___ref(i__, j) = *beta * c___ref(i__, j) + *alpha * 
09904                                 temp1 + *alpha * temp2;
09905                     }
09906 /* L230: */
09907                 }
09908 /* L240: */
09909             }
09910         }
09911     }
09912     return 0;
09913 /*     End of SSYR2K. */
09914 } /* ssyr2k_ */
09915 #undef c___ref
09916 #undef b_ref
09917 #undef a_ref
09918 
09919 
09920 
09921 
09922 /* Subroutine */ int ssytd2_(char *uplo, integer *n, real *a, integer *lda, 
09923         real *d__, real *e, real *tau, integer *info)
09924 {
09925 /*  -- LAPACK routine (version 3.0) --   
09926        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
09927        Courant Institute, Argonne National Lab, and Rice University   
09928        October 31, 1992   
09929 
09930 
09931     Purpose   
09932     =======   
09933 
09934     SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal   
09935     form T by an orthogonal similarity transformation: Q' * A * Q = T.   
09936 
09937     Arguments   
09938     =========   
09939 
09940     UPLO    (input) CHARACTER*1   
09941             Specifies whether the upper or lower triangular part of the   
09942             symmetric matrix A is stored:   
09943             = 'U':  Upper triangular   
09944             = 'L':  Lower triangular   
09945 
09946     N       (input) INTEGER   
09947             The order of the matrix A.  N >= 0.   
09948 
09949     A       (input/output) REAL array, dimension (LDA,N)   
09950             On entry, the symmetric matrix A.  If UPLO = 'U', the leading   
09951             n-by-n upper triangular part of A contains the upper   
09952             triangular part of the matrix A, and the strictly lower   
09953             triangular part of A is not referenced.  If UPLO = 'L', the   
09954             leading n-by-n lower triangular part of A contains the lower   
09955             triangular part of the matrix A, and the strictly upper   
09956             triangular part of A is not referenced.   
09957             On exit, if UPLO = 'U', the diagonal and first superdiagonal   
09958             of A are overwritten by the corresponding elements of the   
09959             tridiagonal matrix T, and the elements above the first   
09960             superdiagonal, with the array TAU, represent the orthogonal   
09961             matrix Q as a product of elementary reflectors; if UPLO   
09962             = 'L', the diagonal and first subdiagonal of A are over-   
09963             written by the corresponding elements of the tridiagonal   
09964             matrix T, and the elements below the first subdiagonal, with   
09965             the array TAU, represent the orthogonal matrix Q as a product   
09966             of elementary reflectors. See Further Details.   
09967 
09968     LDA     (input) INTEGER   
09969             The leading dimension of the array A.  LDA >= f2cmax(1,N).   
09970 
09971     D       (output) REAL array, dimension (N)   
09972             The diagonal elements of the tridiagonal matrix T:   
09973             D(i) = A(i,i).   
09974 
09975     E       (output) REAL array, dimension (N-1)   
09976             The off-diagonal elements of the tridiagonal matrix T:   
09977             E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.   
09978 
09979     TAU     (output) REAL array, dimension (N-1)   
09980             The scalar factors of the elementary reflectors (see Further   
09981             Details).   
09982 
09983     INFO    (output) INTEGER   
09984             = 0:  successful exit   
09985             < 0:  if INFO = -i, the i-th argument had an illegal value.   
09986 
09987     Further Details   
09988     ===============   
09989 
09990     If UPLO = 'U', the matrix Q is represented as a product of elementary   
09991     reflectors   
09992 
09993        Q = H(n-1) . . . H(2) H(1).   
09994 
09995     Each H(i) has the form   
09996 
09997        H(i) = I - tau * v * v'   
09998 
09999     where tau is a real scalar, and v is a real vector with   
10000     v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in   
10001     A(1:i-1,i+1), and tau in TAU(i).   
10002 
10003     If UPLO = 'L', the matrix Q is represented as a product of elementary   
10004     reflectors   
10005 
10006        Q = H(1) H(2) . . . H(n-1).   
10007 
10008     Each H(i) has the form   
10009 
10010        H(i) = I - tau * v * v'   
10011 
10012     where tau is a real scalar, and v is a real vector with   
10013     v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),   
10014     and tau in TAU(i).   
10015 
10016     The contents of A on exit are illustrated by the following examples   
10017     with n = 5:   
10018 
10019     if UPLO = 'U':                       if UPLO = 'L':   
10020 
10021       (  d   e   v2  v3  v4 )              (  d                  )   
10022       (      d   e   v3  v4 )              (  e   d              )   
10023       (          d   e   v4 )              (  v1  e   d          )   
10024       (              d   e  )              (  v1  v2  e   d      )   
10025       (                  d  )              (  v1  v2  v3  e   d  )   
10026 
10027     where d and e denote diagonal and off-diagonal elements of T, and vi   
10028     denotes an element of the vector defining H(i).   
10029 
10030     =====================================================================   
10031 
10032 
10033        Test the input parameters   
10034 
10035        Parameter adjustments */
10036     /* Table of constant values */
10037     static integer c__1 = 1;
10038     static real c_b8 = 0.f;
10039     static real c_b14 = -1.f;
10040     
10041     /* System generated locals */
10042     integer a_dim1, a_offset, i__1, i__2, i__3;
10043     /* Local variables */
10044     static real taui;
10045     extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
10046     static integer i__;
10047     extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *, 
10048             integer *, real *, integer *, real *, integer *);
10049     static real alpha;
10050     extern logical lsame_(const char *, const char *);
10051     static logical upper;
10052     extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, 
10053             real *, integer *), ssymv_(const char *, integer *, real *, real *, 
10054             integer *, real *, integer *, real *, real *, integer *), 
10055             xerbla_(const char *, integer *), slarfg_(integer *, real *, 
10056             real *, integer *, real *);
10057 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
10058 
10059 
10060     a_dim1 = *lda;
10061     a_offset = 1 + a_dim1 * 1;
10062     a -= a_offset;
10063     --d__;
10064     --e;
10065     --tau;
10066 
10067     /* Function Body */
10068     *info = 0;
10069     upper = lsame_(uplo, "U");
10070     if (! upper && ! lsame_(uplo, "L")) {
10071         *info = -1;
10072     } else if (*n < 0) {
10073         *info = -2;
10074     } else if (*lda < f2cmax(1,*n)) {
10075         *info = -4;
10076     }
10077     if (*info != 0) {
10078         i__1 = -(*info);
10079         xerbla_("SSYTD2", &i__1);
10080         return 0;
10081     }
10082 
10083 /*     Quick return if possible */
10084 
10085     if (*n <= 0) {
10086         return 0;
10087     }
10088 
10089     if (upper) {
10090 
10091 /*        Reduce the upper triangle of A */
10092 
10093         for (i__ = *n - 1; i__ >= 1; --i__) {
10094 
10095 /*           Generate elementary reflector H(i) = I - tau * v * v'   
10096              to annihilate A(1:i-1,i+1) */
10097 
10098             slarfg_(&i__, &a_ref(i__, i__ + 1), &a_ref(1, i__ + 1), &c__1, &
10099                     taui);
10100             e[i__] = a_ref(i__, i__ + 1);
10101 
10102             if (taui != 0.f) {
10103 
10104 /*              Apply H(i) from both sides to A(1:i,1:i) */
10105 
10106                 a_ref(i__, i__ + 1) = 1.f;
10107 
10108 /*              Compute  x := tau * A * v  storing x in TAU(1:i) */
10109 
10110                 ssymv_(uplo, &i__, &taui, &a[a_offset], lda, &a_ref(1, i__ + 
10111                         1), &c__1, &c_b8, &tau[1], &c__1);
10112 
10113 /*              Compute  w := x - 1/2 * tau * (x'*v) * v */
10114 
10115                 alpha = taui * -.5f * sdot_(&i__, &tau[1], &c__1, &a_ref(1, 
10116                         i__ + 1), &c__1);
10117                 saxpy_(&i__, &alpha, &a_ref(1, i__ + 1), &c__1, &tau[1], &
10118                         c__1);
10119 
10120 /*              Apply the transformation as a rank-2 update:   
10121                    A := A - v * w' - w * v' */
10122 
10123                 ssyr2_(uplo, &i__, &c_b14, &a_ref(1, i__ + 1), &c__1, &tau[1],
10124                          &c__1, &a[a_offset], lda);
10125 
10126                 a_ref(i__, i__ + 1) = e[i__];
10127             }
10128             d__[i__ + 1] = a_ref(i__ + 1, i__ + 1);
10129             tau[i__] = taui;
10130 /* L10: */
10131         }
10132         d__[1] = a_ref(1, 1);
10133     } else {
10134 
10135 /*        Reduce the lower triangle of A */
10136 
10137         i__1 = *n - 1;
10138         for (i__ = 1; i__ <= i__1; ++i__) {
10139 
10140 /*           Generate elementary reflector H(i) = I - tau * v * v'   
10141              to annihilate A(i+2:n,i)   
10142 
10143    Computing MIN */
10144             i__2 = i__ + 2;
10145             i__3 = *n - i__;
10146             slarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(f2cmin(i__2,*n), i__), &
10147                     c__1, &taui);
10148             e[i__] = a_ref(i__ + 1, i__);
10149 
10150             if (taui != 0.f) {
10151 
10152 /*              Apply H(i) from both sides to A(i+1:n,i+1:n) */
10153 
10154                 a_ref(i__ + 1, i__) = 1.f;
10155 
10156 /*              Compute  x := tau * A * v  storing y in TAU(i:n-1) */
10157 
10158                 i__2 = *n - i__;
10159                 ssymv_(uplo, &i__2, &taui, &a_ref(i__ + 1, i__ + 1), lda, &
10160                         a_ref(i__ + 1, i__), &c__1, &c_b8, &tau[i__], &c__1);
10161 
10162 /*              Compute  w := x - 1/2 * tau * (x'*v) * v */
10163 
10164                 i__2 = *n - i__;
10165                 alpha = taui * -.5f * sdot_(&i__2, &tau[i__], &c__1, &a_ref(
10166                         i__ + 1, i__), &c__1);
10167                 i__2 = *n - i__;
10168                 saxpy_(&i__2, &alpha, &a_ref(i__ + 1, i__), &c__1, &tau[i__], 
10169                         &c__1);
10170 
10171 /*              Apply the transformation as a rank-2 update:   
10172                    A := A - v * w' - w * v' */
10173 
10174                 i__2 = *n - i__;
10175                 ssyr2_(uplo, &i__2, &c_b14, &a_ref(i__ + 1, i__), &c__1, &tau[
10176                         i__], &c__1, &a_ref(i__ + 1, i__ + 1), lda)
10177                         ;
10178 
10179                 a_ref(i__ + 1, i__) = e[i__];
10180             }
10181             d__[i__] = a_ref(i__, i__);
10182             tau[i__] = taui;
10183 /* L20: */
10184         }
10185         d__[*n] = a_ref(*n, *n);
10186     }
10187 
10188     return 0;
10189 
10190 /*     End of SSYTD2 */
10191 
10192 } /* ssytd2_ */
10193 
10194 #undef a_ref
10195 
10196 
10197 
10198 
10199 
10200 /* Subroutine */ int ssytrd_(char *uplo, integer *n, real *a, integer *lda, 
10201         real *d__, real *e, real *tau, real *work, integer *lwork, integer *
10202         info)
10203 {
10204 /*  -- LAPACK routine (version 3.0) --   
10205        Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,   
10206        Courant Institute, Argonne National Lab, and Rice University   
10207        June 30, 1999   
10208 
10209 
10210     Purpose   
10211     =======   
10212 
10213     SSYTRD reduces a real symmetric matrix A to real symmetric   
10214     tridiagonal form T by an orthogonal similarity transformation:   
10215     Q**T * A * Q = T.   
10216 
10217     Arguments   
10218     =========   
10219 
10220     UPLO    (input) CHARACTER*1   
10221             = 'U':  Upper triangle of A is stored;   
10222             = 'L':  Lower triangle of A is stored.   
10223 
10224     N       (input) INTEGER   
10225             The order of the matrix A.  N >= 0.   
10226 
10227     A       (input/output) REAL array, dimension (LDA,N)   
10228             On entry, the symmetric matrix A.  If UPLO = 'U', the leading   
10229             N-by-N upper triangular part of A contains the upper   
10230             triangular part of the matrix A, and the strictly lower   
10231             triangular part of A is not referenced.  If UPLO = 'L', the   
10232             leading N-by-N lower triangular part of A contains the lower   
10233             triangular part of the matrix A, and the strictly upper   
10234             triangular part of