1*SETAF
2      SUBROUTINE SETAF
3     +   (FUN,N,NP,M,XPLUSD,LDXPD,BETA,ETA,NETA,EPSMAC,
4     +   NROW,PARTMP,PVTEMP,IFLAG)
5C***BEGIN PROLOGUE  SETAF
6C***REFER TO  SODR,SODRC
7C***ROUTINES CALLED  (NONE)
8C***DATE WRITTEN   860529   (YYMMDD)
9C***REVISION DATE  870204   (YYMMDD)
10C***CATEGORY NO.  G2E,I1B1
11C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
12C             NONLINEAR LEAST SQUARES,
13C             ERRORS IN VARIABLES
14C***AUTHOR  BOGGS, PAUL T.
15C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
16C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
17C           BYRD, RICHARD H.
18C             DEPARTMENT OF COMPUTER SCIENCE
19C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
20C           DONALDSON, JANET R.
21C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
22C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
23C           SCHNABEL, ROBERT B.
24C             DEPARTMENT OF COMPUTER SCIENCE
25C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
26C             AND
27C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
28C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
29C***PURPOSE  COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS
30C            (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE ETAFUN)
31C***END PROLOGUE  SETAF
32C
33C  EXTERNALS
34C
35      EXTERNAL FUN
36C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
37C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
38C        ARGUMENT FUN.)
39C
40C  VARIABLE DECLARATIONS (ALPHABETICALLY)
41C
42      REAL A
43C        PARAMETERS OF THE FIT.
44      REAL B
45C        PARAMETERS OF THE FIT.
46      REAL BETA(NP)
47C        THE FUNCTION PARAMETERS.
48C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
49      REAL EPSMAC
50C        THE VALUE OF MACHINE PRECISION.
51      REAL ETA
52C        THE NOISE IN THE MODEL RESULTS.
53      REAL FAC
54C        A FACTOR USED IN THE COMPUTATIONS.
55      INTEGER I
56C        AN INDEXING VARIABLE.
57      INTEGER IFLAG
58C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
59C        USER WISHES THE COMPUTATIONS STOPPED.
60      REAL J
61C        THE VALUE FLOAT(I-3).
62      INTEGER K
63C        AN INDEX VARIABLE.
64      INTEGER LDXPD
65C        THE LEADING DIMENSION OF ARRAY XPLUSD.
66      INTEGER M
67C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
68C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
69      INTEGER N
70C        THE NUMBER OF OBSERVATIONS.
71C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
72      INTEGER NETA
73C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS.
74      INTEGER NP
75C        THE NUMBER OF FUNCTION PARAMETERS.
76C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
77      INTEGER NROW
78C        THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED.
79      REAL ONE
80C        THE VALUE 1.0E0.
81      REAL P1
82C        THE VALUE 0.1E0.
83      REAL P2
84C        THE VALUE 0.2E0.
85      REAL PARTMP(NP)
86C        MODIFIED MODEL PARAMETERS
87      REAL PVTEMP(N)
88C        PREDICTED VALUES
89      REAL RSS(5)
90C        THE RESIDUAL SUM OF SQUARES FOR EACH VALUE OF J.
91      REAL RSSSM
92C        THE SUM OF THE RESIDUAL SUM OF SQUARES FOR EACH SET OF
93C        PARAMETER VALUES.
94      REAL RSSSMJ
95C        THE SUM OF THE RESIDUAL SUM OF SQUARES TIMES J FOR EACH
96C        SET OF PARAMETER VALUES.
97      REAL SQRTMP
98C        THE SQUARE ROOT OF MACHINE PRECISION (EPSMAC).
99      REAL XPLUSD(LDXPD,M)
100C        THE ARRAY X + DELTA.
101      REAL ZERO
102C        THE VALUE 0.0E0.
103C
104C
105      DATA ZERO,P1,P2,ONE/0.0E0,0.1E0,0.2E0,1.0E0/
106C
107C
108C***FIRST EXECUTABLE STATEMENT  SETAF
109C
110C
111      SQRTMP = SQRT(EPSMAC)
112      RSSSM = ZERO
113      RSSSMJ = ZERO
114      DO 20 I=1,5
115         J = I-3
116         DO 10 K=1,NP
117            PARTMP(K) = BETA(K)*(ONE+J*SQRTMP)
118   10    CONTINUE
119         IFLAG = 0
120         CALL FUN(N,NP,M,PARTMP,XPLUSD,LDXPD,PVTEMP,IFLAG)
121         IF (IFLAG.LT.0) THEN
122            RETURN
123         END IF
124C
125         RSS(I) = PVTEMP(NROW)
126C
127         RSSSM = RSSSM + RSS(I)
128         RSSSMJ = RSSSMJ + J*RSS(I)
129   20 CONTINUE
130      A = P2*RSSSM
131      B = P1*RSSSMJ
132      IF (RSS(3).NE.ZERO) THEN
133         FAC = ONE/ABS(RSS(3))
134      ELSE
135         FAC = ONE
136      END IF
137      DO 30 I=1,5
138         J = I-3
139         RSS(I) = ABS((RSS(I)-(A+J*B))*FAC)
140   30 CONTINUE
141      ETA = MAX(RSS(1),RSS(2),RSS(3),RSS(4),RSS(5),EPSMAC)
142      NETA = INT(-LOG10(ETA))
143C
144      RETURN
145      END
146