MINICERN/mathlib/gen/e/rlsqp1.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 RLSQP1(N,X,Y,A0,A1,SD,IFAIL)
  11       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  12       REAL X,Y,A0,A1,SD
  13
  14       DIMENSION X(*),Y(*)
  15
  16       PARAMETER (R0 = 0)
  17
  18       A0=0
  19       A1=0
  20       SD=0
  21       IF(N .LE. 1) THEN
  22        IFAIL=1
  23       ELSE
  24        FN=N
  25        XM=0
  26        DO 1 K = 1,N
  27        XM=XM+X(K)
  28     1  CONTINUE
  29        XM=XM/FN
  30        SX=0
  31        SY=0
  32        SXX=0
  33        SYY=0
  34        SXY=0
  35        DO 2 K = 1,N
  36        XK=X(K)-XM
  37        YK=Y(K)
  38        SX=SX+XK
  39        SY=SY+YK
  40        SXX=SXX+XK**2
  41        SYY=SYY+YK**2
  42        SXY=SXY+XK*YK
  43     2  CONTINUE
  44        DET=FN*SXX-SX**2
  45        IF(DET .GT. 0) THEN
  46         D0=(SY*SXX-SXY*SX)/DET
  47         D1=(FN*SXY-SX*SY)/DET
  48         IFAIL=0
  49        ELSE
  50         IFAIL=-1
  51        ENDIF
  52       ENDIF
  53       IF(IFAIL .EQ. 0) THEN
  54        IF(N .GT. 2) SD=SQRT(MAX(R0,SYY-D0*SY-D1*SXY)/(N-2))
  55        A0=D0-D1*XM
  56        A1=D1
  57       ENDIF
  58       RETURN
  59       END