00001 SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ ) 00002 * 00003 * -- LAPACK auxiliary routine (version 3.2) -- 00004 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00005 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00006 * November 2006 00007 * 00008 * .. Scalar Arguments .. 00009 INTEGER INCX, N 00010 REAL SCALE, SUMSQ 00011 * .. 00012 * .. Array Arguments .. 00013 COMPLEX X( * ) 00014 * .. 00015 * 00016 * Purpose 00017 * ======= 00018 * 00019 * CLASSQ returns the values scl and ssq such that 00020 * 00021 * ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, 00022 * 00023 * where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is 00024 * assumed to be at least unity and the value of ssq will then satisfy 00025 * 00026 * 1.0 .le. ssq .le. ( sumsq + 2*n ). 00027 * 00028 * scale is assumed to be non-negative and scl returns the value 00029 * 00030 * scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), 00031 * i 00032 * 00033 * scale and sumsq must be supplied in SCALE and SUMSQ respectively. 00034 * SCALE and SUMSQ are overwritten by scl and ssq respectively. 00035 * 00036 * The routine makes only one pass through the vector X. 00037 * 00038 * Arguments 00039 * ========= 00040 * 00041 * N (input) INTEGER 00042 * The number of elements to be used from the vector X. 00043 * 00044 * X (input) COMPLEX array, dimension (N) 00045 * The vector x as described above. 00046 * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. 00047 * 00048 * INCX (input) INTEGER 00049 * The increment between successive values of the vector X. 00050 * INCX > 0. 00051 * 00052 * SCALE (input/output) REAL 00053 * On entry, the value scale in the equation above. 00054 * On exit, SCALE is overwritten with the value scl . 00055 * 00056 * SUMSQ (input/output) REAL 00057 * On entry, the value sumsq in the equation above. 00058 * On exit, SUMSQ is overwritten with the value ssq . 00059 * 00060 * ===================================================================== 00061 * 00062 * .. Parameters .. 00063 REAL ZERO 00064 PARAMETER ( ZERO = 0.0E+0 ) 00065 * .. 00066 * .. Local Scalars .. 00067 INTEGER IX 00068 REAL TEMP1 00069 * .. 00070 * .. Intrinsic Functions .. 00071 INTRINSIC ABS, AIMAG, REAL 00072 * .. 00073 * .. Executable Statements .. 00074 * 00075 IF( N.GT.0 ) THEN 00076 DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX 00077 IF( REAL( X( IX ) ).NE.ZERO ) THEN 00078 TEMP1 = ABS( REAL( X( IX ) ) ) 00079 IF( SCALE.LT.TEMP1 ) THEN 00080 SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 00081 SCALE = TEMP1 00082 ELSE 00083 SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 00084 END IF 00085 END IF 00086 IF( AIMAG( X( IX ) ).NE.ZERO ) THEN 00087 TEMP1 = ABS( AIMAG( X( IX ) ) ) 00088 IF( SCALE.LT.TEMP1 ) THEN 00089 SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 00090 SCALE = TEMP1 00091 ELSE 00092 SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 00093 END IF 00094 END IF 00095 10 CONTINUE 00096 END IF 00097 * 00098 RETURN 00099 * 00100 * End of CLASSQ 00101 * 00102 END
1.7.2