LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
csyr2k.f
Go to the documentation of this file.
00001 *> \brief \b CSYR2K
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *  Definition:
00009 *  ===========
00010 *
00011 *       SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
00012 * 
00013 *       .. Scalar Arguments ..
00014 *       COMPLEX ALPHA,BETA
00015 *       INTEGER K,LDA,LDB,LDC,N
00016 *       CHARACTER TRANS,UPLO
00017 *       ..
00018 *       .. Array Arguments ..
00019 *       COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
00020 *       ..
00021 *  
00022 *
00023 *> \par Purpose:
00024 *  =============
00025 *>
00026 *> \verbatim
00027 *>
00028 *> CSYR2K  performs one of the symmetric rank 2k operations
00029 *>
00030 *>    C := alpha*A*B**T + alpha*B*A**T + beta*C,
00031 *>
00032 *> or
00033 *>
00034 *>    C := alpha*A**T*B + alpha*B**T*A + beta*C,
00035 *>
00036 *> where  alpha and beta  are scalars,  C is an  n by n symmetric matrix
00037 *> and  A and B  are  n by k  matrices  in the  first  case  and  k by n
00038 *> matrices in the second case.
00039 *> \endverbatim
00040 *
00041 *  Arguments:
00042 *  ==========
00043 *
00044 *> \param[in] UPLO
00045 *> \verbatim
00046 *>          UPLO is CHARACTER*1
00047 *>           On  entry,   UPLO  specifies  whether  the  upper  or  lower
00048 *>           triangular  part  of the  array  C  is to be  referenced  as
00049 *>           follows:
00050 *>
00051 *>              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
00052 *>                                  is to be referenced.
00053 *>
00054 *>              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
00055 *>                                  is to be referenced.
00056 *> \endverbatim
00057 *>
00058 *> \param[in] TRANS
00059 *> \verbatim
00060 *>          TRANS is CHARACTER*1
00061 *>           On entry,  TRANS  specifies the operation to be performed as
00062 *>           follows:
00063 *>
00064 *>              TRANS = 'N' or 'n'    C := alpha*A*B**T + alpha*B*A**T +
00065 *>                                         beta*C.
00066 *>
00067 *>              TRANS = 'T' or 't'    C := alpha*A**T*B + alpha*B**T*A +
00068 *>                                         beta*C.
00069 *> \endverbatim
00070 *>
00071 *> \param[in] N
00072 *> \verbatim
00073 *>          N is INTEGER
00074 *>           On entry,  N specifies the order of the matrix C.  N must be
00075 *>           at least zero.
00076 *> \endverbatim
00077 *>
00078 *> \param[in] K
00079 *> \verbatim
00080 *>          K is INTEGER
00081 *>           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
00082 *>           of  columns  of the  matrices  A and B,  and on  entry  with
00083 *>           TRANS = 'T' or 't',  K  specifies  the number of rows of the
00084 *>           matrices  A and B.  K must be at least zero.
00085 *> \endverbatim
00086 *>
00087 *> \param[in] ALPHA
00088 *> \verbatim
00089 *>          ALPHA is COMPLEX
00090 *>           On entry, ALPHA specifies the scalar alpha.
00091 *> \endverbatim
00092 *>
00093 *> \param[in] A
00094 *> \verbatim
00095 *>          A is COMPLEX array of DIMENSION ( LDA, ka ), where ka is
00096 *>           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
00097 *>           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
00098 *>           part of the array  A  must contain the matrix  A,  otherwise
00099 *>           the leading  k by n  part of the array  A  must contain  the
00100 *>           matrix A.
00101 *> \endverbatim
00102 *>
00103 *> \param[in] LDA
00104 *> \verbatim
00105 *>          LDA is INTEGER
00106 *>           On entry, LDA specifies the first dimension of A as declared
00107 *>           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
00108 *>           then  LDA must be at least  max( 1, n ), otherwise  LDA must
00109 *>           be at least  max( 1, k ).
00110 *> \endverbatim
00111 *>
00112 *> \param[in] B
00113 *> \verbatim
00114 *>          B is COMPLEX array of DIMENSION ( LDB, kb ), where kb is
00115 *>           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
00116 *>           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
00117 *>           part of the array  B  must contain the matrix  B,  otherwise
00118 *>           the leading  k by n  part of the array  B  must contain  the
00119 *>           matrix B.
00120 *> \endverbatim
00121 *>
00122 *> \param[in] LDB
00123 *> \verbatim
00124 *>          LDB is INTEGER
00125 *>           On entry, LDB specifies the first dimension of B as declared
00126 *>           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
00127 *>           then  LDB must be at least  max( 1, n ), otherwise  LDB must
00128 *>           be at least  max( 1, k ).
00129 *> \endverbatim
00130 *>
00131 *> \param[in] BETA
00132 *> \verbatim
00133 *>          BETA is COMPLEX
00134 *>           On entry, BETA specifies the scalar beta.
00135 *> \endverbatim
00136 *>
00137 *> \param[in,out] C
00138 *> \verbatim
00139 *>          C is COMPLEX array of DIMENSION ( LDC, n ).
00140 *>           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
00141 *>           upper triangular part of the array C must contain the upper
00142 *>           triangular part  of the  symmetric matrix  and the strictly
00143 *>           lower triangular part of C is not referenced.  On exit, the
00144 *>           upper triangular part of the array  C is overwritten by the
00145 *>           upper triangular part of the updated matrix.
00146 *>           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
00147 *>           lower triangular part of the array C must contain the lower
00148 *>           triangular part  of the  symmetric matrix  and the strictly
00149 *>           upper triangular part of C is not referenced.  On exit, the
00150 *>           lower triangular part of the array  C is overwritten by the
00151 *>           lower triangular part of the updated matrix.
00152 *> \endverbatim
00153 *>
00154 *> \param[in] LDC
00155 *> \verbatim
00156 *>          LDC is INTEGER
00157 *>           On entry, LDC specifies the first dimension of C as declared
00158 *>           in  the  calling  (sub)  program.   LDC  must  be  at  least
00159 *>           max( 1, n ).
00160 *> \endverbatim
00161 *
00162 *  Authors:
00163 *  ========
00164 *
00165 *> \author Univ. of Tennessee 
00166 *> \author Univ. of California Berkeley 
00167 *> \author Univ. of Colorado Denver 
00168 *> \author NAG Ltd. 
00169 *
00170 *> \date November 2011
00171 *
00172 *> \ingroup complex_blas_level3
00173 *
00174 *> \par Further Details:
00175 *  =====================
00176 *>
00177 *> \verbatim
00178 *>
00179 *>  Level 3 Blas routine.
00180 *>
00181 *>  -- Written on 8-February-1989.
00182 *>     Jack Dongarra, Argonne National Laboratory.
00183 *>     Iain Duff, AERE Harwell.
00184 *>     Jeremy Du Croz, Numerical Algorithms Group Ltd.
00185 *>     Sven Hammarling, Numerical Algorithms Group Ltd.
00186 *> \endverbatim
00187 *>
00188 *  =====================================================================
00189       SUBROUTINE CSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
00190 *
00191 *  -- Reference BLAS level3 routine (version 3.4.0) --
00192 *  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
00193 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00194 *     November 2011
00195 *
00196 *     .. Scalar Arguments ..
00197       COMPLEX ALPHA,BETA
00198       INTEGER K,LDA,LDB,LDC,N
00199       CHARACTER TRANS,UPLO
00200 *     ..
00201 *     .. Array Arguments ..
00202       COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
00203 *     ..
00204 *
00205 *  =====================================================================
00206 *
00207 *     .. External Functions ..
00208       LOGICAL LSAME
00209       EXTERNAL LSAME
00210 *     ..
00211 *     .. External Subroutines ..
00212       EXTERNAL XERBLA
00213 *     ..
00214 *     .. Intrinsic Functions ..
00215       INTRINSIC MAX
00216 *     ..
00217 *     .. Local Scalars ..
00218       COMPLEX TEMP1,TEMP2
00219       INTEGER I,INFO,J,L,NROWA
00220       LOGICAL UPPER
00221 *     ..
00222 *     .. Parameters ..
00223       COMPLEX ONE
00224       PARAMETER (ONE= (1.0E+0,0.0E+0))
00225       COMPLEX ZERO
00226       PARAMETER (ZERO= (0.0E+0,0.0E+0))
00227 *     ..
00228 *
00229 *     Test the input parameters.
00230 *
00231       IF (LSAME(TRANS,'N')) THEN
00232           NROWA = N
00233       ELSE
00234           NROWA = K
00235       END IF
00236       UPPER = LSAME(UPLO,'U')
00237 *
00238       INFO = 0
00239       IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
00240           INFO = 1
00241       ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
00242      +         (.NOT.LSAME(TRANS,'T'))) THEN
00243           INFO = 2
00244       ELSE IF (N.LT.0) THEN
00245           INFO = 3
00246       ELSE IF (K.LT.0) THEN
00247           INFO = 4
00248       ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
00249           INFO = 7
00250       ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
00251           INFO = 9
00252       ELSE IF (LDC.LT.MAX(1,N)) THEN
00253           INFO = 12
00254       END IF
00255       IF (INFO.NE.0) THEN
00256           CALL XERBLA('CSYR2K',INFO)
00257           RETURN
00258       END IF
00259 *
00260 *     Quick return if possible.
00261 *
00262       IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
00263      +    (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
00264 *
00265 *     And when  alpha.eq.zero.
00266 *
00267       IF (ALPHA.EQ.ZERO) THEN
00268           IF (UPPER) THEN
00269               IF (BETA.EQ.ZERO) THEN
00270                   DO 20 J = 1,N
00271                       DO 10 I = 1,J
00272                           C(I,J) = ZERO
00273    10                 CONTINUE
00274    20             CONTINUE
00275               ELSE
00276                   DO 40 J = 1,N
00277                       DO 30 I = 1,J
00278                           C(I,J) = BETA*C(I,J)
00279    30                 CONTINUE
00280    40             CONTINUE
00281               END IF
00282           ELSE
00283               IF (BETA.EQ.ZERO) THEN
00284                   DO 60 J = 1,N
00285                       DO 50 I = J,N
00286                           C(I,J) = ZERO
00287    50                 CONTINUE
00288    60             CONTINUE
00289               ELSE
00290                   DO 80 J = 1,N
00291                       DO 70 I = J,N
00292                           C(I,J) = BETA*C(I,J)
00293    70                 CONTINUE
00294    80             CONTINUE
00295               END IF
00296           END IF
00297           RETURN
00298       END IF
00299 *
00300 *     Start the operations.
00301 *
00302       IF (LSAME(TRANS,'N')) THEN
00303 *
00304 *        Form  C := alpha*A*B**T + alpha*B*A**T + C.
00305 *
00306           IF (UPPER) THEN
00307               DO 130 J = 1,N
00308                   IF (BETA.EQ.ZERO) THEN
00309                       DO 90 I = 1,J
00310                           C(I,J) = ZERO
00311    90                 CONTINUE
00312                   ELSE IF (BETA.NE.ONE) THEN
00313                       DO 100 I = 1,J
00314                           C(I,J) = BETA*C(I,J)
00315   100                 CONTINUE
00316                   END IF
00317                   DO 120 L = 1,K
00318                       IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
00319                           TEMP1 = ALPHA*B(J,L)
00320                           TEMP2 = ALPHA*A(J,L)
00321                           DO 110 I = 1,J
00322                               C(I,J) = C(I,J) + A(I,L)*TEMP1 +
00323      +                                 B(I,L)*TEMP2
00324   110                     CONTINUE
00325                       END IF
00326   120             CONTINUE
00327   130         CONTINUE
00328           ELSE
00329               DO 180 J = 1,N
00330                   IF (BETA.EQ.ZERO) THEN
00331                       DO 140 I = J,N
00332                           C(I,J) = ZERO
00333   140                 CONTINUE
00334                   ELSE IF (BETA.NE.ONE) THEN
00335                       DO 150 I = J,N
00336                           C(I,J) = BETA*C(I,J)
00337   150                 CONTINUE
00338                   END IF
00339                   DO 170 L = 1,K
00340                       IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
00341                           TEMP1 = ALPHA*B(J,L)
00342                           TEMP2 = ALPHA*A(J,L)
00343                           DO 160 I = J,N
00344                               C(I,J) = C(I,J) + A(I,L)*TEMP1 +
00345      +                                 B(I,L)*TEMP2
00346   160                     CONTINUE
00347                       END IF
00348   170             CONTINUE
00349   180         CONTINUE
00350           END IF
00351       ELSE
00352 *
00353 *        Form  C := alpha*A**T*B + alpha*B**T*A + C.
00354 *
00355           IF (UPPER) THEN
00356               DO 210 J = 1,N
00357                   DO 200 I = 1,J
00358                       TEMP1 = ZERO
00359                       TEMP2 = ZERO
00360                       DO 190 L = 1,K
00361                           TEMP1 = TEMP1 + A(L,I)*B(L,J)
00362                           TEMP2 = TEMP2 + B(L,I)*A(L,J)
00363   190                 CONTINUE
00364                       IF (BETA.EQ.ZERO) THEN
00365                           C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
00366                       ELSE
00367                           C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
00368      +                             ALPHA*TEMP2
00369                       END IF
00370   200             CONTINUE
00371   210         CONTINUE
00372           ELSE
00373               DO 240 J = 1,N
00374                   DO 230 I = J,N
00375                       TEMP1 = ZERO
00376                       TEMP2 = ZERO
00377                       DO 220 L = 1,K
00378                           TEMP1 = TEMP1 + A(L,I)*B(L,J)
00379                           TEMP2 = TEMP2 + B(L,I)*A(L,J)
00380   220                 CONTINUE
00381                       IF (BETA.EQ.ZERO) THEN
00382                           C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
00383                       ELSE
00384                           C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
00385      +                             ALPHA*TEMP2
00386                       END IF
00387   230             CONTINUE
00388   240         CONTINUE
00389           END IF
00390       END IF
00391 *
00392       RETURN
00393 *
00394 *     End of CSYR2K.
00395 *
00396       END
 All Files Functions