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