1*DECK QCDRF
2      SUBROUTINE QCDRF (LUN, KPRINT, IPASS)
3C***BEGIN PROLOGUE  QCDRF
4C***PURPOSE  Quick check for DRF.
5C***LIBRARY   SLATEC
6C***KEYWORDS  QUICK CHECK
7C***AUTHOR  Pexton, R. L., (LLNL)
8C***DESCRIPTION
9C
10C            QUICK TEST FOR CARLSON INTEGRAL DRF
11C
12C***ROUTINES CALLED  D1MACH, DRF, 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   930214  Added more digits to ALEM.  (WRB)
19C***END PROLOGUE  QCDRF
20      INTEGER KPRINT, IPASS, CONTRL, KONTRL, LUN, IER
21      INTEGER IPASS1, IPASS2, IPASS3, IPASS4, NUMXER
22      DOUBLE PRECISION ALEM, TRF, DRF, DIF, D1MACH
23      EXTERNAL D1MACH, DRF, NUMXER, XERCLR, XGETF, XSETF
24C***FIRST EXECUTABLE STATEMENT  QCDRF
25      CALL XERCLR
26      CALL XGETF(CONTRL)
27      IF ( KPRINT .GE. 3 ) THEN
28         KONTRL = +1
29      ELSE
30         KONTRL = 0
31      ENDIF
32      CALL XSETF(KONTRL)
33C
34C  FORCE ERROR 1
35C
36      IF ( KPRINT .GE. 3 ) WRITE (LUN,101)
37  101 FORMAT(' DRF - FORCE ERROR 1 TO OCCUR')
38      TRF = DRF(-1.0D0,-1.0D0,-1.0D0,IER)
39      IER = NUMXER(IER)
40      IF ( IER .EQ. 1 ) THEN
41         IPASS1 = 1
42      ELSE
43         IPASS1 = 0
44      ENDIF
45      CALL XERCLR
46C
47C  FORCE ERROR 2
48C
49      IF ( KPRINT .GE. 3 ) WRITE (LUN,102)
50  102 FORMAT(' DRF - FORCE ERROR 2 TO OCCUR')
51      TRF = DRF(D1MACH(1),D1MACH(1),D1MACH(1),IER)
52      IER = NUMXER(IER)
53      IF ( IER .EQ. 2 ) THEN
54         IPASS2 = 1
55      ELSE
56         IPASS2 = 0
57      ENDIF
58      CALL XERCLR
59C
60C  FORCE ERROR 3
61C
62      IF ( KPRINT .GE. 3 ) WRITE (LUN,103)
63  103 FORMAT(' DRF - FORCE ERROR 3 TO OCCUR')
64      TRF = DRF(D1MACH(2),D1MACH(2),D1MACH(2),IER)
65      IER = NUMXER(IER)
66      IF ( IER .EQ. 3 ) THEN
67         IPASS3 = 1
68      ELSE
69         IPASS3 = 0
70      ENDIF
71      CALL XERCLR
72C
73C  ARGUMENTS IN RANGE
74C  ALEM=LEMNISCATE CONSTANT A
75C
76      ALEM = 1.3110287771460599052324197949455597068D0
77      TRF  = DRF(0.0D0,1.0D0,2.0D0,IER)
78      CALL XERCLR
79      DIF  = TRF - ALEM
80      IF ( (ABS(DIF/ALEM).LT.1000.0D0*D1MACH(4)).AND.(IER.EQ.0) ) THEN
81         IPASS4 = 1
82      ELSE
83         IPASS4 = 0
84      ENDIF
85      IPASS = MIN(IPASS1,IPASS2,IPASS3,IPASS4)
86      IF ( KPRINT .EQ. 0 ) THEN
87         GO TO 999
88      ELSEIF ( KPRINT .EQ. 1 ) THEN
89         IF ( IPASS .EQ. 1 ) THEN
90            GO TO 999
91         ELSE
92            WRITE (LUN,104)
93  104       FORMAT(' DRF - FAILED')
94            GO TO 999
95         ENDIF
96      ELSE
97         IF ( IPASS .EQ. 1 ) THEN
98            WRITE (LUN,105)
99  105       FORMAT(' DRF - PASSED')
100            GO TO 999
101         ELSE
102            WRITE (LUN,104)
103            IF ( IPASS4 .EQ. 0 ) WRITE (LUN,106) ALEM, TRF, DIF
104  106       FORMAT(' CORRECT ANSWER =', 1PD20.14 /
105     *             'COMPUTED ANSWER =',   D20.14 /
106     *             '     DIFFERENCE =',   D20.14 )
107            GO TO 999
108         ENDIF
109      ENDIF
110  999 CONTINUE
111      CALL XSETF(CONTRL)
112      RETURN
113      END
114