dsymm.c
Go to the documentation of this file.
00001 /* dsymm.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n, 
00017         doublereal *alpha, doublereal *a, integer *lda, doublereal *b, 
00018         integer *ldb, doublereal *beta, doublereal *c__, integer *ldc)
00019 {
00020     /* System generated locals */
00021     integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
00022             i__3;
00023 
00024     /* Local variables */
00025     integer i__, j, k, info;
00026     doublereal temp1, temp2;
00027     extern logical lsame_(char *, char *);
00028     integer nrowa;
00029     logical upper;
00030     extern /* Subroutine */ int xerbla_(char *, integer *);
00031 
00032 /*     .. Scalar Arguments .. */
00033 /*     .. */
00034 /*     .. Array Arguments .. */
00035 /*     .. */
00036 
00037 /*  Purpose */
00038 /*  ======= */
00039 
00040 /*  DSYMM  performs one of the matrix-matrix operations */
00041 
00042 /*     C := alpha*A*B + beta*C, */
00043 
00044 /*  or */
00045 
00046 /*     C := alpha*B*A + beta*C, */
00047 
00048 /*  where alpha and beta are scalars,  A is a symmetric matrix and  B and */
00049 /*  C are  m by n matrices. */
00050 
00051 /*  Arguments */
00052 /*  ========== */
00053 
00054 /*  SIDE   - CHARACTER*1. */
00055 /*           On entry,  SIDE  specifies whether  the  symmetric matrix  A */
00056 /*           appears on the  left or right  in the  operation as follows: */
00057 
00058 /*              SIDE = 'L' or 'l'   C := alpha*A*B + beta*C, */
00059 
00060 /*              SIDE = 'R' or 'r'   C := alpha*B*A + beta*C, */
00061 
00062 /*           Unchanged on exit. */
00063 
00064 /*  UPLO   - CHARACTER*1. */
00065 /*           On  entry,   UPLO  specifies  whether  the  upper  or  lower */
00066 /*           triangular  part  of  the  symmetric  matrix   A  is  to  be */
00067 /*           referenced as follows: */
00068 
00069 /*              UPLO = 'U' or 'u'   Only the upper triangular part of the */
00070 /*                                  symmetric matrix is to be referenced. */
00071 
00072 /*              UPLO = 'L' or 'l'   Only the lower triangular part of the */
00073 /*                                  symmetric matrix is to be referenced. */
00074 
00075 /*           Unchanged on exit. */
00076 
00077 /*  M      - INTEGER. */
00078 /*           On entry,  M  specifies the number of rows of the matrix  C. */
00079 /*           M  must be at least zero. */
00080 /*           Unchanged on exit. */
00081 
00082 /*  N      - INTEGER. */
00083 /*           On entry, N specifies the number of columns of the matrix C. */
00084 /*           N  must be at least zero. */
00085 /*           Unchanged on exit. */
00086 
00087 /*  ALPHA  - DOUBLE PRECISION. */
00088 /*           On entry, ALPHA specifies the scalar alpha. */
00089 /*           Unchanged on exit. */
00090 
00091 /*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
00092 /*           m  when  SIDE = 'L' or 'l'  and is  n otherwise. */
00093 /*           Before entry  with  SIDE = 'L' or 'l',  the  m by m  part of */
00094 /*           the array  A  must contain the  symmetric matrix,  such that */
00095 /*           when  UPLO = 'U' or 'u', the leading m by m upper triangular */
00096 /*           part of the array  A  must contain the upper triangular part */
00097 /*           of the  symmetric matrix and the  strictly  lower triangular */
00098 /*           part of  A  is not referenced,  and when  UPLO = 'L' or 'l', */
00099 /*           the leading  m by m  lower triangular part  of the  array  A */
00100 /*           must  contain  the  lower triangular part  of the  symmetric */
00101 /*           matrix and the  strictly upper triangular part of  A  is not */
00102 /*           referenced. */
00103 /*           Before entry  with  SIDE = 'R' or 'r',  the  n by n  part of */
00104 /*           the array  A  must contain the  symmetric matrix,  such that */
00105 /*           when  UPLO = 'U' or 'u', the leading n by n upper triangular */
00106 /*           part of the array  A  must contain the upper triangular part */
00107 /*           of the  symmetric matrix and the  strictly  lower triangular */
00108 /*           part of  A  is not referenced,  and when  UPLO = 'L' or 'l', */
00109 /*           the leading  n by n  lower triangular part  of the  array  A */
00110 /*           must  contain  the  lower triangular part  of the  symmetric */
00111 /*           matrix and the  strictly upper triangular part of  A  is not */
00112 /*           referenced. */
00113 /*           Unchanged on exit. */
00114 
00115 /*  LDA    - INTEGER. */
00116 /*           On entry, LDA specifies the first dimension of A as declared */
00117 /*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then */
00118 /*           LDA must be at least  max( 1, m ), otherwise  LDA must be at */
00119 /*           least  max( 1, n ). */
00120 /*           Unchanged on exit. */
00121 
00122 /*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
00123 /*           Before entry, the leading  m by n part of the array  B  must */
00124 /*           contain the matrix B. */
00125 /*           Unchanged on exit. */
00126 
00127 /*  LDB    - INTEGER. */
00128 /*           On entry, LDB specifies the first dimension of B as declared */
00129 /*           in  the  calling  (sub)  program.   LDB  must  be  at  least */
00130 /*           max( 1, m ). */
00131 /*           Unchanged on exit. */
00132 
00133 /*  BETA   - DOUBLE PRECISION. */
00134 /*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is */
00135 /*           supplied as zero then C need not be set on input. */
00136 /*           Unchanged on exit. */
00137 
00138 /*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
00139 /*           Before entry, the leading  m by n  part of the array  C must */
00140 /*           contain the matrix  C,  except when  beta  is zero, in which */
00141 /*           case C need not be set on entry. */
00142 /*           On exit, the array  C  is overwritten by the  m by n updated */
00143 /*           matrix. */
00144 
00145 /*  LDC    - INTEGER. */
00146 /*           On entry, LDC specifies the first dimension of C as declared */
00147 /*           in  the  calling  (sub)  program.   LDC  must  be  at  least */
00148 /*           max( 1, m ). */
00149 /*           Unchanged on exit. */
00150 
00151 
00152 /*  Level 3 Blas routine. */
00153 
00154 /*  -- Written on 8-February-1989. */
00155 /*     Jack Dongarra, Argonne National Laboratory. */
00156 /*     Iain Duff, AERE Harwell. */
00157 /*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
00158 /*     Sven Hammarling, Numerical Algorithms Group Ltd. */
00159 
00160 
00161 /*     .. External Functions .. */
00162 /*     .. */
00163 /*     .. External Subroutines .. */
00164 /*     .. */
00165 /*     .. Intrinsic Functions .. */
00166 /*     .. */
00167 /*     .. Local Scalars .. */
00168 /*     .. */
00169 /*     .. Parameters .. */
00170 /*     .. */
00171 
00172 /*     Set NROWA as the number of rows of A. */
00173 
00174     /* Parameter adjustments */
00175     a_dim1 = *lda;
00176     a_offset = 1 + a_dim1;
00177     a -= a_offset;
00178     b_dim1 = *ldb;
00179     b_offset = 1 + b_dim1;
00180     b -= b_offset;
00181     c_dim1 = *ldc;
00182     c_offset = 1 + c_dim1;
00183     c__ -= c_offset;
00184 
00185     /* Function Body */
00186     if (lsame_(side, "L")) {
00187         nrowa = *m;
00188     } else {
00189         nrowa = *n;
00190     }
00191     upper = lsame_(uplo, "U");
00192 
00193 /*     Test the input parameters. */
00194 
00195     info = 0;
00196     if (! lsame_(side, "L") && ! lsame_(side, "R")) {
00197         info = 1;
00198     } else if (! upper && ! lsame_(uplo, "L")) {
00199         info = 2;
00200     } else if (*m < 0) {
00201         info = 3;
00202     } else if (*n < 0) {
00203         info = 4;
00204     } else if (*lda < max(1,nrowa)) {
00205         info = 7;
00206     } else if (*ldb < max(1,*m)) {
00207         info = 9;
00208     } else if (*ldc < max(1,*m)) {
00209         info = 12;
00210     }
00211     if (info != 0) {
00212         xerbla_("DSYMM ", &info);
00213         return 0;
00214     }
00215 
00216 /*     Quick return if possible. */
00217 
00218     if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
00219         return 0;
00220     }
00221 
00222 /*     And when  alpha.eq.zero. */
00223 
00224     if (*alpha == 0.) {
00225         if (*beta == 0.) {
00226             i__1 = *n;
00227             for (j = 1; j <= i__1; ++j) {
00228                 i__2 = *m;
00229                 for (i__ = 1; i__ <= i__2; ++i__) {
00230                     c__[i__ + j * c_dim1] = 0.;
00231 /* L10: */
00232                 }
00233 /* L20: */
00234             }
00235         } else {
00236             i__1 = *n;
00237             for (j = 1; j <= i__1; ++j) {
00238                 i__2 = *m;
00239                 for (i__ = 1; i__ <= i__2; ++i__) {
00240                     c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
00241 /* L30: */
00242                 }
00243 /* L40: */
00244             }
00245         }
00246         return 0;
00247     }
00248 
00249 /*     Start the operations. */
00250 
00251     if (lsame_(side, "L")) {
00252 
00253 /*        Form  C := alpha*A*B + beta*C. */
00254 
00255         if (upper) {
00256             i__1 = *n;
00257             for (j = 1; j <= i__1; ++j) {
00258                 i__2 = *m;
00259                 for (i__ = 1; i__ <= i__2; ++i__) {
00260                     temp1 = *alpha * b[i__ + j * b_dim1];
00261                     temp2 = 0.;
00262                     i__3 = i__ - 1;
00263                     for (k = 1; k <= i__3; ++k) {
00264                         c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
00265                         temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
00266 /* L50: */
00267                     }
00268                     if (*beta == 0.) {
00269                         c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] 
00270                                 + *alpha * temp2;
00271                     } else {
00272                         c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] 
00273                                 + temp1 * a[i__ + i__ * a_dim1] + *alpha * 
00274                                 temp2;
00275                     }
00276 /* L60: */
00277                 }
00278 /* L70: */
00279             }
00280         } else {
00281             i__1 = *n;
00282             for (j = 1; j <= i__1; ++j) {
00283                 for (i__ = *m; i__ >= 1; --i__) {
00284                     temp1 = *alpha * b[i__ + j * b_dim1];
00285                     temp2 = 0.;
00286                     i__2 = *m;
00287                     for (k = i__ + 1; k <= i__2; ++k) {
00288                         c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
00289                         temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
00290 /* L80: */
00291                     }
00292                     if (*beta == 0.) {
00293                         c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] 
00294                                 + *alpha * temp2;
00295                     } else {
00296                         c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] 
00297                                 + temp1 * a[i__ + i__ * a_dim1] + *alpha * 
00298                                 temp2;
00299                     }
00300 /* L90: */
00301                 }
00302 /* L100: */
00303             }
00304         }
00305     } else {
00306 
00307 /*        Form  C := alpha*B*A + beta*C. */
00308 
00309         i__1 = *n;
00310         for (j = 1; j <= i__1; ++j) {
00311             temp1 = *alpha * a[j + j * a_dim1];
00312             if (*beta == 0.) {
00313                 i__2 = *m;
00314                 for (i__ = 1; i__ <= i__2; ++i__) {
00315                     c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1];
00316 /* L110: */
00317                 }
00318             } else {
00319                 i__2 = *m;
00320                 for (i__ = 1; i__ <= i__2; ++i__) {
00321                     c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + 
00322                             temp1 * b[i__ + j * b_dim1];
00323 /* L120: */
00324                 }
00325             }
00326             i__2 = j - 1;
00327             for (k = 1; k <= i__2; ++k) {
00328                 if (upper) {
00329                     temp1 = *alpha * a[k + j * a_dim1];
00330                 } else {
00331                     temp1 = *alpha * a[j + k * a_dim1];
00332                 }
00333                 i__3 = *m;
00334                 for (i__ = 1; i__ <= i__3; ++i__) {
00335                     c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
00336 /* L130: */
00337                 }
00338 /* L140: */
00339             }
00340             i__2 = *n;
00341             for (k = j + 1; k <= i__2; ++k) {
00342                 if (upper) {
00343                     temp1 = *alpha * a[j + k * a_dim1];
00344                 } else {
00345                     temp1 = *alpha * a[k + j * a_dim1];
00346                 }
00347                 i__3 = *m;
00348                 for (i__ = 1; i__ <= i__3; ++i__) {
00349                     c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
00350 /* L150: */
00351                 }
00352 /* L160: */
00353             }
00354 /* L170: */
00355         }
00356     }
00357 
00358     return 0;
00359 
00360 /*     End of DSYMM . */
00361 
00362 } /* dsymm_ */


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