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