var/external/lapack/dlassq.inc

   1       SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
   2 !
   3 !  -- LAPACK auxiliary routine (version 3.1) --
   4 !     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
   5 !     November 2006
   6 !
   7 !     .. Scalar Arguments ..
   8       INTEGER            INCX, N
   9       DOUBLE PRECISION   SCALE, SUMSQ
  10 !     ..
  11 !     .. Array Arguments ..
  12       DOUBLE PRECISION   X( * )
  13 !     ..
  14 !
  15 !  Purpose
  16 !  =======
  17 !
  18 !  DLASSQ  returns the values  scl  and  smsq  such that
  19 !
  20 !     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
  21 !
  22 !  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
  23 !  assumed to be non-negative and  scl  returns the value
  24 !
  25 !     scl = max( scale, abs( x( i ) ) ).
  26 !
  27 !  scale and sumsq must be supplied in SCALE and SUMSQ and
  28 !  scl and smsq are overwritten on SCALE and SUMSQ respectively.
  29 !
  30 !  The routine makes only one pass through the vector x.
  31 !
  32 !  Arguments
  33 !  =========
  34 !
  35 !  N       (input) INTEGER
  36 !          The number of elements to be used from the vector X.
  37 !
  38 !  X       (input) DOUBLE PRECISION array, dimension (N)
  39 !          The vector for which a scaled sum of squares is computed.
  40 !             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
  41 !
  42 !  INCX    (input) INTEGER
  43 !          The increment between successive values of the vector X.
  44 !          INCX > 0.
  45 !
  46 !  SCALE   (input/output) DOUBLE PRECISION
  47 !          On entry, the value  scale  in the equation above.
  48 !          On exit, SCALE is overwritten with  scl , the scaling factor
  49 !          for the sum of squares.
  50 !
  51 !  SUMSQ   (input/output) DOUBLE PRECISION
  52 !          On entry, the value  sumsq  in the equation above.
  53 !          On exit, SUMSQ is overwritten with  smsq , the basic sum of
  54 !          squares from which  scl  has been factored out.
  55 !
  56 ! =====================================================================
  57 !
  58 !     .. Parameters ..
  59       DOUBLE PRECISION   ZERO
  60       PARAMETER          ( ZERO = 0.0D+0 )
  61 !     ..
  62 !     .. Local Scalars ..
  63       INTEGER            IX
  64       DOUBLE PRECISION   ABSXI
  65 !     ..
  66 !     .. Intrinsic Functions ..
  67       INTRINSIC          ABS
  68 !     ..
  69 !     .. Executable Statements ..
  70 !
  71       IF( N.GT.0 ) THEN
  72          DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
  73             IF( X( IX ).NE.ZERO ) THEN
  74                ABSXI = ABS( X( IX ) )
  75                IF( SCALE.LT.ABSXI ) THEN
  76                   SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
  77                   SCALE = ABSXI
  78                ELSE
  79                   SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
  80                END IF
  81             END IF
  82    10    CONTINUE
  83       END IF
  84       RETURN
  85 !
  86 !     End of DLASSQ
  87 !
  88       END SUBROUTINE DLASSQ