zlantr.c
Go to the documentation of this file.
00001 /* zlantr.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Table of constant values */
00017 
00018 static integer c__1 = 1;
00019 
00020 doublereal zlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, 
00021          doublecomplex *a, integer *lda, doublereal *work)
00022 {
00023     /* System generated locals */
00024     integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
00025     doublereal ret_val, d__1, d__2;
00026 
00027     /* Builtin functions */
00028     double z_abs(doublecomplex *), sqrt(doublereal);
00029 
00030     /* Local variables */
00031     integer i__, j;
00032     doublereal sum, scale;
00033     logical udiag;
00034     extern logical lsame_(char *, char *);
00035     doublereal value;
00036     extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, 
00037              doublereal *, doublereal *);
00038 
00039 
00040 /*  -- LAPACK auxiliary routine (version 3.2) -- */
00041 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00042 /*     November 2006 */
00043 
00044 /*     .. Scalar Arguments .. */
00045 /*     .. */
00046 /*     .. Array Arguments .. */
00047 /*     .. */
00048 
00049 /*  Purpose */
00050 /*  ======= */
00051 
00052 /*  ZLANTR  returns the value of the one norm,  or the Frobenius norm, or */
00053 /*  the  infinity norm,  or the  element of  largest absolute value  of a */
00054 /*  trapezoidal or triangular matrix A. */
00055 
00056 /*  Description */
00057 /*  =========== */
00058 
00059 /*  ZLANTR returns the value */
00060 
00061 /*     ZLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
00062 /*              ( */
00063 /*              ( norm1(A),         NORM = '1', 'O' or 'o' */
00064 /*              ( */
00065 /*              ( normI(A),         NORM = 'I' or 'i' */
00066 /*              ( */
00067 /*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e' */
00068 
00069 /*  where  norm1  denotes the  one norm of a matrix (maximum column sum), */
00070 /*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and */
00071 /*  normF  denotes the  Frobenius norm of a matrix (square root of sum of */
00072 /*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm. */
00073 
00074 /*  Arguments */
00075 /*  ========= */
00076 
00077 /*  NORM    (input) CHARACTER*1 */
00078 /*          Specifies the value to be returned in ZLANTR as described */
00079 /*          above. */
00080 
00081 /*  UPLO    (input) CHARACTER*1 */
00082 /*          Specifies whether the matrix A is upper or lower trapezoidal. */
00083 /*          = 'U':  Upper trapezoidal */
00084 /*          = 'L':  Lower trapezoidal */
00085 /*          Note that A is triangular instead of trapezoidal if M = N. */
00086 
00087 /*  DIAG    (input) CHARACTER*1 */
00088 /*          Specifies whether or not the matrix A has unit diagonal. */
00089 /*          = 'N':  Non-unit diagonal */
00090 /*          = 'U':  Unit diagonal */
00091 
00092 /*  M       (input) INTEGER */
00093 /*          The number of rows of the matrix A.  M >= 0, and if */
00094 /*          UPLO = 'U', M <= N.  When M = 0, ZLANTR is set to zero. */
00095 
00096 /*  N       (input) INTEGER */
00097 /*          The number of columns of the matrix A.  N >= 0, and if */
00098 /*          UPLO = 'L', N <= M.  When N = 0, ZLANTR is set to zero. */
00099 
00100 /*  A       (input) COMPLEX*16 array, dimension (LDA,N) */
00101 /*          The trapezoidal matrix A (A is triangular if M = N). */
00102 /*          If UPLO = 'U', the leading m by n upper trapezoidal part of */
00103 /*          the array A contains the upper trapezoidal matrix, and the */
00104 /*          strictly lower triangular part of A is not referenced. */
00105 /*          If UPLO = 'L', the leading m by n lower trapezoidal part of */
00106 /*          the array A contains the lower trapezoidal matrix, and the */
00107 /*          strictly upper triangular part of A is not referenced.  Note */
00108 /*          that when DIAG = 'U', the diagonal elements of A are not */
00109 /*          referenced and are assumed to be one. */
00110 
00111 /*  LDA     (input) INTEGER */
00112 /*          The leading dimension of the array A.  LDA >= max(M,1). */
00113 
00114 /*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
00115 /*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
00116 /*          referenced. */
00117 
00118 /* ===================================================================== */
00119 
00120 /*     .. Parameters .. */
00121 /*     .. */
00122 /*     .. Local Scalars .. */
00123 /*     .. */
00124 /*     .. External Functions .. */
00125 /*     .. */
00126 /*     .. External Subroutines .. */
00127 /*     .. */
00128 /*     .. Intrinsic Functions .. */
00129 /*     .. */
00130 /*     .. Executable Statements .. */
00131 
00132     /* Parameter adjustments */
00133     a_dim1 = *lda;
00134     a_offset = 1 + a_dim1;
00135     a -= a_offset;
00136     --work;
00137 
00138     /* Function Body */
00139     if (min(*m,*n) == 0) {
00140         value = 0.;
00141     } else if (lsame_(norm, "M")) {
00142 
00143 /*        Find max(abs(A(i,j))). */
00144 
00145         if (lsame_(diag, "U")) {
00146             value = 1.;
00147             if (lsame_(uplo, "U")) {
00148                 i__1 = *n;
00149                 for (j = 1; j <= i__1; ++j) {
00150 /* Computing MIN */
00151                     i__3 = *m, i__4 = j - 1;
00152                     i__2 = min(i__3,i__4);
00153                     for (i__ = 1; i__ <= i__2; ++i__) {
00154 /* Computing MAX */
00155                         d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
00156                         value = max(d__1,d__2);
00157 /* L10: */
00158                     }
00159 /* L20: */
00160                 }
00161             } else {
00162                 i__1 = *n;
00163                 for (j = 1; j <= i__1; ++j) {
00164                     i__2 = *m;
00165                     for (i__ = j + 1; i__ <= i__2; ++i__) {
00166 /* Computing MAX */
00167                         d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
00168                         value = max(d__1,d__2);
00169 /* L30: */
00170                     }
00171 /* L40: */
00172                 }
00173             }
00174         } else {
00175             value = 0.;
00176             if (lsame_(uplo, "U")) {
00177                 i__1 = *n;
00178                 for (j = 1; j <= i__1; ++j) {
00179                     i__2 = min(*m,j);
00180                     for (i__ = 1; i__ <= i__2; ++i__) {
00181 /* Computing MAX */
00182                         d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
00183                         value = max(d__1,d__2);
00184 /* L50: */
00185                     }
00186 /* L60: */
00187                 }
00188             } else {
00189                 i__1 = *n;
00190                 for (j = 1; j <= i__1; ++j) {
00191                     i__2 = *m;
00192                     for (i__ = j; i__ <= i__2; ++i__) {
00193 /* Computing MAX */
00194                         d__1 = value, d__2 = z_abs(&a[i__ + j * a_dim1]);
00195                         value = max(d__1,d__2);
00196 /* L70: */
00197                     }
00198 /* L80: */
00199                 }
00200             }
00201         }
00202     } else if (lsame_(norm, "O") || *(unsigned char *)
00203             norm == '1') {
00204 
00205 /*        Find norm1(A). */
00206 
00207         value = 0.;
00208         udiag = lsame_(diag, "U");
00209         if (lsame_(uplo, "U")) {
00210             i__1 = *n;
00211             for (j = 1; j <= i__1; ++j) {
00212                 if (udiag && j <= *m) {
00213                     sum = 1.;
00214                     i__2 = j - 1;
00215                     for (i__ = 1; i__ <= i__2; ++i__) {
00216                         sum += z_abs(&a[i__ + j * a_dim1]);
00217 /* L90: */
00218                     }
00219                 } else {
00220                     sum = 0.;
00221                     i__2 = min(*m,j);
00222                     for (i__ = 1; i__ <= i__2; ++i__) {
00223                         sum += z_abs(&a[i__ + j * a_dim1]);
00224 /* L100: */
00225                     }
00226                 }
00227                 value = max(value,sum);
00228 /* L110: */
00229             }
00230         } else {
00231             i__1 = *n;
00232             for (j = 1; j <= i__1; ++j) {
00233                 if (udiag) {
00234                     sum = 1.;
00235                     i__2 = *m;
00236                     for (i__ = j + 1; i__ <= i__2; ++i__) {
00237                         sum += z_abs(&a[i__ + j * a_dim1]);
00238 /* L120: */
00239                     }
00240                 } else {
00241                     sum = 0.;
00242                     i__2 = *m;
00243                     for (i__ = j; i__ <= i__2; ++i__) {
00244                         sum += z_abs(&a[i__ + j * a_dim1]);
00245 /* L130: */
00246                     }
00247                 }
00248                 value = max(value,sum);
00249 /* L140: */
00250             }
00251         }
00252     } else if (lsame_(norm, "I")) {
00253 
00254 /*        Find normI(A). */
00255 
00256         if (lsame_(uplo, "U")) {
00257             if (lsame_(diag, "U")) {
00258                 i__1 = *m;
00259                 for (i__ = 1; i__ <= i__1; ++i__) {
00260                     work[i__] = 1.;
00261 /* L150: */
00262                 }
00263                 i__1 = *n;
00264                 for (j = 1; j <= i__1; ++j) {
00265 /* Computing MIN */
00266                     i__3 = *m, i__4 = j - 1;
00267                     i__2 = min(i__3,i__4);
00268                     for (i__ = 1; i__ <= i__2; ++i__) {
00269                         work[i__] += z_abs(&a[i__ + j * a_dim1]);
00270 /* L160: */
00271                     }
00272 /* L170: */
00273                 }
00274             } else {
00275                 i__1 = *m;
00276                 for (i__ = 1; i__ <= i__1; ++i__) {
00277                     work[i__] = 0.;
00278 /* L180: */
00279                 }
00280                 i__1 = *n;
00281                 for (j = 1; j <= i__1; ++j) {
00282                     i__2 = min(*m,j);
00283                     for (i__ = 1; i__ <= i__2; ++i__) {
00284                         work[i__] += z_abs(&a[i__ + j * a_dim1]);
00285 /* L190: */
00286                     }
00287 /* L200: */
00288                 }
00289             }
00290         } else {
00291             if (lsame_(diag, "U")) {
00292                 i__1 = *n;
00293                 for (i__ = 1; i__ <= i__1; ++i__) {
00294                     work[i__] = 1.;
00295 /* L210: */
00296                 }
00297                 i__1 = *m;
00298                 for (i__ = *n + 1; i__ <= i__1; ++i__) {
00299                     work[i__] = 0.;
00300 /* L220: */
00301                 }
00302                 i__1 = *n;
00303                 for (j = 1; j <= i__1; ++j) {
00304                     i__2 = *m;
00305                     for (i__ = j + 1; i__ <= i__2; ++i__) {
00306                         work[i__] += z_abs(&a[i__ + j * a_dim1]);
00307 /* L230: */
00308                     }
00309 /* L240: */
00310                 }
00311             } else {
00312                 i__1 = *m;
00313                 for (i__ = 1; i__ <= i__1; ++i__) {
00314                     work[i__] = 0.;
00315 /* L250: */
00316                 }
00317                 i__1 = *n;
00318                 for (j = 1; j <= i__1; ++j) {
00319                     i__2 = *m;
00320                     for (i__ = j; i__ <= i__2; ++i__) {
00321                         work[i__] += z_abs(&a[i__ + j * a_dim1]);
00322 /* L260: */
00323                     }
00324 /* L270: */
00325                 }
00326             }
00327         }
00328         value = 0.;
00329         i__1 = *m;
00330         for (i__ = 1; i__ <= i__1; ++i__) {
00331 /* Computing MAX */
00332             d__1 = value, d__2 = work[i__];
00333             value = max(d__1,d__2);
00334 /* L280: */
00335         }
00336     } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
00337 
00338 /*        Find normF(A). */
00339 
00340         if (lsame_(uplo, "U")) {
00341             if (lsame_(diag, "U")) {
00342                 scale = 1.;
00343                 sum = (doublereal) min(*m,*n);
00344                 i__1 = *n;
00345                 for (j = 2; j <= i__1; ++j) {
00346 /* Computing MIN */
00347                     i__3 = *m, i__4 = j - 1;
00348                     i__2 = min(i__3,i__4);
00349                     zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
00350 /* L290: */
00351                 }
00352             } else {
00353                 scale = 0.;
00354                 sum = 1.;
00355                 i__1 = *n;
00356                 for (j = 1; j <= i__1; ++j) {
00357                     i__2 = min(*m,j);
00358                     zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
00359 /* L300: */
00360                 }
00361             }
00362         } else {
00363             if (lsame_(diag, "U")) {
00364                 scale = 1.;
00365                 sum = (doublereal) min(*m,*n);
00366                 i__1 = *n;
00367                 for (j = 1; j <= i__1; ++j) {
00368                     i__2 = *m - j;
00369 /* Computing MIN */
00370                     i__3 = *m, i__4 = j + 1;
00371                     zlassq_(&i__2, &a[min(i__3, i__4)+ j * a_dim1], &c__1, &
00372                             scale, &sum);
00373 /* L310: */
00374                 }
00375             } else {
00376                 scale = 0.;
00377                 sum = 1.;
00378                 i__1 = *n;
00379                 for (j = 1; j <= i__1; ++j) {
00380                     i__2 = *m - j + 1;
00381                     zlassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum);
00382 /* L320: */
00383                 }
00384             }
00385         }
00386         value = scale * sqrt(sum);
00387     }
00388 
00389     ret_val = value;
00390     return ret_val;
00391 
00392 /*     End of ZLANTR */
00393 
00394 } /* zlantr_ */


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