F 8.2.2 Nonlinear Root-Mean-Square Fitting
SUBROUTINE SNLFIT (X, Y, W, IWFL, PHI, JNDVT, DVT, MAXIT,
+ PSI, LDA, M, N, INUM, EPS, A, D, S, C,
+ FV, SQERR, IERR)
C
C*****************************************************************
C *
C The SUBROUTINE SNLFIT computes a non-linear discrete fitting *
C for M+1 given pairs of values (X(I), Y(I)), I=0, ..., M, *
C possibly using weights, by finding a non-linear approximating *
C function defined by N+1 parameters C(K), K=0, ..., M. *
C The model functions have to be provided by the user as a *
C FUNCTION-subroutine. Additionally a SUBROUTINE called DVT may *
C be provided by the user (if JNDVT = 0) that determines the *
C partial derivatives with respect to C(K) for K=0, ..., N. *
C Based on an initial approximation for the desired parameters, *
C the optimal parameters for the fitting function are *
C determined using the damped Newton-method for non-linear *
C systems. The linear minimization problem that is to be solved *
C for each iteration step is solved using Householder *
C transformations. *
C Finally, the value of the fitting function is determined for *
C INUM given locations. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C *
C X (N+1)-vector X(0:M) containing the X-values of the nodes*
C Y (N+1)-vector Y(0:M) containing the Y-values at the nodes*
C W (N+1)-vector W(0:M) containing the positive weights *
C IWFL if IWFL = 0, the nodes will be weighed according to the *
C weights in W. *
C Otherwise, all weights are set to 1, i.e., there is no *
C need to define values for W *
C PHI FUNCTION-subroutine for the model functions defined in *
C the following form: *
C *
C DOUBLE PRECISION FUNCTION PHI (C, N, X) *
C IMPLICIT DOUBLE PRECISION (A-H,O-Z) *
C INTEGER N *
C DIMENSION C(0:N), X *
C -------------------- *
C PHI = value of the model function at X *
C -------------------- *
C RETURN *
C END *
C *
C In the calling program PHI has to be declared as *
C EXTERNAL. *
C *
C JNDVT if JNDVT = 0, the user has provided a subroutine called *
C DVT that determines the partial derivatives. *
C Otherwise the partial derivatives are approximated by *
C central difference quotients. *
C DVT user supplied SUBROUTINE that determines the partial *
C derivatives: *
C *
C SUBROUTINE DVT (X, C, N, F) *
C IMPLICIT DOUBLE PRECISION (A-H,O-Z) *
C INTEGER N *
C DIMENSION C(0:N), F(0:N) *
C ---------------------- *
C F(0) = partial derivative w. r. t. C(0) at X *
C . *
C . *
C . *
C F(N) = partial derivative w.r.t C(N) at X *
C ---------------------- *
C RETURN *
C END *
C *
C In the calling program DVT has to be defined as *
C EXTERNAL. *
C MAXIT maximum number of iterations to be performed *
C PSI INUM-vector PSI(1:INUM) containing the locations where *
C the fitting function is to be evaluated *
C LDA leading dimension of the matrix A (LDA >= M ) *
C M M+1 = number of nodes *
C N N+1 = number of model functions used *
C INUM at INUM locations the fitting function is to evaluated *
C EPS relative error bound for the precision of the optimal *
C parameters *
C C (N+1)-vector C(0:N) containing the initial approxima- *
C tions for the parameters *
C *
C *
C AUXILIARY PARAMETERS: *
C ===================== *
C *
C A 2-dim array A(0:LDA, 0:N+2), the Jacobi matrix *
C D (N+1)-vector D(0:N), auxiliary vector for SHOUSE *
C S (N+1)-vector S(0:N) for the Newton-direction *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C *
C C (N+1)-vector C(0:N), containing the parameters for the *
C fitting function *
C FV INUM-vector FV(1:INUM), containing the values of the *
C fitting function at the INUM given locations *
C PSI(I), I=1(1)INUM *
C IERR error parameter: *
C = 0 : everything o.k. *
C = 1 : error in the input parameters *
C = 2 : an error occurred in SUBROUTINE SHOUSE because *
C (numerically) the functional matrix does not *
C have maximal rank *
C = 3 : after MAXIT iterations the required precision *
C was not reached, i.e., either EPS was chosen *
C too small or the iteration does not converge *
C possibly because the original approximations *
C were too imprecise. *
C SQERR least square error *
C *
C----------------------------------------------------------------*
C *
C subroutines required: SNLPRE, SHOUSE, SENORM, MACHPD *
C *
C*****************************************************************
C *
C author : Ilona Westermann *
C date : 09.01.1987 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DOUBLE PRECISION NEWERR
INTEGER IWFL, JNDVT, MAXIT, LDA, M, N, INUM, IERR
DIMENSION X(0:M), Y(0:M), W(0:M), PSI(INUM), A(0:LDA,0:N+2),
+ D(0:N), S(0:N), C(0:N), FV(INUM)
EXTERNAL DVT, PHI
IERR = 0
C
C testing the input parameters
C
IF (M .LT. N .OR. LDA .LT. M .OR. MAXIT .LE. 0
+ .OR. EPS .LE. 0.0D0 .OR. M .LE. 0 .OR. N .LE. 0) THEN
IERR = 1
RETURN
ENDIF
C
C determine the machine constant if the Jacobi matrix
C will be computed via central difference quotients
C
IF (JNDVT .NE. 0) THEN
EPSMA = 1.0D0
2 EPSMA = EPSMA * 0.5D0
IF (MACHPD(EPSMA + 1.0D0) .EQ. 1) GOTO 2
EPSMA = EPSMA * 2.0D0
ENDIF
C
C store the weights W in the N+2-nd column of A
C
IF (IWFL .EQ. 0) THEN
DO 5 I=0,M
A(I,N+2) = DSQRT (W(I))
5 CONTINUE
ELSE
DO 6 I=0,M
A(I,N+2) = 1.0D0
6 CONTINUE
ENDIF
C
C form the differences between the Y-values at the nodes
C and the values of the fitting function (considering the
C weights) and store in the N+1-st column of A
C
DO 10 I=0,M
A(I,N+1) = (Y(I) - PHI (C, N, X(I))) * A(I,N+2)
10 CONTINUE
C
C determine the square error
C
SQERR = SENORM (A(0,N+1), M)
L = 1
C
C Newton-iteration:
C -----------------
C form the functional matrix considering the weights
C
100 CALL SNLPRE (X, A(0,N+2), PHI, DVT, JNDVT, C, LDA, M, N,
+ EPSMA, D, A)
C
C determine an improvement S;
C if in this process an error occurs in SUBROUTINE SHOUSE,
C due to the matrix A (numerically) not having maximal rank,
C then we set IERR = 2 and return
C
CALL SHOUSE (A, LDA, M, N, D, S, MARK)
IF (MARK .EQ. 1) THEN
IERR = 2
RETURN
ENDIF
C
C damped Newton step
C
DO 40 K=0,10
SMOOTH = 1.0D0 / 2.0D0 ** K
DO 20 I=0,N
D(I) = C(I) + S(I) * SMOOTH
20 CONTINUE
DO 30 I=0,M
A(I,N+1) = (Y(I) - PHI(D, N, X(I))) * A(I,N+2)
30 CONTINUE
NEWERR = SENORM (A(0,N+1), M)
IF (NEWERR .LE. SQERR) GOTO 50
40 CONTINUE
C
C next, the difference between the old and the new
C approximations is stored in S and thereafter the new
C approximation is stored in C
C
50 DO 60 I=0,N
S(I) = C(I) - D(I)
C(I) = D(I)
60 CONTINUE
C
C check the stopping criteria
C
IF (SENORM(S,N) .GT. EPS * SENORM(C,N)) THEN
IF (L .LT. MAXIT) THEN
SQERR = NEWERR
L = L + 1
GOTO 100
ELSE
IERR = 3
RETURN
ENDIF
ENDIF
C
C if the required precision has been reached, the functional
C values of the computed fitting function are computed at
C the locations specified in PSI
C
DO 70 I=1,INUM
FV(I) = PHI(C, N, PSI(I))
70 CONTINUE
C
C determine least square error
C
SQERR = DSQRT(NEWERR)
MAXIT = L
RETURN
END