This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / e / rlsqpm.F
1 *
2 * $Id$
3 *
4 * $Log$
5 * Revision 1.1.1.1  1996/04/01 15:02:24  mclareni
6 * Mathlib gen
7 *
8 *
9 #include "gen/pilot.h"
10       SUBROUTINE RLSQPM(N,X,Y,M,A,SD,IFAIL)
11       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12       REAL X,Y,A,R0
13  
14       PARAMETER (IDIM = 21, R0 = 0, D0 = 0)
15  
16       DIMENSION  X(*),Y(*),A(0:*),B(IDIM,IDIM),D(0:IDIM),XY(0:IDIM)
17  
18       M1=M+1
19       IFAIL=0
20       IF(N .LE. 1 .OR. M .LT. 0 .OR. M1 .GT. IDIM .OR. M1 .GT. N) THEN
21        IFAIL=1
22       ELSEIF(M .EQ. 0) THEN
23        XY(0)=DVSUM(N,Y(1),Y(2))
24        D(0)=XY(0)/N
25        SYY=DVMPY(N,Y(1),Y(2),Y(1),Y(2))
26       ELSE
27        DO 11 J = 1,M1
28        D(J-1)=0
29        B(J,1)=0
30        B(M1,J)=0
31    11  CONTINUE
32        B(1,1)=N
33        SYY=0
34        DO 4 K = 1,N
35        XK=X(K)
36        YK=Y(K)
37        SYY=SYY+YK**2
38        P=1
39        D(0)=D(0)+YK
40        DO 2 J = 2,M1
41        P=P*XK
42        B(J,1)=B(J,1)+P
43        D(J-1)=D(J-1)+P*YK
44     2  CONTINUE
45        DO 3 J = 2,M1
46        P=P*XK
47        B(M1,J)=B(M1,J)+P
48     3  CONTINUE
49     4  CONTINUE
50        DO 5 I = 2,M
51        DO 5 K = I,M1
52        B(K-1,I)=B(K,I-1)
53     5  CONTINUE
54        DO 6 J = 0,M
55        XY(J)=D(J)
56     6  CONTINUE
57        CALL DSEQN(M1,B,IDIM,IFAIL,1,D)
58       ENDIF
59       SD=0
60       IF(IFAIL .EQ. 0) THEN
61        IF(N .GT. M1) THEN
62         SD=SYY
63         DO 7 J = 0,M
64         SD=SD-D(J)*XY(J)
65     7   CONTINUE
66         SD=SQRT(MAX(D0,SD)/(N-M1))
67        ENDIF
68        DO 8 J = 0,M
69        A(J)=D(J)
70     8  CONTINUE
71       ELSE
72        CALL RVSET(M1,R0,A(0),A(1))
73        M=0
74       ENDIF
75       RETURN
76       END