*DECK QXRKF SUBROUTINE QXRKF (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE QXRKF C***PURPOSE Test the DEPAC routine DERKF. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (QXRKF-S, QXDRKF-D) C***KEYWORDS QUICK CHECK C***AUTHOR Chow, Jeff, (LANL) C***DESCRIPTION C C *Usage: C C INTEGER LUN, KPRINT, IPASS C C CALL QXRKF (LUN, KPRINT, IPASS) C C *Arguments: C C LUN :IN is the unit number to which output is to be written. C C KPRINT:IN controls the amount of output, as specified in the C SLATEC Guidelines. C C IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. C IPASS=0 indicates one or more tests failed. C C *Description: C C DERKF is tested by solving the equations of motion of a body C moving in a plane about a spherical earth, namely C (D/DT)(D/DT)X = -G*X/R**3 C (D/DT)(D/DT)Y = -G*Y/R**3 C where G = 1, R = SQRT(X**2 + Y**2) and C X(0) = 1 C (D/DT)X(0) = 0 C Y(0) = 0 C (D/DT)Y(0) = 1. C C***ROUTINES CALLED DERKF, FDEQC, R1MACH C***REVISION HISTORY (YYMMDD) C 810801 DATE WRITTEN C 890618 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900415 Code extensively revised. (WRB) C***END PROLOGUE QXRKF C C Declare arguments. C INTEGER LUN, KPRINT, IPASS C C Declare local variables. C INTEGER IDID, INFO(15), IPAR, IWORK(34), N, LIW, LRW REAL ABSERR, R, R1MACH, RELERR, RELTOL, RPAR, RWORK(61), T, TOUT, + U(4) EXTERNAL FDEQC C***FIRST EXECUTABLE STATEMENT QXRKF IF (KPRINT .GE. 2) WRITE (LUN, 9000) C C Initialize problem. C N = 4 LRW = 61 LIW = 34 T = 0.0E0 TOUT = 8.0E0*ATAN(1.0E0) U(1) = 1.0E0 U(2) = 0.0E0 U(3) = 0.0E0 U(4) = 1.0E0 IPASS = 1 RELTOL = SQRT(R1MACH(4)) RELERR = 0.1E0*RELTOL ABSERR = RELERR**1.5E0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9010) RELERR, ABSERR, T, (1.0E0) C 100 CALL DERKF (FDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, + IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR) R = SQRT(U(1)*U(1)+U(2)*U(2)) IF (ABS(R-1.0E0) .GT. RELTOL) IPASS = 0 IF (KPRINT .GT. 2) WRITE (LUN, 9020) T, R INFO(1) = 1 IF (IDID .EQ. 1) GO TO 100 C C Finish up. C IF (IDID .LT. 1) IPASS = 0 IF (KPRINT.GT.1 .AND. IDID.LT.1) WRITE (LUN, 9030) IDID IF (KPRINT.GT.1 .AND. IPASS.EQ.1) WRITE (LUN, 9040) IF (KPRINT.GE.1 .AND. IPASS.EQ.0) WRITE (LUN, 9050) RETURN C C FORMATs. C 9000 FORMAT ('1'/' ------------ DERKF QUICK CHECK OUTPUT', + ' ------------') 9010 FORMAT (/ ' RELERR = ', E16.8, ' ABSERR =', E16.8 / + 12X, 'T', 19X, 'R' / 2E20.8) 9020 FORMAT (2E20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DERKF. IDID = ', I3) 9040 FORMAT (/ ' ------------ DERKF PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DERKF FAILED TESTS ************') END