![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CHFRK 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 *> \htmlonly 00009 *> Download CHFRK + dependencies 00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chfrk.f"> 00011 *> [TGZ]</a> 00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chfrk.f"> 00013 *> [ZIP]</a> 00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chfrk.f"> 00015 *> [TXT]</a> 00016 *> \endhtmlonly 00017 * 00018 * Definition: 00019 * =========== 00020 * 00021 * SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, 00022 * C ) 00023 * 00024 * .. Scalar Arguments .. 00025 * REAL ALPHA, BETA 00026 * INTEGER K, LDA, N 00027 * CHARACTER TRANS, TRANSR, UPLO 00028 * .. 00029 * .. Array Arguments .. 00030 * COMPLEX A( LDA, * ), C( * ) 00031 * .. 00032 * 00033 * 00034 *> \par Purpose: 00035 * ============= 00036 *> 00037 *> \verbatim 00038 *> 00039 *> Level 3 BLAS like routine for C in RFP Format. 00040 *> 00041 *> CHFRK performs one of the Hermitian rank--k operations 00042 *> 00043 *> C := alpha*A*A**H + beta*C, 00044 *> 00045 *> or 00046 *> 00047 *> C := alpha*A**H*A + beta*C, 00048 *> 00049 *> where alpha and beta are real scalars, C is an n--by--n Hermitian 00050 *> matrix and A is an n--by--k matrix in the first case and a k--by--n 00051 *> matrix in the second case. 00052 *> \endverbatim 00053 * 00054 * Arguments: 00055 * ========== 00056 * 00057 *> \param[in] TRANSR 00058 *> \verbatim 00059 *> TRANSR is CHARACTER*1 00060 *> = 'N': The Normal Form of RFP A is stored; 00061 *> = 'C': The Conjugate-transpose Form of RFP A is stored. 00062 *> \endverbatim 00063 *> 00064 *> \param[in] UPLO 00065 *> \verbatim 00066 *> UPLO is CHARACTER*1 00067 *> On entry, UPLO specifies whether the upper or lower 00068 *> triangular part of the array C is to be referenced as 00069 *> follows: 00070 *> 00071 *> UPLO = 'U' or 'u' Only the upper triangular part of C 00072 *> is to be referenced. 00073 *> 00074 *> UPLO = 'L' or 'l' Only the lower triangular part of C 00075 *> is to be referenced. 00076 *> 00077 *> Unchanged on exit. 00078 *> \endverbatim 00079 *> 00080 *> \param[in] TRANS 00081 *> \verbatim 00082 *> TRANS is CHARACTER*1 00083 *> On entry, TRANS specifies the operation to be performed as 00084 *> follows: 00085 *> 00086 *> TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C. 00087 *> 00088 *> TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C. 00089 *> 00090 *> Unchanged on exit. 00091 *> \endverbatim 00092 *> 00093 *> \param[in] N 00094 *> \verbatim 00095 *> N is INTEGER 00096 *> On entry, N specifies the order of the matrix C. N must be 00097 *> at least zero. 00098 *> Unchanged on exit. 00099 *> \endverbatim 00100 *> 00101 *> \param[in] K 00102 *> \verbatim 00103 *> K is INTEGER 00104 *> On entry with TRANS = 'N' or 'n', K specifies the number 00105 *> of columns of the matrix A, and on entry with 00106 *> TRANS = 'C' or 'c', K specifies the number of rows of the 00107 *> matrix A. K must be at least zero. 00108 *> Unchanged on exit. 00109 *> \endverbatim 00110 *> 00111 *> \param[in] ALPHA 00112 *> \verbatim 00113 *> ALPHA is REAL 00114 *> On entry, ALPHA specifies the scalar alpha. 00115 *> Unchanged on exit. 00116 *> \endverbatim 00117 *> 00118 *> \param[in] A 00119 *> \verbatim 00120 *> A is COMPLEX array, dimension (LDA,ka) 00121 *> where KA 00122 *> is K when TRANS = 'N' or 'n', and is N otherwise. Before 00123 *> entry with TRANS = 'N' or 'n', the leading N--by--K part of 00124 *> the array A must contain the matrix A, otherwise the leading 00125 *> K--by--N part of the array A must contain the matrix A. 00126 *> Unchanged on exit. 00127 *> \endverbatim 00128 *> 00129 *> \param[in] LDA 00130 *> \verbatim 00131 *> LDA is INTEGER 00132 *> On entry, LDA specifies the first dimension of A as declared 00133 *> in the calling (sub) program. When TRANS = 'N' or 'n' 00134 *> then LDA must be at least max( 1, n ), otherwise LDA must 00135 *> be at least max( 1, k ). 00136 *> Unchanged on exit. 00137 *> \endverbatim 00138 *> 00139 *> \param[in] BETA 00140 *> \verbatim 00141 *> BETA is REAL 00142 *> On entry, BETA specifies the scalar beta. 00143 *> Unchanged on exit. 00144 *> \endverbatim 00145 *> 00146 *> \param[in,out] C 00147 *> \verbatim 00148 *> C is COMPLEX array, dimension (N*(N+1)/2) 00149 *> On entry, the matrix A in RFP Format. RFP Format is 00150 *> described by TRANSR, UPLO and N. Note that the imaginary 00151 *> parts of the diagonal elements need not be set, they are 00152 *> assumed to be zero, and on exit they are set to zero. 00153 *> \endverbatim 00154 * 00155 * Authors: 00156 * ======== 00157 * 00158 *> \author Univ. of Tennessee 00159 *> \author Univ. of California Berkeley 00160 *> \author Univ. of Colorado Denver 00161 *> \author NAG Ltd. 00162 * 00163 *> \date November 2011 00164 * 00165 *> \ingroup complexOTHERcomputational 00166 * 00167 * ===================================================================== 00168 SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, 00169 $ C ) 00170 * 00171 * -- LAPACK computational routine (version 3.4.0) -- 00172 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00173 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00174 * November 2011 00175 * 00176 * .. Scalar Arguments .. 00177 REAL ALPHA, BETA 00178 INTEGER K, LDA, N 00179 CHARACTER TRANS, TRANSR, UPLO 00180 * .. 00181 * .. Array Arguments .. 00182 COMPLEX A( LDA, * ), C( * ) 00183 * .. 00184 * 00185 * ===================================================================== 00186 * 00187 * .. 00188 * .. Parameters .. 00189 REAL ONE, ZERO 00190 COMPLEX CZERO 00191 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00192 PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) 00193 * .. 00194 * .. Local Scalars .. 00195 LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS 00196 INTEGER INFO, NROWA, J, NK, N1, N2 00197 COMPLEX CALPHA, CBETA 00198 * .. 00199 * .. External Functions .. 00200 LOGICAL LSAME 00201 EXTERNAL LSAME 00202 * .. 00203 * .. External Subroutines .. 00204 EXTERNAL CGEMM, CHERK, XERBLA 00205 * .. 00206 * .. Intrinsic Functions .. 00207 INTRINSIC MAX, CMPLX 00208 * .. 00209 * .. Executable Statements .. 00210 * 00211 * 00212 * Test the input parameters. 00213 * 00214 INFO = 0 00215 NORMALTRANSR = LSAME( TRANSR, 'N' ) 00216 LOWER = LSAME( UPLO, 'L' ) 00217 NOTRANS = LSAME( TRANS, 'N' ) 00218 * 00219 IF( NOTRANS ) THEN 00220 NROWA = N 00221 ELSE 00222 NROWA = K 00223 END IF 00224 * 00225 IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN 00226 INFO = -1 00227 ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN 00228 INFO = -2 00229 ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN 00230 INFO = -3 00231 ELSE IF( N.LT.0 ) THEN 00232 INFO = -4 00233 ELSE IF( K.LT.0 ) THEN 00234 INFO = -5 00235 ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN 00236 INFO = -8 00237 END IF 00238 IF( INFO.NE.0 ) THEN 00239 CALL XERBLA( 'CHFRK ', -INFO ) 00240 RETURN 00241 END IF 00242 * 00243 * Quick return if possible. 00244 * 00245 * The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not 00246 * done (it is in CHERK for example) and left in the general case. 00247 * 00248 IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. 00249 $ ( BETA.EQ.ONE ) ) )RETURN 00250 * 00251 IF( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ZERO ) ) THEN 00252 DO J = 1, ( ( N*( N+1 ) ) / 2 ) 00253 C( J ) = CZERO 00254 END DO 00255 RETURN 00256 END IF 00257 * 00258 CALPHA = CMPLX( ALPHA, ZERO ) 00259 CBETA = CMPLX( BETA, ZERO ) 00260 * 00261 * C is N-by-N. 00262 * If N is odd, set NISODD = .TRUE., and N1 and N2. 00263 * If N is even, NISODD = .FALSE., and NK. 00264 * 00265 IF( MOD( N, 2 ).EQ.0 ) THEN 00266 NISODD = .FALSE. 00267 NK = N / 2 00268 ELSE 00269 NISODD = .TRUE. 00270 IF( LOWER ) THEN 00271 N2 = N / 2 00272 N1 = N - N2 00273 ELSE 00274 N1 = N / 2 00275 N2 = N - N1 00276 END IF 00277 END IF 00278 * 00279 IF( NISODD ) THEN 00280 * 00281 * N is odd 00282 * 00283 IF( NORMALTRANSR ) THEN 00284 * 00285 * N is odd and TRANSR = 'N' 00286 * 00287 IF( LOWER ) THEN 00288 * 00289 * N is odd, TRANSR = 'N', and UPLO = 'L' 00290 * 00291 IF( NOTRANS ) THEN 00292 * 00293 * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' 00294 * 00295 CALL CHERK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, 00296 $ BETA, C( 1 ), N ) 00297 CALL CHERK( 'U', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, 00298 $ BETA, C( N+1 ), N ) 00299 CALL CGEMM( 'N', 'C', N2, N1, K, CALPHA, A( N1+1, 1 ), 00300 $ LDA, A( 1, 1 ), LDA, CBETA, C( N1+1 ), N ) 00301 * 00302 ELSE 00303 * 00304 * N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' 00305 * 00306 CALL CHERK( 'L', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, 00307 $ BETA, C( 1 ), N ) 00308 CALL CHERK( 'U', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA, 00309 $ BETA, C( N+1 ), N ) 00310 CALL CGEMM( 'C', 'N', N2, N1, K, CALPHA, A( 1, N1+1 ), 00311 $ LDA, A( 1, 1 ), LDA, CBETA, C( N1+1 ), N ) 00312 * 00313 END IF 00314 * 00315 ELSE 00316 * 00317 * N is odd, TRANSR = 'N', and UPLO = 'U' 00318 * 00319 IF( NOTRANS ) THEN 00320 * 00321 * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' 00322 * 00323 CALL CHERK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, 00324 $ BETA, C( N2+1 ), N ) 00325 CALL CHERK( 'U', 'N', N2, K, ALPHA, A( N2, 1 ), LDA, 00326 $ BETA, C( N1+1 ), N ) 00327 CALL CGEMM( 'N', 'C', N1, N2, K, CALPHA, A( 1, 1 ), 00328 $ LDA, A( N2, 1 ), LDA, CBETA, C( 1 ), N ) 00329 * 00330 ELSE 00331 * 00332 * N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' 00333 * 00334 CALL CHERK( 'L', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, 00335 $ BETA, C( N2+1 ), N ) 00336 CALL CHERK( 'U', 'C', N2, K, ALPHA, A( 1, N2 ), LDA, 00337 $ BETA, C( N1+1 ), N ) 00338 CALL CGEMM( 'C', 'N', N1, N2, K, CALPHA, A( 1, 1 ), 00339 $ LDA, A( 1, N2 ), LDA, CBETA, C( 1 ), N ) 00340 * 00341 END IF 00342 * 00343 END IF 00344 * 00345 ELSE 00346 * 00347 * N is odd, and TRANSR = 'C' 00348 * 00349 IF( LOWER ) THEN 00350 * 00351 * N is odd, TRANSR = 'C', and UPLO = 'L' 00352 * 00353 IF( NOTRANS ) THEN 00354 * 00355 * N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' 00356 * 00357 CALL CHERK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, 00358 $ BETA, C( 1 ), N1 ) 00359 CALL CHERK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, 00360 $ BETA, C( 2 ), N1 ) 00361 CALL CGEMM( 'N', 'C', N1, N2, K, CALPHA, A( 1, 1 ), 00362 $ LDA, A( N1+1, 1 ), LDA, CBETA, 00363 $ C( N1*N1+1 ), N1 ) 00364 * 00365 ELSE 00366 * 00367 * N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' 00368 * 00369 CALL CHERK( 'U', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, 00370 $ BETA, C( 1 ), N1 ) 00371 CALL CHERK( 'L', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA, 00372 $ BETA, C( 2 ), N1 ) 00373 CALL CGEMM( 'C', 'N', N1, N2, K, CALPHA, A( 1, 1 ), 00374 $ LDA, A( 1, N1+1 ), LDA, CBETA, 00375 $ C( N1*N1+1 ), N1 ) 00376 * 00377 END IF 00378 * 00379 ELSE 00380 * 00381 * N is odd, TRANSR = 'C', and UPLO = 'U' 00382 * 00383 IF( NOTRANS ) THEN 00384 * 00385 * N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' 00386 * 00387 CALL CHERK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, 00388 $ BETA, C( N2*N2+1 ), N2 ) 00389 CALL CHERK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, 00390 $ BETA, C( N1*N2+1 ), N2 ) 00391 CALL CGEMM( 'N', 'C', N2, N1, K, CALPHA, A( N1+1, 1 ), 00392 $ LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), N2 ) 00393 * 00394 ELSE 00395 * 00396 * N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' 00397 * 00398 CALL CHERK( 'U', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, 00399 $ BETA, C( N2*N2+1 ), N2 ) 00400 CALL CHERK( 'L', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA, 00401 $ BETA, C( N1*N2+1 ), N2 ) 00402 CALL CGEMM( 'C', 'N', N2, N1, K, CALPHA, A( 1, N1+1 ), 00403 $ LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), N2 ) 00404 * 00405 END IF 00406 * 00407 END IF 00408 * 00409 END IF 00410 * 00411 ELSE 00412 * 00413 * N is even 00414 * 00415 IF( NORMALTRANSR ) THEN 00416 * 00417 * N is even and TRANSR = 'N' 00418 * 00419 IF( LOWER ) THEN 00420 * 00421 * N is even, TRANSR = 'N', and UPLO = 'L' 00422 * 00423 IF( NOTRANS ) THEN 00424 * 00425 * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' 00426 * 00427 CALL CHERK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, 00428 $ BETA, C( 2 ), N+1 ) 00429 CALL CHERK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, 00430 $ BETA, C( 1 ), N+1 ) 00431 CALL CGEMM( 'N', 'C', NK, NK, K, CALPHA, A( NK+1, 1 ), 00432 $ LDA, A( 1, 1 ), LDA, CBETA, C( NK+2 ), 00433 $ N+1 ) 00434 * 00435 ELSE 00436 * 00437 * N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' 00438 * 00439 CALL CHERK( 'L', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, 00440 $ BETA, C( 2 ), N+1 ) 00441 CALL CHERK( 'U', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, 00442 $ BETA, C( 1 ), N+1 ) 00443 CALL CGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, NK+1 ), 00444 $ LDA, A( 1, 1 ), LDA, CBETA, C( NK+2 ), 00445 $ N+1 ) 00446 * 00447 END IF 00448 * 00449 ELSE 00450 * 00451 * N is even, TRANSR = 'N', and UPLO = 'U' 00452 * 00453 IF( NOTRANS ) THEN 00454 * 00455 * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' 00456 * 00457 CALL CHERK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, 00458 $ BETA, C( NK+2 ), N+1 ) 00459 CALL CHERK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, 00460 $ BETA, C( NK+1 ), N+1 ) 00461 CALL CGEMM( 'N', 'C', NK, NK, K, CALPHA, A( 1, 1 ), 00462 $ LDA, A( NK+1, 1 ), LDA, CBETA, C( 1 ), 00463 $ N+1 ) 00464 * 00465 ELSE 00466 * 00467 * N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' 00468 * 00469 CALL CHERK( 'L', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, 00470 $ BETA, C( NK+2 ), N+1 ) 00471 CALL CHERK( 'U', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, 00472 $ BETA, C( NK+1 ), N+1 ) 00473 CALL CGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, 1 ), 00474 $ LDA, A( 1, NK+1 ), LDA, CBETA, C( 1 ), 00475 $ N+1 ) 00476 * 00477 END IF 00478 * 00479 END IF 00480 * 00481 ELSE 00482 * 00483 * N is even, and TRANSR = 'C' 00484 * 00485 IF( LOWER ) THEN 00486 * 00487 * N is even, TRANSR = 'C', and UPLO = 'L' 00488 * 00489 IF( NOTRANS ) THEN 00490 * 00491 * N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' 00492 * 00493 CALL CHERK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, 00494 $ BETA, C( NK+1 ), NK ) 00495 CALL CHERK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, 00496 $ BETA, C( 1 ), NK ) 00497 CALL CGEMM( 'N', 'C', NK, NK, K, CALPHA, A( 1, 1 ), 00498 $ LDA, A( NK+1, 1 ), LDA, CBETA, 00499 $ C( ( ( NK+1 )*NK )+1 ), NK ) 00500 * 00501 ELSE 00502 * 00503 * N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' 00504 * 00505 CALL CHERK( 'U', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, 00506 $ BETA, C( NK+1 ), NK ) 00507 CALL CHERK( 'L', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, 00508 $ BETA, C( 1 ), NK ) 00509 CALL CGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, 1 ), 00510 $ LDA, A( 1, NK+1 ), LDA, CBETA, 00511 $ C( ( ( NK+1 )*NK )+1 ), NK ) 00512 * 00513 END IF 00514 * 00515 ELSE 00516 * 00517 * N is even, TRANSR = 'C', and UPLO = 'U' 00518 * 00519 IF( NOTRANS ) THEN 00520 * 00521 * N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' 00522 * 00523 CALL CHERK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, 00524 $ BETA, C( NK*( NK+1 )+1 ), NK ) 00525 CALL CHERK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, 00526 $ BETA, C( NK*NK+1 ), NK ) 00527 CALL CGEMM( 'N', 'C', NK, NK, K, CALPHA, A( NK+1, 1 ), 00528 $ LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), NK ) 00529 * 00530 ELSE 00531 * 00532 * N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' 00533 * 00534 CALL CHERK( 'U', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, 00535 $ BETA, C( NK*( NK+1 )+1 ), NK ) 00536 CALL CHERK( 'L', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, 00537 $ BETA, C( NK*NK+1 ), NK ) 00538 CALL CGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, NK+1 ), 00539 $ LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), NK ) 00540 * 00541 END IF 00542 * 00543 END IF 00544 * 00545 END IF 00546 * 00547 END IF 00548 * 00549 RETURN 00550 * 00551 * End of CHFRK 00552 * 00553 END