1*DECK DPFITT
2      SUBROUTINE DPFITT (LUN, KPRINT, IPASS)
3C***BEGIN PROLOGUE  DPFITT
4C***PURPOSE  Quick check for DPOLFT, DPCOEF and DP1VLU.
5C***LIBRARY   SLATEC
6C***TYPE      DOUBLE PRECISION (PFITQX-S, DPFITT-D)
7C***AUTHOR  (UNKNOWN)
8C***ROUTINES CALLED  D1MACH, DCMPAR, DP1VLU, DPCOEF, DPOLFT, PASS,
9C                    XERCLR, XGETF, XSETF
10C***COMMON BLOCKS    DCHECK
11C***REVISION HISTORY  (YYMMDD)
12C   ??????  DATE WRITTEN
13C   890911  Removed unnecessary intrinsics.  (WRB)
14C   890921  Realigned order of variables in the COMMON block.
15C           (WRB)
16C   891214  Prologue converted to Version 4.0 format.  (BAB)
17C   900911  Test problem changed and cosmetic changes to code.  (WRB)
18C   901205  Changed usage of D1MACH(3) to D1MACH(4) and modified the
19C           FORMATs.  (RWC)
20C   910708  Minor modifications in use of KPRINT.  (WRB)
21C   891214  Prologue converted to Version 4.0 format.  (BAB)
22C   900911  Test problem changed and cosmetic changes to code.  (WRB)
23C   920214  Code restructured to test for all values of KPRINT and to
24C           provide more PASS/FAIL information.  (WRB)
25C***END PROLOGUE  DPFITT
26C     .. Scalar Arguments ..
27      INTEGER IPASS, KPRINT, LUN
28C     .. Scalars in Common ..
29      DOUBLE PRECISION EPS, RP, SVEPS, TOL
30      INTEGER IERP, IERR, NORD, NORDP
31C     .. Arrays in Common ..
32      DOUBLE PRECISION R(11)
33C     .. Local Scalars ..
34      DOUBLE PRECISION YFIT
35      INTEGER I, ICNT, M, MAXORD
36C     .. Local Arrays ..
37      DOUBLE PRECISION A(97), TC(5), W(11), X(11), Y(11), YP(5)
38      INTEGER ITEST(9)
39C     .. External Functions ..
40      DOUBLE PRECISION D1MACH
41      EXTERNAL D1MACH
42C     .. External Subroutines ..
43      EXTERNAL DCMPAR, PASS, DPCOEF, DPOLFT, DP1VLU
44C     .. Intrinsic Functions ..
45      INTRINSIC ABS, SQRT
46C     .. Common blocks ..
47      COMMON /DCHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR
48C***FIRST EXECUTABLE STATEMENT  DPFITT
49      IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000)
50C
51C     Initialize variables for testing passage or failure of tests
52C
53      DO 100 I = 1,9
54        ITEST(I) = 0
55  100 CONTINUE
56      ICNT = 0
57      TOL = SQRT(D1MACH(4))
58      M = 11
59      DO 110 I = 1,M
60        X(I) = I - 6
61        Y(I) = X(I)**4
62  110 CONTINUE
63C
64C     Test DPOLFT
65C     Input EPS is negative - specified level
66C
67      W(1) = -1.0D0
68      EPS = -0.01D0
69      SVEPS = EPS
70      MAXORD = 8
71      NORDP = 4
72      RP = 625.0D0
73      IERP = 1
74      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
75C
76C     See if test passed
77C
78      CALL DCMPAR (ICNT, ITEST)
79C
80C     Check for suppression of printing.
81C
82      IF (KPRINT .EQ. 0) GO TO 130
83      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 130
84      WRITE (LUN,FMT=9010)
85      WRITE (LUN,FMT=9020)
86      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 120
87      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
88      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
89C
90C     Send message indicating passage or failure of test
91C
92  120 CALL PASS (LUN, ICNT, ITEST(ICNT))
93C
94C     Input EPS is negative - computed level
95C
96  130 EPS = -1.0D0
97      SVEPS = EPS
98      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
99C
100C     See if test passed
101C
102      CALL DCMPAR (ICNT, ITEST)
103C
104C     Check for suppression of printing.
105C
106      IF (KPRINT .EQ. 0) GO TO 150
107      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 150
108      WRITE (LUN,FMT=9050)
109      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 140
110      WRITE (LUN,FMT=9060) MAXORD
111      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
112      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
113C
114C     Send message indicating passage or failure of test
115C
116  140 CALL PASS (LUN, ICNT, ITEST(ICNT))
117C
118C     Input EPS is zero
119C
120  150 W(1) = -1.0D0
121      EPS = 0.0D0
122      SVEPS = EPS
123      NORDP = 5
124      MAXORD = 5
125      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
126C
127C     See if test passed
128C
129      CALL DCMPAR (ICNT, ITEST)
130C
131C     Check for suppression of printing.
132C
133      IF (KPRINT .EQ. 0) GO TO 170
134      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 170
135      WRITE (LUN,FMT=9070)
136      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 160
137      WRITE (LUN,FMT=9060) MAXORD
138      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
139      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
140C
141C     Send message indicating passage or failure of test
142C
143  160 CALL PASS (LUN, ICNT, ITEST(ICNT))
144C
145C     Input EPS is positive
146C
147  170 IERP = 1
148      NORDP = 4
149      EPS = 75.0D0*D1MACH(4)
150      SVEPS = EPS
151      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
152C
153C     See if test passed
154C
155      CALL DCMPAR (ICNT, ITEST)
156C
157C     Check for suppression of printing.
158C
159      IF (KPRINT .EQ. 0) GO TO 190
160      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 190
161      WRITE (LUN,FMT=9080)
162      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 180
163      WRITE (LUN,FMT=9060) MAXORD
164      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
165      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
166C
167C     Send message indicating passage or failure of test
168C
169  180 CALL PASS (LUN, ICNT, ITEST(ICNT))
170C
171C     Improper input
172C
173  190 IERP = 2
174      M = -2
175C
176C     Check for suppression of printing.
177C
178      CALL XGETF (KONTRL)
179      IF (KPRINT .LE. 2) THEN
180         CALL XSETF (0)
181      ELSE
182         CALL XSETF (1)
183      ENDIF
184      CALL XERCLR
185C
186      IF (KPRINT .GE. 3) WRITE (LUN,9090)
187      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
188C
189C     See if test passed
190C
191      ICNT = ICNT + 1
192      IF (IERR .EQ. 2) THEN
193        ITEST(ICNT) = 1
194        IF (KPRINT .GE. 3) THEN
195          WRITE (LUN, 9100) 'PASSED', IERR
196        ENDIF
197      ELSE
198        IF (KPRINT .GE. 2) THEN
199          WRITE (LUN, 9100) 'FAILED', IERR
200        ENDIF
201      ENDIF
202C
203C     Check for suppression of printing.
204C
205      IF (KPRINT .EQ. 0) GO TO 210
206      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 210
207      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 200
208C
209C     Send message indicating passage or failure of test
210C
211  200 CALL PASS (LUN, ICNT, ITEST(ICNT))
212C
213      CALL XERCLR
214      CALL XSETF (KONTRL)
215C
216C     MAXORD too small to meet RMS error
217C
218  210 M = 11
219      W(1) = -1.0D0
220      EPS = 5.0D0*D1MACH(4)
221      SVEPS = EPS
222      RP = 553.0D0
223      MAXORD = 2
224      IERP = 3
225      NORDP = 2
226      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
227C
228C     See if test passed
229C
230      CALL DCMPAR (ICNT, ITEST)
231C
232C     Check for suppression of printing.
233C
234      IF (KPRINT .EQ. 0) GO TO 230
235      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 230
236      WRITE (LUN,FMT=9110)
237      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 220
238      WRITE (LUN,FMT=9060) MAXORD
239      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
240      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
241C
242C     Send message indicating passage or failure of test
243C
244  220 CALL PASS (LUN, ICNT, ITEST(ICNT))
245C
246C     MAXORD too small to meet statistical test
247C
248  230 NORDP = 4
249      IERP = 4
250      RP = 625.0D0
251      EPS = -0.01D0
252      SVEPS = EPS
253      MAXORD = 5
254      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
255C
256C     See if test passed
257C
258      CALL DCMPAR (ICNT, ITEST)
259C
260C     Check for suppression of printing.
261C
262      IF (KPRINT .EQ. 0) GO TO 250
263      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 250
264      WRITE (LUN,FMT=9120)
265      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 240
266      WRITE (LUN,FMT=9060) MAXORD
267      WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP
268      WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR
269C
270C     Send message indicating passage or failure of test
271C
272  240 CALL PASS (LUN, ICNT, ITEST(ICNT))
273C
274C     Test DPCOEF
275C
276  250 MAXORD = 6
277      EPS = 0.0D0
278      SVEPS = EPS
279      Y(6) = 1.0D0
280      DO 260 I = 1,M
281        W(I) = 1.0D0/(Y(I)**2)
282  260 CONTINUE
283      Y(6) = 0.0D0
284      CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A)
285      CALL DPCOEF (4, 5.0D0, TC, A)
286C
287C     See if test passed
288C
289      ICNT = ICNT + 1
290      IF (ABS(R(11)-TC(1)) .LE. TOL) ITEST(ICNT) = 1
291C
292C     Check for suppression of printing
293C
294      IF (KPRINT .EQ. 0) GO TO 280
295      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 280
296      WRITE (LUN,FMT=9130)
297      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 270
298      WRITE (LUN,FMT=9140) R(11),TC(1)
299C
300C     Send message indicating passage or failure of test
301C
302  270 CALL PASS (LUN, ICNT, ITEST(ICNT))
303C
304C     Test DP1VLU
305C     Normal call
306C
307  280 CALL DP1VLU (6, 0, X(8), YFIT, YP, A)
308C
309C     See if test passed
310C
311      ICNT = ICNT + 1
312      IF (ABS(R(8)-YFIT) .LE. TOL) ITEST(ICNT) = 1
313C
314C     Check for suppression of printing
315C
316      IF (KPRINT .EQ. 0) GO TO 300
317      IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 300
318      WRITE (LUN,FMT=9150)
319      WRITE (LUN,FMT=9160)
320      IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 290
321      WRITE (LUN,FMT=9170) X(8),R(8),YFIT
322C
323C     Send message indicating passage or failure of test
324C
325  290 CALL PASS (LUN, ICNT, ITEST(ICNT))
326C
327C     Check to see if all tests passed
328C
329  300 IPASS = 1
330      DO 310 I = 1,9
331        IPASS = IPASS*ITEST(I)
332  310 CONTINUE
333C
334      IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9180)
335      IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9190)
336      RETURN
337C
338 9000 FORMAT ('1' / ' Test DPOLFT, DPCOEF and DP1VLU')
339 9010 FORMAT (' Exercise DPOLFT')
340 9020 FORMAT (' Input EPS is negative - specified significance level')
341 9030 FORMAT (' Input EPS =  ', E15.8, '   correct order =  ', I3,
342     +        '   R(1) = ', E15.8, '   IERR = ', I1)
343 9040 FORMAT (' Output EPS = ', E15.8, '   computed order = ', I3,
344     +        '   R(1) = ', E15.8, '   IERR = ', I1)
345 9050 FORMAT (/ ' Input EPS is negative - computed significance level')
346 9060 FORMAT (' Maximum order = ', I2)
347 9070 FORMAT (/ ' Input EPS is zero')
348 9080 FORMAT (/ ' Input EPS is positive')
349 9090 FORMAT (/ ' Invalid input')
350 9100 FORMAT (' DPOLFT incorrect argument test ', A /
351     +        ' IERR should be 2.  It is ', I4)
352 9110 FORMAT (/ ' Cannot meet RMS error requirement')
353 9120 FORMAT (/ ' Cannot satisfy statistical test')
354 9130 FORMAT (/ ' Exercise DPCOEF')
355 9140 FORMAT (/ ' For C=1.0, correct coefficient = ', E15.8,
356     +        '   computed = ', E15.8)
357 9150 FORMAT (/ ' Exercise DP1VLU')
358 9160 FORMAT (' Normal execution')
359 9170 FORMAT (' For X = ', F5.2, '   correct P(X) = ', E15.8,
360     +        '    P(X) from DP1VLU = ', E15.8)
361 9180 FORMAT (/' ***************DPOLFT PASSED ALL TESTS***************')
362 9190 FORMAT (/' ***************DPOLFT FAILED SOME TESTS**************')
363      END
364