source: iLOVECLIM-branch/SOURCES/BLAS/slassq.f @ 28

Last change on this file since 28 was 22, checked in by roche, 9 years ago

Petites adaptations diverses du code pour compilation en gfortran. Ajout d un Makefile flexible a option pour choisir ifort ou gfortran.
File size: 4.1 KB
Line 
1*> \brief \b SLASSQ
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at 
6*            http://www.netlib.org/lapack/explore-html/ 
7*
8*> \htmlonly
9*> Download SLASSQ + dependencies 
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slassq.f"> 
11*> [TGZ]</a> 
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slassq.f"> 
13*> [ZIP]</a> 
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slassq.f"> 
15*> [TXT]</a>
16*> \endhtmlonly 
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )
22* 
23*       .. Scalar Arguments ..
24*       INTEGER            INCX, N
25*       REAL               SCALE, SUMSQ
26*       ..
27*       .. Array Arguments ..
28*       REAL               X( * )
29*       ..
30* 
31*
32*> \par Purpose:
33*  =============
34*>
35*> \verbatim
36*>
37*> SLASSQ  returns the values  scl  and  smsq  such that
38*>
39*>    ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
40*>
41*> where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
42*> assumed to be non-negative and  scl  returns the value
43*>
44*>    scl = max( scale, abs( x( i ) ) ).
45*>
46*> scale and sumsq must be supplied in SCALE and SUMSQ and
47*> scl and smsq are overwritten on SCALE and SUMSQ respectively.
48*>
49*> The routine makes only one pass through the vector x.
50*> \endverbatim
51*
52*  Arguments:
53*  ==========
54*
55*> \param[in] N
56*> \verbatim
57*>          N is INTEGER
58*>          The number of elements to be used from the vector X.
59*> \endverbatim
60*>
61*> \param[in] X
62*> \verbatim
63*>          X is REAL array, dimension (N)
64*>          The vector for which a scaled sum of squares is computed.
65*>             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
66*> \endverbatim
67*>
68*> \param[in] INCX
69*> \verbatim
70*>          INCX is INTEGER
71*>          The increment between successive values of the vector X.
72*>          INCX > 0.
73*> \endverbatim
74*>
75*> \param[in,out] SCALE
76*> \verbatim
77*>          SCALE is REAL
78*>          On entry, the value  scale  in the equation above.
79*>          On exit, SCALE is overwritten with  scl , the scaling factor
80*>          for the sum of squares.
81*> \endverbatim
82*>
83*> \param[in,out] SUMSQ
84*> \verbatim
85*>          SUMSQ is REAL
86*>          On entry, the value  sumsq  in the equation above.
87*>          On exit, SUMSQ is overwritten with  smsq , the basic sum of
88*>          squares from which  scl  has been factored out.
89*> \endverbatim
90*
91*  Authors:
92*  ========
93*
94*> \author Univ. of Tennessee 
95*> \author Univ. of California Berkeley 
96*> \author Univ. of Colorado Denver 
97*> \author NAG Ltd. 
98*
99*> \date November 2011
100*
101*> \ingroup auxOTHERauxiliary
102*
103*  =====================================================================
104      SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )
105*
106*  -- LAPACK auxiliary routine (version 3.4.0) --
107*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
108*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
109*     November 2011
110*
111*     .. Scalar Arguments ..
112      INTEGER            INCX, N
113      REAL               SCALE, SUMSQ
114*     ..
115*     .. Array Arguments ..
116      REAL               X( * )
117*     ..
118*
119* =====================================================================
120*
121*     .. Parameters ..
122      REAL               ZERO
123      PARAMETER          ( ZERO = 0.0E+0 )
124*     ..
125*     .. Local Scalars ..
126      INTEGER            IX
127      REAL               ABSXI
128*     ..
129*     .. Intrinsic Functions ..
130      INTRINSIC          ABS
131*     ..
132*     .. Executable Statements ..
133*
134      IF( N.GT.0 ) THEN
135         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
136            IF( X( IX ).NE.ZERO ) THEN
137               ABSXI = ABS( X( IX ) )
138               IF( SCALE.LT.ABSXI ) THEN
139                  SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
140                  SCALE = ABSXI
141               ELSE
142                  SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
143               END IF
144            END IF
145   10    CONTINUE
146      END IF
147      RETURN
148*
149*     End of SLASSQ
150*
151      END
Note: See TracBrowser for help on using the repository browser.