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