![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b ZHPR 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 ZHPR(UPLO,N,ALPHA,X,INCX,AP) 00012 * 00013 * .. Scalar Arguments .. 00014 * DOUBLE PRECISION ALPHA 00015 * INTEGER INCX,N 00016 * CHARACTER UPLO 00017 * .. 00018 * .. Array Arguments .. 00019 * COMPLEX*16 AP(*),X(*) 00020 * .. 00021 * 00022 * 00023 *> \par Purpose: 00024 * ============= 00025 *> 00026 *> \verbatim 00027 *> 00028 *> ZHPR performs the hermitian rank 1 operation 00029 *> 00030 *> A := alpha*x*x**H + A, 00031 *> 00032 *> where alpha is a real scalar, x is an n element vector and A is an 00033 *> n by n hermitian matrix, supplied in packed form. 00034 *> \endverbatim 00035 * 00036 * Arguments: 00037 * ========== 00038 * 00039 *> \param[in] UPLO 00040 *> \verbatim 00041 *> UPLO is CHARACTER*1 00042 *> On entry, UPLO specifies whether the upper or lower 00043 *> triangular part of the matrix A is supplied in the packed 00044 *> array AP as follows: 00045 *> 00046 *> UPLO = 'U' or 'u' The upper triangular part of A is 00047 *> supplied in AP. 00048 *> 00049 *> UPLO = 'L' or 'l' The lower triangular part of A is 00050 *> supplied in AP. 00051 *> \endverbatim 00052 *> 00053 *> \param[in] N 00054 *> \verbatim 00055 *> N is INTEGER 00056 *> On entry, N specifies the order of the matrix A. 00057 *> N must be at least zero. 00058 *> \endverbatim 00059 *> 00060 *> \param[in] ALPHA 00061 *> \verbatim 00062 *> ALPHA is DOUBLE PRECISION. 00063 *> On entry, ALPHA specifies the scalar alpha. 00064 *> \endverbatim 00065 *> 00066 *> \param[in] X 00067 *> \verbatim 00068 *> X is COMPLEX*16 array of dimension at least 00069 *> ( 1 + ( n - 1 )*abs( INCX ) ). 00070 *> Before entry, the incremented array X must contain the n 00071 *> element vector x. 00072 *> \endverbatim 00073 *> 00074 *> \param[in] INCX 00075 *> \verbatim 00076 *> INCX is INTEGER 00077 *> On entry, INCX specifies the increment for the elements of 00078 *> X. INCX must not be zero. 00079 *> \endverbatim 00080 *> 00081 *> \param[in,out] AP 00082 *> \verbatim 00083 *> AP is COMPLEX*16 array of DIMENSION at least 00084 *> ( ( n*( n + 1 ) )/2 ). 00085 *> Before entry with UPLO = 'U' or 'u', the array AP must 00086 *> contain the upper triangular part of the hermitian matrix 00087 *> packed sequentially, column by column, so that AP( 1 ) 00088 *> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) 00089 *> and a( 2, 2 ) respectively, and so on. On exit, the array 00090 *> AP is overwritten by the upper triangular part of the 00091 *> updated matrix. 00092 *> Before entry with UPLO = 'L' or 'l', the array AP must 00093 *> contain the lower triangular part of the hermitian matrix 00094 *> packed sequentially, column by column, so that AP( 1 ) 00095 *> contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) 00096 *> and a( 3, 1 ) respectively, and so on. On exit, the array 00097 *> AP is overwritten by the lower triangular part of the 00098 *> updated matrix. 00099 *> Note that the imaginary parts of the diagonal elements need 00100 *> not be set, they are assumed to be zero, and on exit they 00101 *> are set to zero. 00102 *> \endverbatim 00103 * 00104 * Authors: 00105 * ======== 00106 * 00107 *> \author Univ. of Tennessee 00108 *> \author Univ. of California Berkeley 00109 *> \author Univ. of Colorado Denver 00110 *> \author NAG Ltd. 00111 * 00112 *> \date November 2011 00113 * 00114 *> \ingroup complex16_blas_level2 00115 * 00116 *> \par Further Details: 00117 * ===================== 00118 *> 00119 *> \verbatim 00120 *> 00121 *> Level 2 Blas routine. 00122 *> 00123 *> -- Written on 22-October-1986. 00124 *> Jack Dongarra, Argonne National Lab. 00125 *> Jeremy Du Croz, Nag Central Office. 00126 *> Sven Hammarling, Nag Central Office. 00127 *> Richard Hanson, Sandia National Labs. 00128 *> \endverbatim 00129 *> 00130 * ===================================================================== 00131 SUBROUTINE ZHPR(UPLO,N,ALPHA,X,INCX,AP) 00132 * 00133 * -- Reference BLAS level2 routine (version 3.4.0) -- 00134 * -- Reference BLAS is a software package provided by Univ. of Tennessee, -- 00135 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00136 * November 2011 00137 * 00138 * .. Scalar Arguments .. 00139 DOUBLE PRECISION ALPHA 00140 INTEGER INCX,N 00141 CHARACTER UPLO 00142 * .. 00143 * .. Array Arguments .. 00144 COMPLEX*16 AP(*),X(*) 00145 * .. 00146 * 00147 * ===================================================================== 00148 * 00149 * .. Parameters .. 00150 COMPLEX*16 ZERO 00151 PARAMETER (ZERO= (0.0D+0,0.0D+0)) 00152 * .. 00153 * .. Local Scalars .. 00154 COMPLEX*16 TEMP 00155 INTEGER I,INFO,IX,J,JX,K,KK,KX 00156 * .. 00157 * .. External Functions .. 00158 LOGICAL LSAME 00159 EXTERNAL LSAME 00160 * .. 00161 * .. External Subroutines .. 00162 EXTERNAL XERBLA 00163 * .. 00164 * .. Intrinsic Functions .. 00165 INTRINSIC DBLE,DCONJG 00166 * .. 00167 * 00168 * Test the input parameters. 00169 * 00170 INFO = 0 00171 IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN 00172 INFO = 1 00173 ELSE IF (N.LT.0) THEN 00174 INFO = 2 00175 ELSE IF (INCX.EQ.0) THEN 00176 INFO = 5 00177 END IF 00178 IF (INFO.NE.0) THEN 00179 CALL XERBLA('ZHPR ',INFO) 00180 RETURN 00181 END IF 00182 * 00183 * Quick return if possible. 00184 * 00185 IF ((N.EQ.0) .OR. (ALPHA.EQ.DBLE(ZERO))) RETURN 00186 * 00187 * Set the start point in X if the increment is not unity. 00188 * 00189 IF (INCX.LE.0) THEN 00190 KX = 1 - (N-1)*INCX 00191 ELSE IF (INCX.NE.1) THEN 00192 KX = 1 00193 END IF 00194 * 00195 * Start the operations. In this version the elements of the array AP 00196 * are accessed sequentially with one pass through AP. 00197 * 00198 KK = 1 00199 IF (LSAME(UPLO,'U')) THEN 00200 * 00201 * Form A when upper triangle is stored in AP. 00202 * 00203 IF (INCX.EQ.1) THEN 00204 DO 20 J = 1,N 00205 IF (X(J).NE.ZERO) THEN 00206 TEMP = ALPHA*DCONJG(X(J)) 00207 K = KK 00208 DO 10 I = 1,J - 1 00209 AP(K) = AP(K) + X(I)*TEMP 00210 K = K + 1 00211 10 CONTINUE 00212 AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(J)*TEMP) 00213 ELSE 00214 AP(KK+J-1) = DBLE(AP(KK+J-1)) 00215 END IF 00216 KK = KK + J 00217 20 CONTINUE 00218 ELSE 00219 JX = KX 00220 DO 40 J = 1,N 00221 IF (X(JX).NE.ZERO) THEN 00222 TEMP = ALPHA*DCONJG(X(JX)) 00223 IX = KX 00224 DO 30 K = KK,KK + J - 2 00225 AP(K) = AP(K) + X(IX)*TEMP 00226 IX = IX + INCX 00227 30 CONTINUE 00228 AP(KK+J-1) = DBLE(AP(KK+J-1)) + DBLE(X(JX)*TEMP) 00229 ELSE 00230 AP(KK+J-1) = DBLE(AP(KK+J-1)) 00231 END IF 00232 JX = JX + INCX 00233 KK = KK + J 00234 40 CONTINUE 00235 END IF 00236 ELSE 00237 * 00238 * Form A when lower triangle is stored in AP. 00239 * 00240 IF (INCX.EQ.1) THEN 00241 DO 60 J = 1,N 00242 IF (X(J).NE.ZERO) THEN 00243 TEMP = ALPHA*DCONJG(X(J)) 00244 AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(J)) 00245 K = KK + 1 00246 DO 50 I = J + 1,N 00247 AP(K) = AP(K) + X(I)*TEMP 00248 K = K + 1 00249 50 CONTINUE 00250 ELSE 00251 AP(KK) = DBLE(AP(KK)) 00252 END IF 00253 KK = KK + N - J + 1 00254 60 CONTINUE 00255 ELSE 00256 JX = KX 00257 DO 80 J = 1,N 00258 IF (X(JX).NE.ZERO) THEN 00259 TEMP = ALPHA*DCONJG(X(JX)) 00260 AP(KK) = DBLE(AP(KK)) + DBLE(TEMP*X(JX)) 00261 IX = JX 00262 DO 70 K = KK + 1,KK + N - J 00263 IX = IX + INCX 00264 AP(K) = AP(K) + X(IX)*TEMP 00265 70 CONTINUE 00266 ELSE 00267 AP(KK) = DBLE(AP(KK)) 00268 END IF 00269 JX = JX + INCX 00270 KK = KK + N - J + 1 00271 80 CONTINUE 00272 END IF 00273 END IF 00274 * 00275 RETURN 00276 * 00277 * End of ZHPR . 00278 * 00279 END