1*DECK DQG8TS
2      SUBROUTINE DQG8TS (LUN, KPRINT, IPASS)
3C***BEGIN PROLOGUE  DQG8TS
4C***PURPOSE  Quick check for DGAUS8.
5C***LIBRARY   SLATEC
6C***TYPE      DOUBLE PRECISION (QG8TST-S, DQG8TS-D)
7C***AUTHOR  (UNKNOWN)
8C***ROUTINES CALLED  D1MACH, DFQD1, DFQD2, DGAUS8, XGETF, XSETF
9C***REVISION HISTORY  (YYMMDD)
10C   ??????  DATE WRITTEN
11C   891214  Prologue converted to Version 4.0 format.  (BAB)
12C   901205  Changed usage of D1MACH(3) to D1MACH(4).  (RWC)
13C   910501  Added PURPOSE and TYPE records.  (WRB)
14C   910708  Minor modifications in use of KPRINT.  (WRB)
15C   920213  Code restructured to test DGAUS8 for all values of KPRINT,
16C           second accuracy test added and testing of error returns
17C           revised.  (WRB)
18C***END PROLOGUE  DQG8TS
19C     .. Scalar Arguments ..
20      INTEGER IPASS, KPRINT, LUN
21C     .. Local Scalars ..
22      INTEGER IERR, KONTRL
23      DOUBLE PRECISION A, ANS, B, COR, ERR, REQ, TOL
24      LOGICAL FATAL
25C     .. External Functions ..
26      DOUBLE PRECISION D1MACH, DFQD1, DFQD2
27      EXTERNAL D1MACH, DFQD1, DFQD2
28C     .. External Subroutines ..
29      EXTERNAL DGAUS8, XGETF, XSETF
30C     .. Intrinsic Functions ..
31      INTRINSIC ABS, ATAN, EXP, SQRT
32C***FIRST EXECUTABLE STATEMENT  DQG8TS
33      IF (KPRINT .GE. 2) WRITE (LUN,FMT=9000)
34C
35C     Initialize variables for testing.
36C
37      TOL = SQRT(D1MACH(4))
38      IPASS = 1
39C
40C     First accuracy test.
41C
42      A = 1.0D0
43      B = 4.0D0
44      ERR = TOL/100.0D0
45      CALL DGAUS8 (DFQD1, A, B, ERR, ANS, IERR)
46      COR = 2.0D0
47      IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN
48        IF (KPRINT .GE. 3)
49     +    WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR
50      ELSE
51        IPASS = 0
52        IF (KPRINT .GE. 2)
53     +    WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR
54      ENDIF
55C
56C     Second accuracy test.
57C
58      A = 0.0D0
59      B = 4.0D0*ATAN(1.0D0)
60      ERR = TOL/100.0D0
61      CALL DGAUS8 (DFQD2, A, B, ERR, ANS, IERR)
62      COR = (EXP(B)-1.0D0)/101.0D0
63      IF (ABS(ANS-COR).LE.TOL .AND. IERR.EQ.1) THEN
64        IF (KPRINT .GE. 3)
65     +    WRITE (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR
66      ELSE
67        IPASS = 0
68        IF (KPRINT .GE. 2)
69     +    WRITE (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR
70      ENDIF
71C
72C     Test error returns.
73C
74      CALL XGETF (KONTRL)
75      IF (KPRINT .LE. 2) THEN
76         CALL XSETF (0)
77      ELSE
78         CALL XSETF (1)
79      ENDIF
80      FATAL = .FALSE.
81C
82      IF (KPRINT .GE. 3) WRITE (LUN,FMT=9030)
83C
84C     Test with a discontinuous integrand and a tight error tolerance.
85C
86      A = 0.0D0
87      B = 1.0D0
88      COR = 2.0D0
89      ERR = 100.0D0*D1MACH(4)
90      REQ = ERR
91      CALL DGAUS8 (DFQD1, A, B, ERR, ANS, IERR)
92C
93C     See if test passed.
94C
95      IF (IERR .EQ. 2) THEN
96        IF (KPRINT .GE. 3)
97     +    WRITE (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR
98      ELSE
99        IF (KPRINT .GE. 2)
100     +    WRITE (LUN,FMT=9040) 'FAILED', REQ, ANS, IERR, ERR, COR
101        IPASS = 0
102        FATAL = .TRUE.
103      ENDIF
104C
105C     Test DGAUS8 with A and B nearly equal.
106C
107      A = 2.0D0
108      B = A*(1.0D0+D1MACH(4))
109      COR = 0.0D0
110      ERR = TOL
111C
112      CALL DGAUS8 (DFQD1, A, B, ERR, ANS, IERR)
113C
114C     Check to see if test passed.
115C
116      IF (IERR.EQ.-1 .AND. ANS.EQ.0.0D0) THEN
117        IF (KPRINT .GE. 3) WRITE (LUN,9050) 'PASSED'
118      ELSE
119        IPASS = 0
120        FATAL = .TRUE.
121        IF (KPRINT .GE. 2) WRITE (LUN,9050) 'FAILED'
122      ENDIF
123C
124      CALL XSETF (KONTRL)
125      IF (FATAL) THEN
126         IF (KPRINT .GE. 2) THEN
127            WRITE (LUN, 9060)
128         ENDIF
129      ELSE
130         IF (KPRINT .GE. 3) THEN
131            WRITE (LUN, 9070)
132         ENDIF
133      ENDIF
134C
135      IF (IPASS.EQ.1 .AND. KPRINT.GE.3) WRITE (LUN,FMT=9080)
136      IF (IPASS.EQ.0 .AND. KPRINT.GE.2) WRITE (LUN,FMT=9090)
137      RETURN
138C
139 9000 FORMAT ('1' / ' DGAUS8 Quick Check')
140 9010 FORMAT (/ ' Accuracy test of DGAUS8 ', A /
141     +        ' A = ', F10.5, '   B = ', F10.5 /
142     +        ' Computed result = ', D14.7, '   Exact result = ',
143     +        D14.7 /
144     +        ' Tolerance = ', D14.7, '   IERR = ', I2 /)
145 9030 FORMAT (/ ' Test error returns' /
146     +        ' 2 error messages expected' /)
147 9040 FORMAT (' Test of DGAUS8 ', A /
148     +        ' REQ =', D10.2, 5X, 'ANS =', D20.13, 5X, 'IERR =', I2,
149     +        5X, 'should be 2' /
150     +        ' ERR =', D10.2, ' CORRECT =' ,D20.13 /)
151 9050 FORMAT (' Test of A and B nearly equal ', A)
152 9060 FORMAT (/ ' At least one incorrect argument test FAILED')
153 9070 FORMAT (/ ' All incorrect argument tests PASSED')
154 9080 FORMAT (/,' ***************DGAUS8 PASSED ALL TESTS**************')
155 9090 FORMAT (/,' ***************DGAUS8 FAILED SOME TESTS*************')
156      END
157