*DECK DPFITT SUBROUTINE DPFITT (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DPFITT C***PURPOSE Quick check for DPOLFT, DPCOEF and DP1VLU. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (PFITQX-S, DPFITT-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED D1MACH, DCMPAR, DP1VLU, DPCOEF, DPOLFT, PASS, C XERCLR, XGETF, XSETF C***COMMON BLOCKS DCHECK C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890921 Realigned order of variables in the COMMON block. C (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900911 Test problem changed and cosmetic changes to code. (WRB) C 901205 Changed usage of D1MACH(3) to D1MACH(4) and modified the C FORMATs. (RWC) C 910708 Minor modifications in use of KPRINT. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900911 Test problem changed and cosmetic changes to code. (WRB) C 920214 Code restructured to test for all values of KPRINT and to C provide more PASS/FAIL information. (WRB) C***END PROLOGUE DPFITT C .. Scalar Arguments .. INTEGER IPASS, KPRINT, LUN C .. Scalars in Common .. DOUBLE PRECISION EPS, RP, SVEPS, TOL INTEGER IERP, IERR, NORD, NORDP C .. Arrays in Common .. DOUBLE PRECISION R(11) C .. Local Scalars .. DOUBLE PRECISION YFIT INTEGER I, ICNT, M, MAXORD C .. Local Arrays .. DOUBLE PRECISION A(97), TC(5), W(11), X(11), Y(11), YP(5) INTEGER ITEST(9) C .. External Functions .. DOUBLE PRECISION D1MACH EXTERNAL D1MACH C .. External Subroutines .. EXTERNAL DCMPAR, PASS, DPCOEF, DPOLFT, DP1VLU C .. Intrinsic Functions .. INTRINSIC ABS, SQRT C .. Common blocks .. COMMON /DCHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR C***FIRST EXECUTABLE STATEMENT DPFITT IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000) C C Initialize variables for testing passage or failure of tests C DO 100 I = 1,9 ITEST(I) = 0 100 CONTINUE ICNT = 0 TOL = SQRT(D1MACH(4)) M = 11 DO 110 I = 1,M X(I) = I - 6 Y(I) = X(I)**4 110 CONTINUE C C Test DPOLFT C Input EPS is negative - specified level C W(1) = -1.0D0 EPS = -0.01D0 SVEPS = EPS MAXORD = 8 NORDP = 4 RP = 625.0D0 IERP = 1 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 130 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 130 WRITE (LUN,FMT=9010) WRITE (LUN,FMT=9020) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 120 WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 120 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Input EPS is negative - computed level C 130 EPS = -1.0D0 SVEPS = EPS CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 150 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 150 WRITE (LUN,FMT=9050) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 140 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 140 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Input EPS is zero C 150 W(1) = -1.0D0 EPS = 0.0D0 SVEPS = EPS NORDP = 5 MAXORD = 5 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 170 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 170 WRITE (LUN,FMT=9070) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 160 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 160 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Input EPS is positive C 170 IERP = 1 NORDP = 4 EPS = 75.0D0*D1MACH(4) SVEPS = EPS CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 190 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 190 WRITE (LUN,FMT=9080) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 180 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 180 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Improper input C 190 IERP = 2 M = -2 C C Check for suppression of printing. C CALL XGETF (KONTRL) IF (KPRINT .LE. 2) THEN CALL XSETF (0) ELSE CALL XSETF (1) ENDIF CALL XERCLR C IF (KPRINT .GE. 3) WRITE (LUN,9090) CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C ICNT = ICNT + 1 IF (IERR .EQ. 2) THEN ITEST(ICNT) = 1 IF (KPRINT .GE. 3) THEN WRITE (LUN, 9100) 'PASSED', IERR ENDIF ELSE IF (KPRINT .GE. 2) THEN WRITE (LUN, 9100) 'FAILED', IERR ENDIF ENDIF C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 210 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 210 IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 200 C C Send message indicating passage or failure of test C 200 CALL PASS (LUN, ICNT, ITEST(ICNT)) C CALL XERCLR CALL XSETF (KONTRL) C C MAXORD too small to meet RMS error C 210 M = 11 W(1) = -1.0D0 EPS = 5.0D0*D1MACH(4) SVEPS = EPS RP = 553.0D0 MAXORD = 2 IERP = 3 NORDP = 2 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 230 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 230 WRITE (LUN,FMT=9110) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 220 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 220 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C MAXORD too small to meet statistical test C 230 NORDP = 4 IERP = 4 RP = 625.0D0 EPS = -0.01D0 SVEPS = EPS MAXORD = 5 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) C C See if test passed C CALL DCMPAR (ICNT, ITEST) C C Check for suppression of printing. C IF (KPRINT .EQ. 0) GO TO 250 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 250 WRITE (LUN,FMT=9120) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 240 WRITE (LUN,FMT=9060) MAXORD WRITE (LUN,FMT=9030) SVEPS,NORDP,RP,IERP WRITE (LUN,FMT=9040) EPS,NORD,R(11),IERR C C Send message indicating passage or failure of test C 240 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Test DPCOEF C 250 MAXORD = 6 EPS = 0.0D0 SVEPS = EPS Y(6) = 1.0D0 DO 260 I = 1,M W(I) = 1.0D0/(Y(I)**2) 260 CONTINUE Y(6) = 0.0D0 CALL DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) CALL DPCOEF (4, 5.0D0, TC, A) C C See if test passed C ICNT = ICNT + 1 IF (ABS(R(11)-TC(1)) .LE. TOL) ITEST(ICNT) = 1 C C Check for suppression of printing C IF (KPRINT .EQ. 0) GO TO 280 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 280 WRITE (LUN,FMT=9130) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 270 WRITE (LUN,FMT=9140) R(11),TC(1) C C Send message indicating passage or failure of test C 270 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Test DP1VLU C Normal call C 280 CALL DP1VLU (6, 0, X(8), YFIT, YP, A) C C See if test passed C ICNT = ICNT + 1 IF (ABS(R(8)-YFIT) .LE. TOL) ITEST(ICNT) = 1 C C Check for suppression of printing C IF (KPRINT .EQ. 0) GO TO 300 IF (KPRINT.EQ.1 .AND. ITEST(ICNT).EQ.1) GO TO 300 WRITE (LUN,FMT=9150) WRITE (LUN,FMT=9160) IF (KPRINT.LE.2 .AND. ITEST(ICNT).EQ.1) GO TO 290 WRITE (LUN,FMT=9170) X(8),R(8),YFIT C C Send message indicating passage or failure of test C 290 CALL PASS (LUN, ICNT, ITEST(ICNT)) C C Check to see if all tests passed C 300 IPASS = 1 DO 310 I = 1,9 IPASS = IPASS*ITEST(I) 310 CONTINUE C IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9180) IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9190) RETURN C 9000 FORMAT ('1' / ' Test DPOLFT, DPCOEF and DP1VLU') 9010 FORMAT (' Exercise DPOLFT') 9020 FORMAT (' Input EPS is negative - specified significance level') 9030 FORMAT (' Input EPS = ', E15.8, ' correct order = ', I3, + ' R(1) = ', E15.8, ' IERR = ', I1) 9040 FORMAT (' Output EPS = ', E15.8, ' computed order = ', I3, + ' R(1) = ', E15.8, ' IERR = ', I1) 9050 FORMAT (/ ' Input EPS is negative - computed significance level') 9060 FORMAT (' Maximum order = ', I2) 9070 FORMAT (/ ' Input EPS is zero') 9080 FORMAT (/ ' Input EPS is positive') 9090 FORMAT (/ ' Invalid input') 9100 FORMAT (' DPOLFT incorrect argument test ', A / + ' IERR should be 2. It is ', I4) 9110 FORMAT (/ ' Cannot meet RMS error requirement') 9120 FORMAT (/ ' Cannot satisfy statistical test') 9130 FORMAT (/ ' Exercise DPCOEF') 9140 FORMAT (/ ' For C=1.0, correct coefficient = ', E15.8, + ' computed = ', E15.8) 9150 FORMAT (/ ' Exercise DP1VLU') 9160 FORMAT (' Normal execution') 9170 FORMAT (' For X = ', F5.2, ' correct P(X) = ', E15.8, + ' P(X) from DP1VLU = ', E15.8) 9180 FORMAT (/' ***************DPOLFT PASSED ALL TESTS***************') 9190 FORMAT (/' ***************DPOLFT FAILED SOME TESTS**************') END