1*DECK QCDRC
2      SUBROUTINE QCDRC (LUN, KPRINT, IPASS)
3C***BEGIN PROLOGUE  QCDRC
4C***PURPOSE  Quick check for DRC.
5C***LIBRARY   SLATEC
6C***KEYWORDS  QUICK CHECK
7C***AUTHOR  Pexton, R. L., (LLNL)
8C***DESCRIPTION
9C
10C            QUICK TEST FOR CARLSON INTEGRAL DRC
11C
12C***ROUTINES CALLED  D1MACH, DRC, NUMXER, XERCLR, XGETF, XSETF
13C***REVISION HISTORY  (YYMMDD)
14C   790801  DATE WRITTEN
15C   890618  REVISION DATE from Version 3.2
16C   891214  Prologue converted to Version 4.0 format.  (BAB)
17C   910708  Minor modifications in use of KPRINT.  (WRB)
18C***END PROLOGUE  QCDRC
19      INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER
20      INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER
21      DOUBLE PRECISION PI, TRC, DRC, DIF, D1MACH
22      EXTERNAL D1MACH, DRC, NUMXER, XERCLR, XGETF, XSETF
23C***FIRST EXECUTABLE STATEMENT  QCDRC
24      CALL XERCLR
25      CALL XGETF(CONTRL)
26      IF ( KPRINT .GE. 3 ) THEN
27         KONTRL = +1
28      ELSE
29         KONTRL = 0
30      ENDIF
31      CALL XSETF(KONTRL)
32C
33C  FORCE ERROR 1
34C
35      IF ( KPRINT .GE. 3 ) WRITE (LUN,101)
36  101 FORMAT(' DRC - FORCE ERROR 1 TO OCCUR')
37      TRC = DRC(-1.0D0,-1.0D0,IER)
38      IER = NUMXER(IER)
39      IF ( IER .EQ. 1 ) THEN
40         IPASS1 = 1
41      ELSE
42         IPASS1 = 0
43      ENDIF
44      CALL XERCLR
45C
46C  FORCE ERROR 2
47C
48      IF ( KPRINT .GE. 3 ) WRITE (LUN,102)
49  102 FORMAT(' DRC - FORCE ERROR 2 TO OCCUR')
50      TRC = DRC(D1MACH(1),D1MACH(1),IER)
51      IER = NUMXER(IER)
52      IF ( IER .EQ. 2 ) THEN
53         IPASS2 = 1
54      ELSE
55         IPASS2 = 0
56      ENDIF
57      CALL XERCLR
58C
59C  FORCE ERROR 3
60C
61      IF ( KPRINT .GE. 3 ) WRITE (LUN,103)
62  103 FORMAT(' DRC - FORCE ERROR 3 TO OCCUR')
63      TRC = DRC(D1MACH(2),D1MACH(2),IER)
64      IER = NUMXER(IER)
65      IF ( IER .EQ. 3 ) THEN
66         IPASS3 = 1
67      ELSE
68         IPASS3 = 0
69      ENDIF
70      CALL XERCLR
71C
72C  ARGUMENTS IN RANGE
73C
74      PI  = 3.141592653589793238462643383279D0
75      TRC = DRC(0.0D0,0.25D0,IER)
76      CALL XERCLR
77      DIF = TRC - PI
78      IF ( (ABS(DIF/PI).LT.1000.0D0*D1MACH(4)) .AND. (IER.EQ.0) ) THEN
79         IPASS4 = 1
80      ELSE
81         IPASS4 = 0
82      ENDIF
83      IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4)
84      IF ( KPRINT .LE. 0 ) THEN
85         GO TO 999
86      ELSEIF ( KPRINT .EQ. 1 ) THEN
87         IF ( IPASS .EQ. 1 ) THEN
88            GO TO 999
89         ELSE
90            WRITE (LUN,104)
91  104       FORMAT(' DRC - FAILED')
92            GO TO 999
93         ENDIF
94      ELSE
95         IF ( IPASS .EQ. 1 ) THEN
96            WRITE (LUN,105)
97  105       FORMAT(' DRC - PASSED')
98            GO TO 999
99         ELSE
100            WRITE (LUN,104)
101            IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) PI, TRC, DIF
102  106       FORMAT(' CORRECT ANSWER =', 1PD20.14 /
103     *             'COMPUTED ANSWER =',   D20.14 /
104     *             '     DIFFERENCE =',   D20.14 )
105            GO TO 999
106         ENDIF
107      ENDIF
108  999 CONTINUE
109      CALL XSETF(CONTRL)
110      RETURN
111      END
112