FTN,L,B 
C 
C HP92405A CURVE FITTING PACKAGE
C 
C SOURCE TAPE 92405-80001 REV. A
C RELOC. TAPE 92405-60001 REV. A
C 
C AUTHOR - T.A. SAPONAS 
C 
C VERSION 3 OCTOBER 1973
C 
C 
      SUBROUTINE CRVFT(ITYPE,X,Y,N,A,B,ERRMX) 
C  "CRVFT" PERFORMS A LEAST SQUARE ERROR CURVE FIT ON THE 
C   FUNCTION ARGUMENTS IN ARRAY "X" AND THE CORRESPONDING 
C   FUNCTION VALUES IN ARRAY "Y".  "ITYPE" DETERMINES THE CURVE 
C   TO BE FIT, AND "ERRMX" IS THE MAXIMUM ERROR OF THE DATA 
C   FROM THE FITTED CURVE.
C   IF "ITYPE" OR "N" HAVE ILLEGAL VALUES ERRMX = -2.0 .
C   IF THE DATA WON'T FIT THE SELECTED CURVE ERRMX = -1.0 . 
C   "A" AND "B" ARE THE COEFFICIENTS FOR THE EQUATION SELECTED
C   BY "ITYPE".  SUBROUTINE "XYTTL" PERFORMS A RUNNING SUM, 
C   SUM OF SQUARES AND SUM OF CROSS PRODUDCT. 
C 
      DIMENSION X(1),Y(1),SUM(5)
C 
C  IF ITYPE < 1 OR ITYPE > 6 OR N < 1 SET ERRMX = -2.0
      IF(N)901,901,1
    1 IF(ITYPE)901,901,2
    2 IF(ITYPE-7)3,901
C 
C  INITIALIZE ACCUMULATORS
    3 DO 4 I = 1,5
    4 SUM(I) = 0. 
      BSIGN = 1.
C 
C  BRANCH TO SELECTED EQUATION CURVE FIT
      GO TO (100,200,300,400,500,600),ITYPE 
C 
C  CURVE FIT FOR Y = A*X + B
  100 DO 101 I = 1,N
  101 CALL XYTTL(SUM,X(I),Y(I)) 
      GO TO 800 
C 
C  CURVE FIT FOR Y = A/X + B
  200 DO 201 I = 1,N
      IF(X(I))201,900,201 
  201 CALL XYTTL(SUM,1./X(I),Y(I))
      GO TO 800 
C 
C  CURVE FIT FOR Y = 1/( A*X + B )
  300 DO 301 I = 1,N
      IF(Y(I))301,900,301 
  301 CALL XYTTL(SUM,X(I),1./Y(I))
      GO TO 800 
C 
C  CURVE FIT FOR Y = X/( A + B*X )
  400 DO 401 I = 1,N
      IF(X(I))402,900,402 
  402 IF(Y(I))401,900,401 
  401 CALL XYTTL(SUM,1./X(I),1./Y(I)) 
      GO TO 800 
C 
C  CURVE FIT FOR Y = B*EXP( A*X ) 
500   BSIGN = SIGN(1.,Y)
      DO 501 I = 1,N
      A = Y(I)*BSIGN
      IF(A)900,900,501
  501 CALL XYTTL(SUM,X(I),ALOG(A))
      GO TO 800 
C 
C  CURVE FIT FOR Y = B*X**A 
600   BSIGN = SIGN(1.,Y)
      DO 601 I = 1,N
      A = BSIGN*Y(I)
      IF(X(I))900,900,602 
  602 IF(A)900,900,601
  601 CALL XYTTL(SUM,ALOG(X(I)),ALOG(A))
  800 RN = N
C 
C  COMPUTE A AND B COEFFICIENTS FROM SUMS, SUM OF SQUARES AND 
C  SUM OF CROSS PRODUCT 
      A = (RN*SUM(4)-SUM*SUM(3))/(RN*SUM(2)-SUM*SUM)
      B = (SUM(3)-A*SUM)/RN 
      IF(ITYPE-5)801,802
  802 B = EXP(B)
  801 ERRMX = 0.
      B = BSIGN*B 
C 
C  COMPUTE MAXIMUM ERROR AND STANDARD ERROR OF CURVE FIT
C  BY EVALUATING CURVE AT EVERY POINT AND COMPARING TO DATA 
      DO 805 I = 1,N
C 
C  BRANCH TO CORRESPONDING FUNCTION EVALUATION
      GO TO (810,820,830,840,850,860),ITYPE 
  810 F = A*X(I)+B
      GO TO 803 
  820 F = A/X(I)+B
      GO TO 803 
  830 F = 1./(A*X(I)+B) 
      GO TO 803 
  840 F = X(I)/(A+B*X(I)) 
      GO TO 803 
  850 F = B*EXP(A*X(I)) 
      GO TO 803 
  860 F = B*X(I)**A 
C 
C  COMPUTE MAGNITUDE OF ERROR 
  803 F = ABS(F-Y(I)) 
C 
C  IF ERROR IS LARGER THAN PREVIOUS MAXIMUM, MAKE IT NEW MAXIMUM
      IF(ERRMX-F)804,805
  804 ERRMX = F 
  805 CONTINUE
      RETURN
C 
C  ERROR RETURN WHEN DATA WILL NOT FIT CURVE ( EITHER A DIVIDE
C  BY ZERO OR BOTH POSITIVE AND NEGATIVE Y VALUES IN CURVES 
C  5 OR 6 ).
  900 ERRMX = -1. 
      RETURN
C 
C ERROR RETURN FOR BAD N OR ITYPE 
  901 ERRMX = -2. 
      RETURN
      END 
      SUBROUTINE XYTTL(SUM,X,Y) 
C 
C  "XYTTL" COMPUTES RUNNING SUM, SUM OF SQUARES AND SUM OF
C  CROSS PRODUCT OF "X" AND "Y" 
      DIMENSION SUM(5)
      SUM = SUM+X 
      SUM(2) = SUM(2)+X*X 
      SUM(3) = SUM(3)+Y 
      SUM(4) = SUM(4)+X*Y 
      SUM(5) = SUM(5)+Y*Y 
      RETURN
      END 
      END$
                                                                                                                                                                                            