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