C     ALGORITHM 639 COLLECTED ALGORITHMS FROM ACM.
C     ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.12, NO. 1,
C     MAR., 1986, P. 24.
C      PROGRAM DRIVE1
C      FILE CONTAINS MAIN, EXACT, HFUN, GPER, G5AND9, RJBESL AND DGAMMA.
C      THE FINAL TWO ARE HIGH QUALITY SOFTWARE WRITTEN BY W.J.CODY.
C      THE FIRST FOUR ARE A MEDIUM QUALITY DRIVER AND SUBROUTINES
C      TO RUN THE SUBMITTED SUBROUTINE OSCINT.
C      THESE FOUR SHARE A LABELLED COMMON LIST.
C
C
C         THIS PROGRAM TESTS THE SUBROUTINE, OSCINT, FOR FOUR GIVEN
C     FUNCTIONS (SPECIFIED BY NUMFUN). THE RESULTS ARE COMPARED TO
C     THE EXACT INTEGRALS FOUND USING ANALYTIC FORMULAS IN THE
C     SUBROUTINE EXACT.
C
C      CENTRAL LOOP IS ON NUMFUN = 1,4. THIS IS INSIDE A HAND CODED
C      LOOP, NTIME  = 1,4. WHEN  NTIME = 1, THE RESULTS ONLY ARE
C      PRINTED. WHEN NTIME = 2, SOME OF THE ABSCISSAS AND FUNCTION
C      VALUES ARE PRINTED, ALONG WITH THE FINITE AVERAGE TABLE.
C      WHEN NTIME = 3 AND 4, MINOR ALTERATIONS ARE MADE IN THE INPUT
C      PARAMETERS WHICH ILLUSTRATE SOME FEATURES OF THE METHOD AND
C      HOW THINGS CAN GO WRONG AND WHETHER OR NOT THE ROUTINE
C      GIVES ANY WARNING.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      CHARACTER *12 GNAME
      CHARACTER *52 NOTES,COM1,COM2,COM3,HNAME,M52
      DIMENSION NOTES(4,4),COM1(4,2),COM2(4,2),COM3(4,2)
      EXTERNAL HFUN,GPER,G5AND9

      DIMENSION WORK(100,14),QLIST(100),SMWORK(10,14)
      DIMENSION SAVPER(128),WEIGHT(18),ABSCIS(18),ISTATE(6)
      COMMON /OSCSUB/PI,HALFPI,EBASE,ALPHA,CONST6,NIX(10),NUMFUN,NB
C
C
C     SET UP THE NOTES. THESE APPEAR BEFORE EACH RUN.
      NOTES(1,1) =
     .            ' FIRST TIME. BRIEF OUTPUT. NOTE EPS AND DIFFERENCE  '
      NOTES(1,2) =
     .            ' SECOND TIME. SAME AS FIRST BUT WITH DETAILED OUTPUT'
      NOTES(1,3) =
     .            ' NOW NDIM1 = 10. SPECIAL VALUE FOR SPACE ECONOMY.   '
      NOTES(1,4) =
     .            ' PERIOD WRONG. IT SHOULD BE TWOPI = 0.628...+01     '
      DO 20 K = 1,4
         DO 10 J = 2,4
            NOTES(J,K) = NOTES(1,K)
   10    CONTINUE
   20 CONTINUE
C
      NOTES(2,3) =
     .            ' NOW NQUAD = -9 FOR 9 POINT GAUSS QUADRATURE RULE   '
      NOTES(3,3) =
     .            ' NOW NDIM1 = 5, TO ILLUSTRATE NO CONVERGENCE.       '
      NOTES(4,3) =
     .            ' NOW NDIM2 = 11, TO ILLUSTRATE VARIANT BEHAVIOR     '
C
C     SET UP THE COMMENTS. THESE APPEAR AFTER EACH RUN.
      M52 = ' MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM '
      DO 40 K = 1,4
         DO 30 J = 1,2
            COM3(K,J) = M52
   30    CONTINUE
   40 CONTINUE
      COM1(1,2) = ' NOTE ISTATE(1), ISTATE(6).  NEGATIVE PERIOD NOTICED'
      COM2(1,2) = ' BEFORE ANY SERIOUS COMPUTATION.                    '
      COM1(2,2) = ' WRONG PERIOD NOTICED QUICKLY SINCE GPER = COS(X)   '
      COM2(2,2) = ' WAS FOUND NOT TO HAVE CLAIMED PERIOD.              '
      COM1(3,2) = ' THIS EASY CALCULATION ENDED DURING THE SIGN CHANGE '
      COM2(3,2) = ' GRACE PERIOD. (YOU CANT LOOSE EM ALL.)             '
      COM1(4,2) = ' SINCE GPER = 1, WRONG PERIOD WAS NOT NOTICED, BUT  '
      COM2(4,2) = ' SIGN CHANGE PATTERN ULTIMATELY LED TO TERMINATION  '
      COM3(4,2) = ' AFTER THE GRACE PERIOD.    MMMMMMMMMMMMMMMMMMMMMM  '
C
      COM1(1,1) = ' NOTE ONLY SMALL ARRAY NEEDED. THE READER MAY       '
      COM2(1,1) = ' IDENTIFY THIS SUBSET OF THE PREVIOUS NUMFUN=1 TABLE'
      COM1(2,1) = ' THIS QUADRATURE RULE INADEQUATE. NOTE THE STEADY   '
      COM2(2,1) = ' CONVERGENCE OF THE TABLE ELEMENTS BELOW TO A RESULT'
      COM3(2,1) = ' WHICH IS IN FACT WRONG. ROUTINE CANNOT KNOW THIS.  '
      COM1(3,1) = ' BECAUSE NDIM1 = 5, BUT THE WORK ARRAY HAS DIMENSION'
      COM2(3,1) = ' 100, THE ELEMENTS APPEAR IN UNFAMILIAR LOCATIONS.  '
      COM1(4,1) = ' THE PREVIOUSLY CHOSEN ELEMENT (16,14) UNREACHABLE. '
      COM2(4,1) = ' EQUALLY GOOD, BUT MARGINALLY MORE EXPENSIVE        '
      COM3(4,1) = ' ELEMENT (25,11) IS CHOSEN INSTEAD.     MMMMMMMMMMM '
C
C      CONSTANTS, ETC.USED IN SUBROUTINES.
      EBASE = DEXP(1.0D0)
      PI = 4.0D0*DATAN(1.0D0)
      HALFPI = PI/2.0D0
      CIN = 1.0D0 + DSQRT(2.0D0)
      CONST6 = 1.0D0/DLOG(CIN)
      ALPHA = 0.0D0
      NB = 2
C
      NTIME = 1
C     HAND CODED LOOP ON NTIME = 1,2,3,4  STARTS HERE.
C
   50 CONTINUE
C
C      NOW, SET THE CODE-CHECK OUTPUT PARAMETERS.
C      SET VALUES OF NIX TO PRINT VARIOUS CODE CHECKS
C          NIX(1) > 0    CAUSES VALUE RETURNED FROM XINT TO BE PRINTED
C                        IN THE MAIN ROUTINE FOR THE FIRST N CALLS
C          NIX(2) > 0    CAUSES FIRST NIX(2) ROWS OF THE FORWARD AVERAGE
C                        TABLE TO BE PRINTED.
C          NIX(3) > 0    CAUSES OUTPUT FROM FUN TO BE PRINTED FOR THE
C                        FIRST N CALLS
C
      NIX(1) = 0
      NIX(3) = 0
      IF (NTIME.GT.1) NIX(2) = 40
C
C
      DO 190 NUMFUN = 1,4
C
         NRUN = 10*NTIME + NUMFUN
         IF (NTIME.EQ.2) NIX(1) = 12
         IF (NTIME.EQ.2) NIX(3) = 12
C
C      FIRST, CLEAR VARIOUS WORK SPACES. THIS IS UNNECESSARY FOR
C      RUNNING, BUT IS USEFUL FOR TIDY OUTPUT.
C
         DO 80 J = 1,NDIM2
            DO 60 I = 1,10
               SMWORK(I,J) = 0.0D0
   60       CONTINUE
            DO 70 I = 1,NDIM1
               WORK(I,J) = 0.0D0
   70       CONTINUE
   80    CONTINUE
         DO 90 I = 1,100
            QLIST(I) = 0.0D0
   90    CONTINUE
         RESULT = 0.0D0
C
C     SECOND, SET THE INPUT PARAMETERS FOR OSCINT.
C
C     AZERO IS THE LOWER LIMIT OF INTEGRATION
         AZERO = 0.0D0
C
         PERIOD = 2.0D0*PI
         IF (NUMFUN.EQ.6) PERIOD = PI
C
C     RFIRST IS THE RIGHT-HAND ENDPOINT OF THE FIRST INTERVAL
         RFIRST = 0.0D0
C
C     NQUAD REPRESENTS THE TYPE OF QUADRATURE RULE USED
C           NQUAD = -5    5 PT GAUSS RULE
C           NQUAD = -9    9 PT GAUSS RULE
C           NQUAD = N,N>0 (N ODD) N POINT TRAPAZOIDAL RULE(N-1 PANELS)
         NQUAD = -9
         IF (NUMFUN.EQ.2) NQUAD = 64
C
C     SET EPSILON, THE REQUESTED TOLERANCE
         EPS = 1.0D-13
C
C     NDIM1 AND NDIM2 ARE THE DIMENSIONS OF THE WORK TABLE. THEY
C     MUST BE LESS THAN OR EQUAL TO THE DIMENSIONS GIVEN TO WORK
C     IN THE DIMENSION STATEMENT
         NDIM1 = 100
         NDIM2 = 14
C
C     WHEN NTIME = 1  ONLY PRINCIPALRESULTS
C     WHEN NTIME = 2  FULL FINITE AVERAGE TABLE AND  OTHER CODE CHECK.
C     WHEN NTIME = 3 OR 4 INPUT CHANGES(MISTAKES,ETC.)
C
         IF (NTIME.NE.3) GO TO 100
         IF (NUMFUN.EQ.1) NDIM1 = 10
         IF (NUMFUN.EQ.2) NQUAD = -9
         IF (NUMFUN.EQ.3) NDIM1 = 5
         IF (NUMFUN.EQ.4) NDIM2 = 11
  100    CONTINUE
C
         IF (NTIME.LT.4) GO TO 110
         IF (NUMFUN.EQ.1) PERIOD = -PI
         IF (NUMFUN.EQ.2) PERIOD = PI
         IF (NUMFUN.EQ.3) PERIOD = PI
         IF (NUMFUN.EQ.4) PERIOD = PI
  110    CONTINUE
C
C      NOW, PRINT OUT THE INPUT PARAMETERS BEFORE THE CALL TO OSCINT.

C
         GNAME = ' 1.0D0      '
         IF (NUMFUN.EQ.2) GNAME = ' COS(X)     '
         IF (NUMFUN.EQ.6) GNAME = ' C4(X) -3/8 '
         IF (NUMFUN.EQ.1) HNAME = 'SIN(X)/X'
         IF (NUMFUN.EQ.2) HNAME = '1.0D0/(1+X**2)'
         IF (NUMFUN.EQ.3) HNAME = 'EXP(-X*SINH(PI/2)*J1(X)'
         IF (NUMFUN.EQ.4) HNAME =
     .            'CONST(1 - EXP(X)) * J0(X) / X . (QUADPACK, PAGE 118)'
         IF (NUMFUN.EQ.5) HNAME = '(1 + 100*EXP(-X**2/PI**2))*J1(X)'
         IF (NUMFUN.EQ.6) HNAME = '(COS**4(X) - 3/8)/(1 + X**2)'
C
         PRINT 9041
         PRINT 9001,NUMFUN,GNAME,HNAME
         PRINT 9011,NOTES(NUMFUN,NTIME),M52
         PRINT 9021,AZERO,PERIOD,RFIRST,EPS,NQUAD
         PRINT 9031,'G5AND9',NDIM1,NDIM2
         PRINT 9041
         IF (NIX(1).GT.0 .OR. NIX(3).GT.0) PRINT 9051
C
C
C
         IF (NRUN.EQ.31) GO TO 120
         CALL OSCINT(AZERO,PERIOD,RFIRST,EPS,NQUAD,NDIM1,NDIM2,G5AND9,
     .               HFUN,GPER,WORK,SAVPER,WEIGHT,ABSCIS,QLIST,RESULT,
     .               ISTATE)
         GO TO 130

  120    CALL OSCINT(AZERO,PERIOD,RFIRST,EPS,NQUAD,NDIM1,NDIM2,G5AND9,
     .               HFUN,GPER,SMWORK,SAVPER,WEIGHT,ABSCIS,QLIST,RESULT,
     .               ISTATE)
  130    CONTINUE
C
C
C      NOW, PRINT OUT THE RESULTS.
C
         PRINT 9061
         PRINT 9071,RESULT,EXACT(),EXACT() - RESULT
         PRINT 9081, (ISTATE(I),I=1,5)
         IF (NTIME.LE.2) PRINT 9091,ISTATE(6)
         NTM2 = NTIME - 2
         IF (NTIME.GE.3) PRINT 9101,COM1(NUMFUN,NTM2),
     .       COM2(NUMFUN,NTM2),ISTATE(6),COM3(NUMFUN,NTM2)
         PRINT 9001,NUMFUN,GNAME,HNAME
         PRINT 9041
C
         IF (NIX(2).LE.0) GO TO 180
         NTERMS = ISTATE(3)
         NCOL = ISTATE(4)
         NPTOP = MIN(NTERMS,NIX(2))
         IF (NRUN.EQ.31) GO TO 150
C
         IF (NRUN.EQ.33) NPTOP = 25
         DO 140 JPR = 1,NPTOP
            IF (NDIM2.LE.10) PRINT 9111,JPR, (WORK(JPR,KPR),KPR=1,10)
            IF (NDIM2.GT.10) PRINT 9121,JPR, (WORK(JPR,KPR),KPR=1,14)
  140    CONTINUE
         GO TO 170
C
  150    NPTOP = MIN(10,NIX(2))
         NPTOP = MIN(NTERMS,NPTOP)
         DO 160 JPR = 1,NPTOP
            IF (NDIM2.LE.10) PRINT 9111,JPR, (SMWORK(JPR,KPR),KPR=1,10)
            IF (NDIM2.GT.10) PRINT 9121,JPR, (SMWORK(JPR,KPR),KPR=1,14)
  160    CONTINUE
C
  170    PRINT 9001,NUMFUN,GNAME,HNAME
         PRINT 9041
  180    CONTINUE
C
         PRINT 9131
  190 CONTINUE
C
      NTIME = NTIME + 1
      IF (NTIME.LT.5) GO TO 50
C
 9001 FORMAT (/,' NUMFUN = ',1X,I1,10X,'F(X) = G(X).H(X).     G(X) = ',
     .     A12,'. H(X) = ',A52)
 9011 FORMAT (/,' INPUT PARAMETERS FOR OSCINT-',25X,A52,/,54X,A52,/)
 9021 FORMAT (4X,'AZERO',12X,'PERIOD',12X,'RFIRST',12X,'EPS',12X,
     .     'NQUAD',12X,/,D13.6,5X,D12.6,6X,D12.6,6X,D12.6,6X,I3,/)
 9031 FORMAT (/,4X,'(GAUSS)',10X,'(HFUN)',12X,'(GPER)',12X,'NDIM1',10X,
     .     'NDIM2',/,4X,A6,11X,37X,I3,11X,I3,/)
 9041 FORMAT (
     .'--------------------------------------------------------- -------
     .----------------')
 9051 FORMAT (/,'    CODE CHECK OUTPUT FROM HFUN, GPER, QRULE',/)
 9061 FORMAT (/,' PRINCIPAL OUTPUT PARAMETERS-',/,/)
 9071 FORMAT (5X,'RESULT',20X,'EXACT',21X,'DIFFERENCE',/,D17.8,10X,
     .     D16.8,10X,D16.8,10X,/,/)
 9081 FORMAT (4X,'ISTATE(1)',5X,'ISTATE(2)',5X,'ISTATE(3)',5X,
     .     'ISTATE(4)',8X,'ISTATE(5)',/,5X,'(IFAIL)',7X,'(LSIGCH)',8X,
     .     '(N)',7X,'(COLUMN NO.)',6X,'(ROW NO.)',/,I13,11X,I3,11X,I3,
     .     11X,I3,13X,I4,/,/)
 9091 FORMAT (4X,'ISTATE(6)',/,' NO. OF FUNCTION VALUES',/,4X,I4,/,/)
 9101 FORMAT (4X,'ISTATE(6)',41X,A52,/,' NO. OF FUNCTION VALUES',31X,
     .     A52,/,4X,I4,46X,A52,//)
 9111 FORMAT (I4,10D12.4,/)
 9121 FORMAT (I4,14D9.2,/)
 9131 FORMAT (/,/,/,/,/,/)
      END
      FUNCTION EXACT()
C
C      EXACT IS THE VALUE OF THE INTEGRAL OF F(X) OVER (0,INFINITY).
C      HERE, OF COURSE, F(X) = H(X).G(X) GIVEN BY HFUN AND GPER BELOW.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /OSCSUB/PI,HALFPI,EBASE,ALPHA,CONST6,NIX(10),NUMFUN,NB

      EXACT = 0.0D0
      IF (NUMFUN.EQ.1) EXACT = HALFPI
      IF (NUMFUN.EQ.2) EXACT = PI/ (2.0D0*EBASE)
      IF (NUMFUN.EQ.3) THEN
          EXACT = DEXP(- (1.0D0+ALPHA)*HALFPI)/DCOSH(HALFPI)
      END IF

      IF (NUMFUN.EQ.4) EXACT = 1.0D0
      IF (NUMFUN.EQ.6) THEN
          EXACT = PI/16.0D0* (EBASE** (-4)+4.0D0*EBASE** (-2))
      END IF

      RETURN
      END
C
C
C
      FUNCTION HFUN(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      EXTERNAL RJBESL

      COMMON /OSCSUB/PI,HALFPI,EBASE,ALPHA,CONST6,NIX(10),NUMFUN,NB
      DIMENSION B(100)
C
C      ALPHA - FRACTIONAL PART OF ORDER FOR WHICH BESSEL FUNCTION IS TO
C              BE CALCULATED, 0 <= ALPHA < 1
C      NB      NUMBER OF BESSEL FUNCTIONS IN SEQUENCE.
C
C
CCCC      IF (NUMFUN .EQ. 1) F(X) = SIN(X)/X
CCCC      IF (NUMFUN .EQ. 2) F(X) = COS(X)/(1+X**2)
CCCC      IF (NUMFUN .EQ. 3) F(X) = EXP(-X*SINH(PI/2)*J1(X)
CCCC      IF (NUMFUN .EQ. 4) F(X) = QUADPACK 5.2.3. PAGE118
CCCC      IF (NUMFUN .EQ. 5) F(X) = (1 + 100*EXP(-X**2/PI**2))*J1(X)
CCCC      IF (NUMFUN .EQ. 6) F(X) = (COS**4(X) - 3/8)/(1 + X**2)
C
CCCC      WHEN NUMFUN IS 1,3,4OR5, H(X) = F(X).
CCCC      WHEN NUMFUN IS 2 OR 6,   H(X) = 1/(1 + X**2)
C
      IF (NUMFUN.NE.1) GO TO 10
      HFUN = 1.0D0 - X**2/6.0D0 + X**4/120.0D0
      IF (DABS(X).GT.10.0D-4) HFUN = SIN(X)/X
      GO TO 30

   10 CONTINUE
      IF (NUMFUN.EQ.2) HFUN = 1.0D0/ (1.0D0+ (X**2.0D0))
      IF (NUMFUN.GE.6) GO TO 20
      IF (NUMFUN.GE.3) CALL RJBESL(X,ALPHA,NB,B,NCALC)
      IF (NUMFUN.EQ.5) HFUN = (1.0D0+1.0D2*
     .                        DEXP(- (X**2.0D0)/ (PI**2.0D0)))*B(2)
C
      IF (NUMFUN.EQ.3) THEN
          U = HALFPI
          SINCHU = (EBASE**U-EBASE** (-U))/2.0D0
          HFUN = EBASE** (-X*SINCHU)*B(2)
      END IF
C
      IF (NUMFUN.EQ.4) THEN
          IF (X.LT.10.0D-8) F1 = 1.0D0
          IF (X.GE.10.0D-8) F1 = (1.0D0-DEXP(-X))/X
          HFUN = F1*CONST6*B(1)
      END IF
C
   20 IF (NUMFUN.EQ.6) HFUN = 1.0D0/ (1.0D0+ (X**2.0D0))
C
   30 CONTINUE
C
      IF (NIX(3).GT.0) THEN
          NIX(3) = NIX(3) - 1
          PRINT 9001,X,HFUN
      END IF

      RETURN

 9001 FORMAT ('   X = ',D22.16,'   HFUN = ',D22.16)
      END
C
C
C
C
      FUNCTION GPER(X)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /OSCSUB/PI,HALFPI,EBASE,ALPHA,CONST6,NIX(10),NUMFUN,NB
C
      GPER = 1.0D0
      IF (NUMFUN.EQ.2) GPER = DCOS(X)
      IF (NUMFUN.EQ.6) GPER = (DCOS(X))**4.0D0 - 3.0D0/8.0D0
      IF (NIX(3).NE.0) PRINT 9001,X,GPER
      RETURN

 9001 FORMAT ('   X = ',D22.16,'   GPER = ',D22.16)
      END
C
C
C
      SUBROUTINE G5AND9(ITYPE,A,B,C,D,NQUAD,WEIGHT,ABSCIS,IERR)
C
C      THIS IS AN EXTRACT FROM A QUADRATURE ROUTINE CONSTRUCTED ONLY FOR
C      USE IN A DRIVER WHICH ILLUSTRATES OSCINT. A NAG LIBRARY
C      SUBSCRIBER MAY REPLACE THIS BY D01BCF FOR GENERAL USE.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION WEIGHT(NQUAD),ABSCIS(NQUAD)
      DIMENSION WT5(5),ABSC5(5),WT9(9),ABSC9(9)
C      THE FOLLOWING DATA ARE WEIGHTS AND ABSCISSAS OF THE FIVE POINT
C      AND THE NINE POINT GAUSS-LEGENDRE QUADRATURE RULES RESPECTIVELY.
C      NORMALISED TO THE INTERVAL (-1,1).
      DATA WT5/.2369268850561891D0,.4786286704993665D0,
     .     .5688888888888889D0,.4786286704993665D0,.2369268850561891D0/
      DATA ABSC5/-.9061798459386640D0,-.5384693101056831D0,0.0D0,
     .     .5384693101056830D0,.9061798459386640D0/
      DATA WT9/.0812743883615745D0,.1806481606948574D0,
     .     .2606106964029355D0,.3123470770400029D0,.3302393550012598D0,
     .     .3123470770400029D0,.2606106964029356D0,.1806481606948575D0,
     .     .8127438836157467D-01/
      DATA ABSC9/-.9681602395076261D0,-.8360311073266358D0,
     .     -.6133714327005904D0,-.3242534234038090D0,0.0D0,
     .     .3242534234038087D0,.6133714327005902D0,.8360311073266357D0,
     .     .9681602395076260D0/
C
      IERR = 59
C
      IF (NQUAD.EQ.5) THEN
          IERR = 0
          DO 10 I = 1,5
             ABSCIS(I) = ABSC5(I)
             WEIGHT(I) = WT5(I)
   10     CONTINUE
      END IF
C
      IF (NQUAD.EQ.9) THEN
          IERR = 0
          DO 20 I = 1,9
             ABSCIS(I) = ABSC9(I)
             WEIGHT(I) = WT9(I)
   20     CONTINUE
      END IF
C
      RETURN
      END
C
C
C
      SUBROUTINE RJBESL(X,ALPHA,NB,B,NCALC)
C-----------------------------------------------------------
C
C  THIS ROUTINE CALCULATES BESSEL FUNCTIONS J SUB(N+ALPHA) (X)
C  FOR NON-NEGATIVE ARGUMENT X, AND NON-NEGATIVE ORDER N+ALPHA.
C
C
C EXPLANATION OF VARIABLES IN THE CALLING SEQUENCE
C
C X     - WORKING PRECISION NON-NEGATIVE REAL ARGUMENT FOR WHICH
C         J'S ARE TO BE CALCULATED.
C ALPHA - WORKING PRECISION FRACTIONAL PART OF ORDER FOR WHICH
C         J'S OR EXPONENTIALLY SCALED J'S (J*EXP(X)) ARE
C         TO BE CALCULATED.  0 .LE. ALPHA .LT. 1.0.
C NB    - INTEGER NUMBER OF FUNCTIONS TO BE CALCULATED, NB .GT. 0.
C         THE FIRST FUNCTION CALCULATED IS OF ORDER ALPHA, AND THE
C         LAST IS OF ORDER (NB - 1 + ALPHA).
C B     - WORKING PRECISION OUTPUT VECTOR OF LENGTH NB.  IF THE ROUTINE
C         TERMINATES NORMALLY (NCALC=NB), THE VECTOR B CONTAINS THE
C         FUNCTIONS J/ALPHA/(X) THROUGH J/NB-1+ALPHA/(X), OR THE
C         CORRESPONDING EXPONENTIALLY SCALED FUNCTIONS.
C NCALC - INTEGER OUTPUT VARIABLE INDICATING POSSIBLE ERRORS.
C         BEFORE USING THE VECTOR B, THE USER SHOULD CHECK THAT
C         NCALC=NB, I.E., ALL ORDERS HAVE BEEN CALCULATED TO
C         THE DESIRED ACCURACY.  SEE ERROR RETURNS BELOW.
C
C
C EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
C
C   IN THE FOLLOWING DISCUSSION, THE DESIRED DECIMAL SIGNIFICANCE
C   IS DENOTED BY  NSIG = IFIX(ALOG10(2)*NBIT+1), WHERE NBIT IS
C   THE NUMBER OF BITS IN THE MANTISSA OF A WORKING PRECISION
C   VARIABLE.  (LOWER VALUES OF NSIG RESULT IN DECREASED ACCURACY
C   WHILE HIGHER VALUES INCREASE CPU TIME WITHOUT INCREASING
C   ACCURACY.) RELATIVE TRUNCATION ERROR IS THEN LIMITED TO
C   T = 0.5*10**(-NSIG).  THE FOLLOWING CONSTANTS ARE USED IN
C   THIS PROGRAM:
C
C ENTEN  - 10.0 ** K, WHERE K IS THE LARGEST INTEGER SUCH THAT
C          ENTEN IS MACHINE-REPRESENTABLE IN WORKING PRECISION.
C ENSIG  - 10.0 ** NSIG.
C RTNSIG - 10.0 ** (-K) FOR THE SMALLEST INTEGER K SUCH THAT
C          K .GE. NSIG/4.
C ENMTEN - THE SMALLEST ABS(X) SUCH THAT X/4 DOES NOT UNDERFLOW.
C XLARGE - UPPER LIMIT ON THE MAGNITUDE OF X.  BEAR IN MIND
C          THAT IF ABS(X)=N, THEN AT LEAST N ITERATIONS OF THE
C          BACKWARD RECURSION WILL BE EXECUTED.
C
C     APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
C
C         IBM/195    CDC/7600  UNIVAC/1108   VAX 11/780 (UNIX)
C          (D.P.)  (S.P.,RNDG)    (D.P.)     (S.P.)     (D.P.)
C
C NSIG      16         14          18           8        17
C ENTEN   1.0D75     1.0E322     1.0D307     1.0E38    1.0D38
C ENSIG   1.0D16     1.0E14      1.0D18      1.0E8     1.0D17
C RTNSIG  1.0D-4     1.0E-4      1.0D-5      1.0E-2    1.0D-4
C ENMTEN  2.2D-78    1.0E-290    1.2D-308    1.2E-37   1.2D-37
C XLARGE  1.0D4      1.0E4       1.0D4       1.0E4     1.0D4
C
C
C ERROR RETURNS
C
C  IN CASE OF AN ERROR,  NCALC .NE. NB,  AND NOT ALL J'S ARE
C  CALCULATED TO THE DESIRED ACCURACY.
C
C  NCALC .LT. 0:  AN ARGUMENT IS OUT OF RANGE. FOR EXAMPLE,
C     NB .LE. 0, ALPHA .LT. 0 OR .GT. 1, OR X IS TOO LARGE.
C     IN THIS CASE, THE B-VECTOR IS NOT CALCULATED, AND NCALC IS
C     SET TO  MIN0(NB,0)-1  SO THAT NCALC .NE. NB.
C
C  NB .GT. NCALC .GT. 0: NOT ALL REQUESTED FUNCTION VALUES COULD
C     BE CALCULATED ACCURATELY.  THIS USUALLY OCCURS BECAUSE NB IS
C     MUCH LARGER THAN ABS(X).  IN THIS CASE, B(N) IS CALCULATED
C     TO THE DESIRED ACCURACY FOR  N .LE. NCALC,  BUT PRECISION
C     IS LOST FOR NCALC .LT. N .LE. NB.  IF B(N) DOES NOT VANISH
C     FOR  N .GT. NCALC  (BECAUSE IT IS TOO SMALL TO BE REPRESENTED),
C     AND  B(N)/B(NCALC) = 10**(-K), THEN ONLY THE FIRST NSIG-K
C     SIGNIFICANT FIGURES OF B(N) CAN BE TRUSTED.
C
C
C OTHER SUBPROGRAMS REQUIRED (SINGLE PRECISION VERSION)
C
C     ABS,AINT,AMAX1,COS,GAMMA,SIN,SQRT,FLOAT,IFIX,MIN0
C
C OTHER SUBPROGRAMS REQUIRED (DOUBLE PRECISION VERSION)
C
C     DABS,DBLE,DCOS,DINT,DGAMMA,DMAX1,DSIN,DSQRT,FLOAT,
C          IFIX,MIN0,SNGL
C
C
C ACKNOWLEDGEMENT
C
C  THIS PROGRAM IS BASED ON A PROGRAM WRITTEN BY DAVID J. SOOKNE
C  THAT COMPUTES VALUES OF THE BESSEL FUNCTIONS J OR I OF REAL
C  ARGUMENT AND INTEGER ORDER.  MODIFICATIONS INCLUDE THE
C  RESTRICTION OF THE COMPUTATION TO THE J BESSEL FUNCTION OF
C  NON-NEGATIVE REAL ARGUMENT, THE EXTENSION OF THE COMPUTATION TO
C  ARBITRARY POSITIVE ORDER, AND THE ELIMINATION OF MOST UNDERFLOW.
C
C
C      MODIFIED BY: W. J. CODY
C                   ARGONNE NATIONAL LABORATORY
C
C      LATEST MODIFICATION: AUGUST 4, 1982
C
C-----------------------------------------------------------
      INTEGER I,J,K,L,M,MAGX,N,NB,NBMX,NCALC,NEND,NSTART
CR    REAL ALPHA, ALPEM, ALP2EM, B, CAPP, CAPQ, EIGHTH, EM, EN,
CR   * ENMTEN, ENSIG, ENTEN, FACT, FOUR, GAMMA, GNU, HALF, HALFX, ONE,
CR   * P, PI2, PLAST, POLD, PSAVE, PSAVEL, RTNSIG, S, SUM, T,
CR   * T1, TEMPA, TEMPB, TEMPC, TEST, THREE, TOVER, TWO, TWOFIV, TWOPI1,
CR   * TWOPI2, X, XC, XIN, XK, XLARGE, XM, VCOS, VSIN, Z, ZERO
      DOUBLE PRECISION ALPHA,ALPEM,ALP2EM,B,CAPP,CAPQ,DGAMMA,EIGHTH,EM,
     .                 EN,ENMTEN,ENSIG,ENTEN,FACT,FOUR,GNU,HALF,HALFX,
     .                 ONE,P,PI2,PLAST,POLD,PSAVE,PSAVEL,RTNSIG,S,SUM,T,
     .                 T1,TEMPA,TEMPB,TEMPC,TEST,THREE,TOVER,TWO,TWOFIV,
     .                 TWOPI1,TWOPI2,X,XC,XIN,XK,XLARGE,XM,VCOS,VSIN,Z,
     .                 ZERO
      DIMENSION B(NB),FACT(25)
C-----------------------------------------------------------
C  MATHEMATICAL CONSTANTS
C
C   PI2    - 2 / PI
C   TWOPI1 - FIRST FEW SIGNIFICANT DIGITS OF 2 * PI
C   TWOPI2 - (2*PI - TWOPI) TO WORKING PRECISION, I.E.,
C            TWOPI1 + TWOPI2 = 2 * PI TO EXTRA PRECISION
C-----------------------------------------------------------
CR    DATA PI2, TWOPI1, TWOPI2 /0.636619772367581343075535E0,6.28125E0,
CR   * 1.935307179586476925286767E-3/
CR    DATA ZERO, EIGHTH, HALF, ONE /0.0E0,0.125E0,0.5E0,1.0E0/
CR    DATA TWO, THREE, FOUR, TWOFIV /2.0E0,3.0E0,4.0E0,25.0E0/
      DATA PI2,TWOPI1,TWOPI2/0.636619772367581343075535D0,6.28125D0,
     .     1.935307179586476925286767D-3/
      DATA ZERO,EIGHTH,HALF,ONE/0.0D0,0.125D0,0.5D0,1.0D0/
      DATA TWO,THREE,FOUR,TWOFIV/2.0D0,3.0D0,4.0D0,25.0D0/
C-----------------------------------------------------------
C  MACHINE DEPENDENT PARAMETERS
C-----------------------------------------------------------
CR    DATA ENTEN, ENSIG, RTNSIG /1.0E38,1.0E8,1.0E-2/
CR    DATA ENMTEN, XLARGE /1.2E-37,1.0E4/
      DATA ENTEN,ENSIG,RTNSIG/1.0D38,1.0D17,1.0D-4/
      DATA ENMTEN,XLARGE/1.2D-37,1.0D4/
C---------------------------------------------------------------------
C     FACTORIAL(N)
C---------------------------------------------------------------------
CR    DATA FACT /1.0E0,1.0E0,2.0E0,6.0E0,24.0E0,1.2E2,7.2E2,5.04E3,
CR   * 4.032E4,3.6288E5,3.6288E6,3.99168E7,4.790016E8,6.2270208E9,
CR   * 8.71782912E10,1.307674368E12,2.0922789888E13,3.55687428096E14,
CR   * 6.402373705728E15,1.21645100408832E17,2.43290200817664E18,
CR   * 5.109094217170944E19,1.12400072777760768E21,2.585201673888497664E
CR   * 22,6.2044840173323943936E23/
      DATA FACT/1.0D0,1.0D0,2.0D0,6.0D0,24.0D0,1.2D2,7.2D2,5.04D3,
     .     4.032D4,3.6288D5,3.6288D6,3.99168D7,4.790016D8,6.2270208D9,
     .     8.71782912D10,1.307674368D12,2.0922789888D13,
     .     3.55687428096D14,6.402373705728D15,1.21645100408832D17,
     .     2.43290200817664D18,5.109094217170944D19,
     .     1.12400072777760768D21,2.585201673888497664D22,
     .     6.2044840173323943936D23/
C---------------------------------------------------------------------
CR    MAGX = IFIX(X)
      MAGX = IFIX(SNGL(X))
      IF ((NB.GT.0) .AND. (X.GE.ZERO) .AND. (X.LE.XLARGE) .AND.
     .    (ALPHA.GE.ZERO) .AND. (ALPHA.LT.ONE)) GO TO 10
C-----------------------------------------------------------
C ERROR RETURN -- X,NB,OR ALPHA IS OUT OF RANGE
C-----------------------------------------------------------
      NCALC = MIN0(NB,0) - 1
      GO TO 290
C-----------------------------------------------------------
C INITIALIZE RESULT ARRAY TO ZERO
C-----------------------------------------------------------
   10 NCALC = NB
      DO 20 I = 1,NB
         B(I) = ZERO
   20 CONTINUE
C-----------------------------------------------------------
C BRANCH TO USE 2-TERM ASCENDING SERIES FOR SMALL X,
C AND ASYMPTOTIC FORM FOR LARGE X WHEN NB IS NOT TOO LARGE
C-----------------------------------------------------------
      IF (X.LT.RTNSIG) GO TO 210
      IF ((X.GT.TWOFIV) .AND. (NB.LE.MAGX+1)) GO TO 250
C-----------------------------------------------------------
C USE RECURRENCE TO GENERATE RESULTS.
C FIRST INITIALIZE THE CALCULATION OF P*S
C-----------------------------------------------------------
      NBMX = NB - MAGX
      N = MAGX + 1
CR    EN = FLOAT(N+N) + (ALPHA+ALPHA)
      EN = DBLE(FLOAT(N+N)) + (ALPHA+ALPHA)
      PLAST = ONE
      P = EN/X
C-----------------------------------------------------------
C CALCULATE GENERAL SIGNIFICANCE TEST
C-----------------------------------------------------------
      TEST = ENSIG + ENSIG
      IF (NBMX.LT.3) GO TO 40
C-----------------------------------------------------------
C CALCULATE P*S UNTIL N = NB-1.  CHECK FOR POSSIBLE OVERFLOW.
C-----------------------------------------------------------
      TOVER = ENTEN/ENSIG
      NSTART = MAGX + 2
      NEND = NB - 1
CR    EN = FLOAT(NSTART+NSTART) - TWO + (ALPHA+ALPHA)
      EN = DBLE(FLOAT(NSTART+NSTART)) - TWO + (ALPHA+ALPHA)
      DO 30 N = NSTART,NEND
         EN = EN + TWO
         POLD = PLAST
         PLAST = P
         P = EN*PLAST/X - POLD
         IF (P.GT.TOVER) GO TO 50
   30 CONTINUE
      N = NEND
CR    EN = FLOAT(N+N) + (ALPHA+ALPHA)
      EN = DBLE(FLOAT(N+N)) + (ALPHA+ALPHA)
C-----------------------------------------------------------
C CALCULATE SPECIAL SIGNIFICANCE TEST FOR NBMX.GT.2.
C-----------------------------------------------------------
CR    TEST = AMAX1(TEST,SQRT(PLAST*ENSIG)*SQRT(P+P))
      TEST = DMAX1(TEST,DSQRT(PLAST*ENSIG)*DSQRT(P+P))
C-----------------------------------------------------------
C CALCULATE P*S UNTIL SIGNIFICANCE TEST PASSES
C-----------------------------------------------------------
   40 N = N + 1
      EN = EN + TWO
      POLD = PLAST
      PLAST = P
      P = EN*PLAST/X - POLD
      IF (P.LT.TEST) GO TO 40
      GO TO 90
C-----------------------------------------------------------
C TO AVOID OVERFLOW, DIVIDE P*S BY TOVER.  CALCULATE P*S
C UNTIL ABS(P).GT.1.
C-----------------------------------------------------------
   50 TOVER = ENTEN
      P = P/TOVER
      PLAST = PLAST/TOVER
      PSAVE = P
      PSAVEL = PLAST
      NSTART = N + 1
   60 N = N + 1
      EN = EN + TWO
      POLD = PLAST
      PLAST = P
      P = EN*PLAST/X - POLD
      IF (P.LE.ONE) GO TO 60
      TEMPB = EN/X
C-----------------------------------------------------------
C CALCULATE BACKWARD TEST, AND FIND NCALC, THE HIGHEST N
C SUCH THAT THE TEST IS PASSED.
C-----------------------------------------------------------
      TEST = POLD*PLAST* (HALF-HALF/ (TEMPB*TEMPB))/ENSIG
      P = PLAST*TOVER
      N = N - 1
      EN = EN - TWO
      NEND = MIN0(NB,N)
      DO 70 L = NSTART,NEND
         NCALC = L
         POLD = PSAVEL
         PSAVEL = PSAVE
         PSAVE = EN*PSAVEL/X - POLD
         IF (PSAVE*PSAVEL.GT.TEST) GO TO 80
   70 CONTINUE
      NCALC = NEND + 1
   80 NCALC = NCALC - 1
C-----------------------------------------------------------
C INITIALIZE THE BACKWARD RECURSION AND THE NORMALIZATION
C SUM
C-----------------------------------------------------------
   90 N = N + 1
      EN = EN + TWO
      TEMPB = ZERO
      TEMPA = ONE/P
      M = 2*N - 4* (N/2)
      SUM = ZERO
CR    EM = FLOAT(N/2)
      EM = DBLE(FLOAT(N/2))
      ALPEM = (EM-ONE) + ALPHA
      ALP2EM = (EM+EM) + ALPHA
      IF (M.NE.0) SUM = TEMPA*ALPEM*ALP2EM/EM
      NEND = N - NB
      IF (NEND.LE.0) GO TO 120
C     IF (NEND) 140, 120, 100
C-----------------------------------------------------------
C RECUR BACKWARD VIA DIFFERENCE EQUATION, CALCULATING (BUT
C NOT STORING) B(N), UNTIL N = NB.
C-----------------------------------------------------------
  100 DO 110 L = 1,NEND
         N = N - 1
         EN = EN - TWO
         TEMPC = TEMPB
         TEMPB = TEMPA
         TEMPA = (EN*TEMPB)/X - TEMPC
         M = 2 - M
         IF (M.EQ.0) GO TO 110
         EM = EM - ONE
         ALP2EM = (EM+EM) + ALPHA
         IF (N.EQ.1) GO TO 120
         ALPEM = (EM-ONE) + ALPHA
         IF (ALPEM.EQ.ZERO) ALPEM = ONE
         SUM = (SUM+TEMPA*ALP2EM)*ALPEM/EM
  110 CONTINUE
C-----------------------------------------------------------
C STORE B(NB)
C-----------------------------------------------------------
  120 B(N) = TEMPA
      IF (NEND.GE.0) GO TO 130
      NEND = -NEND
      GO TO 150

  130 IF (NB.GT.1) GO TO 140
      ALP2EM = ALPHA
      IF ((ALPHA+ONE).EQ.ONE) ALP2EM = ONE
      SUM = SUM + B(1)*ALP2EM
      GO TO 190
C-----------------------------------------------------------
C CALCULATE AND STORE B(NB-1)
C-----------------------------------------------------------
  140 N = N - 1
      EN = EN - TWO
      B(N) = (EN*TEMPA)/X - TEMPB
      IF (N.EQ.1) GO TO 180
      M = 2 - M
      IF (M.EQ.0) GO TO 150
      EM = EM - ONE
      ALP2EM = (EM+EM) + ALPHA
      ALPEM = (EM-ONE) + ALPHA
      IF (ALPEM.EQ.ZERO) ALPEM = ONE
      SUM = (SUM+B(N)*ALP2EM)*ALPEM/EM
C     GO TO 160
C-----------------------------------------------------------
C N.LT.NB, SO STORE B(N) AND SET HIGHER ORDERS TO ZERO
C-----------------------------------------------------------
C 140 B(N) = TEMPA
C     NEND = -NEND
C     DO 150 L=1,NEND
C       B(N+L) = ZERO
C 150 CONTINUE
  150 NEND = N - 2
      IF (NEND.EQ.0) GO TO 170
C-----------------------------------------------------------
C CALCULATE VIA DIFFERENCE EQUATION AND STORE B(N),
C UNTIL N = 2
C-----------------------------------------------------------
      DO 160 L = 1,NEND
         N = N - 1
         EN = EN - TWO
         B(N) = (EN*B(N+1))/X - B(N+2)
         M = 2 - M
         IF (M.EQ.0) GO TO 160
         EM = EM - ONE
         ALP2EM = (EM+EM) + ALPHA
         ALPEM = (EM-ONE) + ALPHA
         IF (ALPEM.EQ.ZERO) ALPEM = ONE
         SUM = (SUM+B(N)*ALP2EM)*ALPEM/EM
  160 CONTINUE
C-----------------------------------------------------------
C CALCULATE B(1)
C-----------------------------------------------------------
  170 B(1) = TWO* (ALPHA+ONE)*B(2)/X - B(3)
  180 EM = EM - ONE
      ALP2EM = (EM+EM) + ALPHA
      IF (ALP2EM.EQ.ZERO) ALP2EM = ONE
      SUM = SUM + B(1)*ALP2EM
C-----------------------------------------------------------
C NORMALIZE.  DIVIDE ALL B(N) BY SUM.
C-----------------------------------------------------------
CR200 IF ((ALPHA+ONE).NE.ONE) SUM = SUM*GAMMA(ALPHA)*(X*HALF)**(-ALPHA)
  190 IF ((ALPHA+ONE).NE.ONE) SUM = SUM*DGAMMA(ALPHA)* (X*HALF)**
     .                              (-ALPHA)
      TEMPA = ENMTEN
      IF (SUM.GT.ONE) TEMPA = TEMPA*SUM
      DO 200 N = 1,NB
CR      IF (ABS(B(N)).LT.TEMPA) B(N) = ZERO
         IF (DABS(B(N)).LT.TEMPA) B(N) = ZERO
         B(N) = B(N)/SUM
  200 CONTINUE
      GO TO 290
C-----------------------------------------------------------
C TWO-TERM ASCENDING SERIES FOR SMALL X
C-----------------------------------------------------------
  210 TEMPA = ONE
      ALPEM = ONE + ALPHA
      HALFX = ZERO
      IF (X.GT.ENMTEN) HALFX = HALF*X
CR    IF (ALPHA.NE.ZERO) TEMPA = HALFX**ALPHA/(ALPHA*GAMMA(ALPHA))
      IF (ALPHA.NE.ZERO) TEMPA = HALFX**ALPHA/ (ALPHA*DGAMMA(ALPHA))
      TEMPB = ZERO
      IF ((X+ONE).GT.ONE) TEMPB = -HALFX*HALFX
      B(1) = TEMPA + TEMPA*TEMPB/ALPEM
      IF ((X.NE.ZERO) .AND. (B(1).EQ.ZERO)) NCALC = 0
      IF (NB.EQ.1) GO TO 290
      IF (X.GT.ZERO) GO TO 230
      DO 220 N = 2,NB
         B(N) = ZERO
  220 CONTINUE
      GO TO 290
C-----------------------------------------------------------
C CALCULATE HIGHER ORDER FUNCTIONS
C-----------------------------------------------------------
  230 TEMPC = HALFX
      TOVER = (ENMTEN+ENMTEN)/X
      IF (TEMPB.NE.ZERO) TOVER = ENMTEN/TEMPB
      DO 240 N = 2,NB
         TEMPA = TEMPA/ALPEM
         ALPEM = ALPEM + ONE
         TEMPA = TEMPA*TEMPC
         IF (TEMPA.LE.TOVER*ALPEM) TEMPA = ZERO
         B(N) = TEMPA + TEMPA*TEMPB/ALPEM
         IF ((B(N).EQ.ZERO) .AND. (NCALC.GT.N)) NCALC = N - 1
  240 CONTINUE
      GO TO 290
C-----------------------------------------------------------
C ASYMPTOTIC SERIES FOR X .GT. 21.0
C-----------------------------------------------------------
  250 XC = SQRT(PI2/X)
CD260 XC = DSQRT(PI2/X)
      XIN = (EIGHTH/X)**2
      M = 11
CR    IF (X.GE.35.0E0) M = 8
CR    IF (X.GE.130.0E0) M = 4
      IF (X.GE.35.0D0) M = 8
      IF (X.GE.130.0D0) M = 4
      XM = FOUR*FLOAT(M)
C-----------------------------------------------------------
C REDUCTION OF ARGUMENT FOR SIN AND COS ROUTINES
C-----------------------------------------------------------
CR      T = AINT(X/(TWOPI1+TWOPI2)+HALF)
      T = DINT(X/ (TWOPI1+TWOPI2)+HALF)
      Z = ((X-T*TWOPI1)-T*TWOPI2) - (ALPHA+HALF)/PI2
CR    VSIN = SIN(Z)
CR    VCOS = COS(Z)
      VSIN = DSIN(Z)
      VCOS = DCOS(Z)
      GNU = ALPHA + ALPHA
      DO 270 I = 1,2
         S = ((XM-ONE)-GNU)* ((XM-ONE)+GNU)*XIN*HALF
         T = (GNU- (XM-THREE))* (GNU+ (XM-THREE))
         CAPP = S*T/FACT(2*M+1)
         T1 = (GNU- (XM+ONE))* (GNU+ (XM+ONE))
         CAPQ = S*T1/FACT(2*M+2)
         XK = XM
         K = M + M
         T1 = T
         DO 260 J = 2,M
            XK = XK - FOUR
            S = ((XK-ONE)-GNU)* ((XK-ONE)+GNU)
            T = (GNU- (XK-THREE))* (GNU+ (XK-THREE))
            CAPP = (CAPP+ONE/FACT(K-1))*S*T*XIN
            CAPQ = (CAPQ+ONE/FACT(K))*S*T1*XIN
            K = K - 2
            T1 = T
  260    CONTINUE
         CAPP = CAPP + ONE
         CAPQ = (CAPQ+ONE)* (GNU*GNU-ONE)* (EIGHTH/X)
         B(I) = XC* (CAPP*VCOS-CAPQ*VSIN)
         IF (NB.EQ.1) GO TO 290
         T = VSIN
         VSIN = -VCOS
         VCOS = T
         GNU = GNU + TWO
  270 CONTINUE
C-----------------------------------------------------------
C IF  NB .GT. 2, COMPUTE J(X,ORDER+I)  I = 2, NB-1
C-----------------------------------------------------------
      IF (NB.LE.2) GO TO 290
      GNU = ALPHA + ALPHA + TWO
C
      DO 280 J = 3,NB
         B(J) = GNU*B(J-1)/X - B(J-2)
         GNU = GNU + TWO
  280 CONTINUE
C-----------------------------------------------------------
C EXIT
C-----------------------------------------------------------
  290 RETURN
C ---------- LAST CARD OF RJBESL ----------
      END
C
C
C
C
C
CS    REAL FUNCTION GAMMA(X)
      DOUBLE PRECISION FUNCTION DGAMMA(X)
C----------------------------------------------------------------------
C
C THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X.
C     COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN W. J. CODY,
C     'AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL FUNCTIONS',
C     LECTURE NOTES IN MATHEMATICS, 506, NUMERICAL ANALYSIS DUNDEE,
C     1975, G. A. WATSON (ED.), SPRINGER VERLAG, BERLIN, 1976.  THE
C     PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA
C     FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS.  COEFFICIENTS
C     FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
C     THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM HART, ET. AL.,
C     COMPUTER APPROXIMATIONS, WILEY AND SONS, NEW YORK, 1968.  LOWER
C     ORDER APPROXIMATIONS CAN BE SUBSTITUTED FOR THESE ON MACHINES
C     WITH LESS PRECISE ARITHMETIC.
C
C
C*******************************************************************
C*******************************************************************
C
C EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
C
C EPS    - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
C          1.0 + EPS .GT. 1.0
C XBIG   - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE
C          IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION
C                  GAMMA(XBIG) = XINF.
C XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
C          1/XMININ IS MACHINE REPRESENTABLE.
C XINF   - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER.
C
C     APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
C
C         IBM/195    CDC/7600  UNIVAC/1108   VAX 11/780 (UNIX)
C          (D.P.)  (S.P.,RNDG)    (D.P.)     (S.P.)     (D.P.)
C
C EPS     2.221D-16  3.553E-15   1.735D-18   5.961E-08  1.388D-17
C XBIG    57.574     177.802     171.489     34.844     34.844
C XMININ  1.382D-76  3.132E-294  1.113D-308  5.883E-39  5.883D-39
C XINF    7.23D+75   1.26E+322   8.98D+307   1.70E+38   1.70D+38
C
C*******************************************************************
C*******************************************************************
C
C
C ERROR RETURNS
C
C  THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
C     WHEN OVERFLOW WOULD OCCUR.  THE COMPUTATION IS BELIEVED
C     TO BE FREE OF UNDERFLOW AND OVERFLOW.
C
C
C
C OTHER SUBPROGRAMS REQUIRED (SINGLE PRECISION VERSION)
C
C     ALOG,EXP,FLOAT,IFIX,SIN
C
C OTHER SUBPROGRAMS REQUIRED (DOUBLE PRECISION VERSION)
C
C     DBLE,DEXP,DLOG,DSIN,FLOAT,IFIX,SNGL
C
C
C
C  AUTHOR: W. J. CODY
C          APPLIED MATHEMATICS DIVISION
C          ARGONNE NATIONAL LABORATORY
C          ARGONNE, IL 60439
C
C  LATEST MODIFICATION: MAY 18, 1982
C
C----------------------------------------------------------------------
CS    REAL C,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,
CS   1     SUM,TWELVE,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
      DOUBLE PRECISION C,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,SUM,TWELVE,
     .                 X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
      INTEGER I,J,N
      LOGICAL PARITY
      DIMENSION C(7),P(8),Q(8)
C----------------------------------------------------------------------
C  MATHEMATICAL CONSTANTS
C----------------------------------------------------------------------
CS    DATA ONE,HALF,TWELVE,ZERO/1.0E0,0.5E0,12.0E0,0.0E0/
CS    DATA SQRTPI/0.9189385332046727417803297E0/
CS    DATA PI/3.1415926535897932384626434E0/
      DATA ONE,HALF,TWELVE,ZERO/1.0D0,0.5D0,12.0D0,0.0D0/
      DATA SQRTPI/0.9189385332046727417803297D0/
      DATA PI/3.1415926535897932384626434D0/
C----------------------------------------------------------------------
C  MACHINE DEPENDENT PARAMETERS
C----------------------------------------------------------------------
CS    DATA XBIG,XMININ,EPS/34.844E0,5.883E-39,5.961E-08/
CS    DATA XINF/1.7014E38/
      DATA XBIG,XMININ,EPS/34.844D0,5.883D-39,1.388D-17/
      DATA XINF/1.7014D38/
C----------------------------------------------------------------------
C  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
C     APPROXIMATION OVER (1,2).
C----------------------------------------------------------------------
CS    DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1,
CS   1       -3.79804256470945635097577E+2,6.29331155312818442661052E+2,
CS   2       8.66966202790413211295064E+2,-3.14512729688483675254357E+4,
CS   3       -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
CS    DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2,
CS   1      -1.01515636749021914166146E+3,-3.10777167157231109440444E+3,
CS   2        2.25381184209801510330112E+4,4.75584627752788110767815E+3,
CS   3      -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
      DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1,
     .     -3.79804256470945635097577D+2,6.29331155312818442661052D+2,
     .     8.66966202790413211295064D+2,-3.14512729688483675254357D+4,
     .     -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
      DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2,
     .     -1.01515636749021914166146D+3,-3.10777167157231109440444D+3,
     .     2.25381184209801510330112D+4,4.75584627752788110767815D+3,
     .     -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
C----------------------------------------------------------------------
C  COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
C----------------------------------------------------------------------
CS    DATA C/-1.910444077728E-03,8.4171387781295E-04,
CS   1     -5.952379913043012E-04,7.93650793500350248E-04,
CS   2     -2.777777777777681622553E-03,8.333333333333333331554247E-02,
CS   3      5.7083835261E-03/
      DATA C/-1.910444077728D-03,8.4171387781295D-04,
     .     -5.952379913043012D-04,7.93650793500350248D-04,
     .     -2.777777777777681622553D-03,8.333333333333333331554247D-02,
     .     5.7083835261D-03/
C----------------------------------------------------------------------
      PARITY = .FALSE.
      FACT = ONE
      N = 0
      Y = X
      IF (Y.GT.ZERO) GO TO 10
C----------------------------------------------------------------------
C  ARGUMENT IS NEGATIVE
C----------------------------------------------------------------------
      Y = -X
CS    J = IFIX(Y)
      J = IFIX(SNGL(Y))
CS    RES = Y - FLOAT(J)
      RES = Y - DBLE(FLOAT(J))
      IF (RES.EQ.ZERO) GO TO 100
      IF (J.NE. (J/2)*2) PARITY = .TRUE.
CS    FACT = -PI / SIN(PI*RES)
      FACT = -PI/DSIN(PI*RES)
      Y = Y + ONE
C----------------------------------------------------------------------
C  ARGUMENT IS POSITIVE
C----------------------------------------------------------------------
   10 IF (Y.LT.EPS) GO TO 90
      IF (Y.GE.TWELVE) GO TO 70
      Y1 = Y
      IF (Y.GE.ONE) GO TO 20
C----------------------------------------------------------------------
C  0.0 .LT. ARGUMENT .LT. 1.0
C----------------------------------------------------------------------
      Z = Y
      Y = Y + ONE
      GO TO 30
C----------------------------------------------------------------------
C  1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
C----------------------------------------------------------------------
CS210 N = IFIX(Y) - 1
   20 N = IFIX(SNGL(Y)) - 1
CS    Y = Y - FLOAT(N)
      Y = Y - DBLE(FLOAT(N))
      Z = Y - ONE
C----------------------------------------------------------------------
C  EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
C----------------------------------------------------------------------
   30 XNUM = ZERO
      XDEN = ONE
      DO 40 I = 1,8
         XNUM = (XNUM+P(I))*Z
         XDEN = XDEN*Z + Q(I)
   40 CONTINUE
      RES = XNUM/XDEN + ONE
      IF (Y.EQ.Y1) GO TO 110
      IF (Y1.GT.Y) GO TO 50
C----------------------------------------------------------------------
C  ADJUST RESULT FOR CASE  0.0 .LT. ARGUMENT .LT. 1.0
C----------------------------------------------------------------------
      RES = RES/Y1
      GO TO 110
C----------------------------------------------------------------------
C  ADJUST RESULT FOR CASE  2.0 .LT. ARGUMENT .LT. 12.0
C----------------------------------------------------------------------
   50 DO 60 I = 1,N
         RES = RES*Y
         Y = Y + ONE
   60 CONTINUE
      GO TO 110
C----------------------------------------------------------------------
C  EVALUATE FOR ARGUMENT .GE. 12.0,
C----------------------------------------------------------------------
   70 IF (Y.GT.XBIG) GO TO 100
      YSQ = Y*Y
      SUM = C(7)
      DO 80 I = 1,6
         SUM = SUM/YSQ + C(I)
   80 CONTINUE
      SUM = SUM/Y - Y + SQRTPI
CS    SUM = SUM + (Y-HALF)*ALOG(Y)
      SUM = SUM + (Y-HALF)*DLOG(Y)
CS    RES = EXP(SUM)
      RES = DEXP(SUM)
      GO TO 110
C----------------------------------------------------------------------
C  ARGUMENT .LT. EPS
C----------------------------------------------------------------------
   90 IF (Y.LT.XMININ) GO TO 100
      RES = ONE/Y
      GO TO 110
C----------------------------------------------------------------------
C  RETURN FOR SINGULARITIES, EXTREME ARGUMENTS, ETC.
C----------------------------------------------------------------------
CS700 GAMMA = XINF
  100 DGAMMA = XINF
      GO TO 120
C----------------------------------------------------------------------
C  FINAL ADJUSTMENTS AND RETURN
C----------------------------------------------------------------------
  110 IF (PARITY) RES = -RES
      IF (FACT.NE.ONE) RES = FACT/RES
CS    GAMMA = RES
      DGAMMA = RES
  120 RETURN
C ---------- LAST CARD OF GAMMA ----------
      END
C **************** BEGIN SUBROUTINE OSCINT ****************
C
      SUBROUTINE OSCINT(AZERO,PERIOD,RFIRST,EPS,NQUAD,NDIM1,NDIM2,GAUSS,
     .                  HFUN,GPER,WORK,SAVPER,WEIGHT,ABSCIS,QLIST,
     .                  RESULT,ISTATE)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C         THIS ROUTINE PROVIDES AN APPROXIMATION **RESULT** TO THE
C     INTEGRAL OF AN OVERALL INTEGRAND **HFUN(X)*GPER(X)** OVER A
C     SEMI-INFINITE INTERVAL (AZERO,INFINITY).  THE OVERALL INTEGRAND
C     FUNCTION SHOULD BE ULTIMATELY OSCILLATING IN SIGN AND PERIODIC
C     WITH USER-PROVIDED **PERIOD**.
C
C         THE ROUTINE CONSIDERS A SEQUENCE OF INTERVALS.  ALL THE
C     THE INTERVALS, EXCEPT THE FIRST, ARE OF LENGTH 0.5*PERIOD.
C     IT USES A QUADRATURE RULE TO APPROXIMATE THE INTEGRAL OVER
C     EACH INTERVAL.  THESE APPROXIMATIONS ARE STORED IN
C     QLIST(J)   J = 1,2,3,...   .  THE VALUES OF QLIST ULTIMATELY
C     OSCILLATE IN SIGN.  THEN THE ROUTINE USES A SERIES ACCELERATION
C     TECHNIQUE BASED ON THE EULER TRANSFORMATION TO SUM THIS SEQUENCE.
C
C
C INPUT PARAMETERS:
C
C   AZERO         LOWER LIMIT OF INTEGRATION
C
C   PERIOD        LEAST POSITIVE PERIOD OR ULTIMATE PERIOD OF
C                 INTEGRAND FUNCTION
C
C   RFIRST        RIGHT-HAND ENDPOINT OF FIRST INTERVAL. SUGGESTED VALUE
C                 FOR STRAIGHTFORWARD PROBLEMS IS AZERO.
C                 SEE NOTE 1 BELOW
C
C   EPS           THE REQUESTED ACCURACY
C
C   NQUAD         INTEGER. NQ = ABS(NQUAD) IS THE NUMBER OFABSCISSAS TO
C                 BE USED BY THE QUADRATURE RULE IN EACH INTERVAL.
C                     NQUAD > 1    TRAPEZOIDAL RULE IS USED
C                     NQUAD < 0    RULE SPECIFIED BY GAUSS BELOW IS USED
C
C   NDIM1,NDIM2   DIMENSIONS OF THE OUTPUT ARRAY **WORK**.
C                 NDIM1 = 10 IMPLIES NMAX = 100
C                 NDIM1 .NE. 10 IMPLIES NMAX = MIN(100,NDIM1)
C                 NMAX IS A PHYSICAL LIMIT.  IF CALCULATION IS NOT
C                 COMPLETE AFTER NMAX INTERVALS HAVE BEEN CONSIDERED
C                 IT IS THEN ABANDONED. (SEE NOTE 5 BELOW)
C                 NDIM2  SUGGESTED VALUE IS 15. NORMALLY SHOULD EXCEED 4
C
C   GAUSS         NAME OF A SUBROUTINE WHICH PROVIDES WEIGHTS
C                 AND ABSCISSAS.  WHEN NQUAD > 0 THIS IS NOT CALLED.
C                 SEE NOTE 2 BELOW FOR USE WHEN NQUAD < 0.
C
C   HFUN          NAME OF A FUNCTION SUBROUTINE.  THIS IS ONE FACTOR OF
C                 THE INTEGRAND FUNCTION. THE OTHER FACTOR IS GPER BELOW
C
C   GPER          NAME OF A FUNCTION SUBROUTINE.  THIS IS THE
C                 CO-FACTOR OF HFUN IN THE INTEGRAND FUNCTION.
C                 GPER MUST BE PERIODIC WITH PERIOD COINCIDING WITH THE
C                 INPUT PARAMETER, PERIOD ABOVE. (SEE NOTE 3 BELOW)
C
C
C OUTPUT PARAMETERS:
C
C   WORK(NDIM1,NDIM2)    HOLDS COMPLETED FINITE AVERAGE TABLE
C
C   SAVPER( )         ARRAY TO SAVE FUNCTION VALUES OF GPER.
C                     DIMENSION NOT LESS THAN 2*IABS(NQUAD)
C
C
C   WEIGHT( )         ARRAY TO HOLD WEIGHTS FOR GAUSSIAN QUADRATURE
C                     DIMENSION NOT LESS THAN MAX(1,-NQUAD)
C
C   ABSCIS( )         ARRAY TO HOLD ABSCISSAS FOR GAUSSIAN QUADRATURE
C                     DIMENSION NOT LESS THAN MAX(1,-NQUAD)
C
C   QLIST(100)        ARRAY TO HOLD THE RESULT OF EACH QUADRATURE
C
C   RESULT            OVERALL RESULT OF THE INTEGRATION
C
C   ISTATE(6)         VECTOR OF INTEGERS GIVES STATUS OF RESULT
C
C     ISTATE(1)       AN INDICATOR WARNING ABOUT SUSPICIOUS RESULTS -
C                     ZERO:      THE RUN WAS APPARENTLY SUCCESSFUL.
C                     POSITIVE:  THE RUN WAS APPARENTLY SUCCESSFUL , BUT
C                                THERE ARE UNSATISFACTORY FEATURES OF
C                                POSSIBLE INTEREST TO THE SOPHISTICATED
C                                USER
C                     NEGATIVE:  UNSUCCESSFUL RUN - DISREGARD THE RESULT
C                     SEE NOTES BELOW FOR COMPLETE SPECIFICATION
C     ISTATE(2)       LSIGCH - INDICATES LAST INTERVAL IN WHICH THE SIGN
C                                OF THE INTEGRAL COINCIDED WITH THAT OF
C                                THE INTEGRAL OVER THE PREVIOUS INTERVAL
C                                SEE NOTE 4 BELOW.
C     ISTATE(3)       NOW  - THE NUMBER OF FINITE INTEGRALS, QLIST(Q),
C                                EVALUATED IN THE CALCULATION.
C     ISTATE(4)       NCOL - THE COLUMN OF THE FINITE AVERAGE TABLE,
C                                (WORK), ON WHICH THE  RESULT IS BASED.
C     ISTATE(5)       NROW - THE ROW OF THE FINITE AVERAGE TABLE,
C                                (WORK), ON WHICH THE  RESULT IS BASED.
C     ISTATE(6)       NCOUNT - THE NUMBER OF CALLS TO FUNCTION HFUN.
C
C
C
C  NOTE 1
C
C  RFIRST
C     THIS ALLOWS THE USER TO LOCATE HIS SUBDIVISION.  FOR CAUTIOUS
C  RUNNING, ARRANGE RFIRST TO COINCIDE WITH AN "ULTIMATE ZERO".  FOR
C  SLIGHTLY MORE ADVENTUROUS BUT LESS RELIABLE RUNNING, ARRANGE
C  RFIRST TO COINCIDE WITH AN "ULTIMATE" PEAK.  OTHERWISE, SET
C  RFIRST < AZERO, IN WHICH CASE, OSCINT USES AZERO INSTEAD OF  RFIRST.
C
C
C  NOTE 2
C
C  GAUSS
C     THIS IS THE NAME OF A USER-PROVIDED SUBROUTINE OF THE FORM
C          GAUSS(ITYPE,A,B,C,D,N,WEIGHT(N),ABS(N)CIS,IFAIL)
C  IT IS CALLED ONLY WHEN NQUAD IS NEGATIVE WITH N = -NQUAD.  IT
C  RETURNS A SET OF WEIGHTS AND ABSCISSAS, SUITABLE FOR INTEGRATION
C  OVER THE INTERVAL (-1,1).
C     THE FIRST FIVE INPUT PARAMETERS OF GAUSS SHOULD BE IGNORED.
C  IFAIL MAY BE USED FOR A WARNING MESSAGE.  IF GAUSS RETURNS
C  IFAIL .NE. 0, OSCINT ABORTS, SETTING ISTATE(1) = -4000.
C     THE USER WHO HAS THE NAG LIBRARY AVAILABLE MAY SET GAUSS = D01BCF.
C
C
C  NOTE 3
C
C  HFUN AND GPER
C     ONE MAY ALWAYS USE HFUN FOR THE INTEGRAND FUNCTION, F(X), AND
C  CODE GPER TO RETURN THE VALUE 1.0D0.  HOWEVER, WHEN F(X) HAS A
C  PERIODIC FACTOR, J(X), REPETITIVE EVALUATION OF J(X) IN EACH
C  INTERVAL MAY BE AVOIDED BY SETTING GPER = J(X) AND HFUN = H(X).
C  THE ROUTINE CHECKS THAT GPER IS INDEED PERIODIC BY MAKING SOME
C  EVALUATIONS IN THE THIRD, FOURTH, AND FIFTH INTERVALS.  IF IT
C  FINDS GPER IS NOT PERIODIC, IT TERMINATES WITH  ISTATE(1) = -5000.
C  IF PERIOD <= 10**-5 , THE ROUTINE TERMINATES WITH ISTATE(1) = -3000.
C
C
C  NOTE 4
C
C  TERMINATION
C     IN THIS NOTE, THE "NORMAL SIGN CHANGE PATTERN" IS ONE IN WHICH
C  SUCCESSIVE VALUES OF QLIST(Q) OSCILLATE IN SIGN.  THE "GRACE
C  PERIOD" IS Q<=10 WHEN THE NORMAL SIGN CHANGE PATTERN IS NOT
C  INSISTED ON.  LSIGCH IS THE HIGHEST VALUE OF Q FOR WHICH
C  QLIST(Q)*QLIST(Q-1) IS POSITIVE.  TERMINATION COMES ABOUT
C  AFTER CALCULATING QLIST(NOW), WHEN EITHER
C
C  (A)  AN APPROXIMATION OF SUFFICIENT ACCURACY IS CURRENTLY AVAIL-
C       ABLE  (THE ROUTINE SETS ISTATE(1) = MAX(0,4-(NOW-LSIGCH))
C  OR
C
C  (B)  THE NORMAL SIGN CHANGE PATTERN IS VIOLATED AFTER THE GRACE
C       PERIOD.   (THE ROUTINE SETS ISTATE(1) = -200)
C   OR
C
C  (C)  THE USER SET LIMIT, NMAX, OF INTERVALS HAVE BEEN CALCULATED
C       I.E.  NOW = NMAX.  (THE ROUTINE SETS ISTATE(1) = -100)
C
C     THE ROUTINE CHECKS (A), THEN (B), AND THEN (C).  TERMINATION
C  UNDER (A) MAY OCCUR WITHOUT ANY NORMAL SIGN CHANGE PATTERN
C  EMERGING.  THIS MAY BE DUE TO MISUSE OF THE ROUTINE, BUT THE
C  PROBLEM IS SMALL ENOUGH TO BE CORRECTLY HANDLED.  IN THIS CASE,
C  ISTATE(1) = MAX(0,4-(NOW-LSIGCH)) MAY BE A SMALL POSITIVE  INTEGER.
C
C
C  NOTE 5
C
C  VARIABLE DIMENSIONS AND STORAGE ECONOMY
C     THE PROGRAM WHICH CALLS OSCINT HAS TO PROVIDE NUMERICAL VALUES
C  OF THE INPUT PARAMETERS NQUAD, NDIM1 AND NDIM2. IT MUST ALSO
C  INCLUDE A DIMENSION STATEMENT IN WHICH THE FIRST FIVE AND THE
C  LAST OUTPUT PARAMETERS OF OSCINT ARE DIMENSIONED.  NOTE THAT THE
C  DIMENSIONS OF WEIGHT AND ABSCIS ARE BOTH AT LEAST 1 WHEN NQUAD
C  IS POSITIVE AND AT LEAST -NQUAD OTHERWISE.  HOWEVER, THE
C  DIMENSION OF SAVPER IS AT LEAST 2*ABS(NQUAD) REGARDLESS OF THE
C  SIGN OF NQUAD.
C     GENERALLY, THESE VARIABLE DIMENSION STATEMENTS ALLOW ECONOMIC
C  USE OF STORAGE.  THERE IS ONE FURTHER STORAGE SAVING FEATURE.
C  WHEN NDIM1 = 10, THE ROUTINE CARRIES OUT THE SAME CALCULATION
C  AS IT WOULD IF NDIM1 = 100.  HOWEVER, INSTEAD OF USING A WORK
C  ARRAY OF DIMENSION (100,NDIM2), IT USES A WORK ARRAY OF DIMENSION
C  (10,NDIM2) AND OVERWRITES IT, AS AND WHEN NECESSARY, AS THE
C  CALCULATION PROCEEDS. IN THIS CASE, OSCINT BEHAVES AS IF NDIM2 WERE
C  REPLACED BY  MIN(20,NDIM2).
C     SOME OBVIOUS ERRORS IN DIMENSIONING, SUCH AS NEGATIVE
C  DIMENSIONS, CAUSE THE ROUTINE TO TERMINATE WITH
C         ISTATE(1) = -6000
C  HOWEVER, INADEQUATE DIMENSIONING IN THE CALLING PROGRAM MAY GO
C  UNDETECTED AND MAY LEAD TO RANDOM OR CHAOTIC OUTPUT.
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION WORK(NDIM1,NDIM2),QLIST(100),ISTATE(6)
      DIMENSION SAVPER(*),WEIGHT(*),ABSCIS(*)
      EXTERNAL GAUSS,HFUN,GPER

      HASPER = .5D0*PERIOD
      WMIN = 1.0D0
      DO 10 I = 1,6
         ISTATE(I) = 0
   10 CONTINUE
      IF (NQUAD.EQ.0 .OR. NQUAD.EQ.1 .OR. NDIM1.LT.1 .OR. NDIM2.LT.
     .    1) ISTATE(1) = -6000
      IF (PERIOD.LT.10.0D-5) ISTATE(1) = -5000
      IF (ISTATE(1).LT.0) GO TO 130
      IF (NDIM1.EQ.10) THEN
          NMAX = 100

      ELSE
          NMAX = MIN(100,NDIM1)
      END IF

      JP = 0
      S = 0.0D0
C
C      LOOP TO CONSTRUCT TABLE
C
   20 CONTINUE
      IF (JP.EQ.NMAX) ISTATE(1) = -100
      IF (ISTATE(1).NE.0) GO TO 50
C
      K = 0
      JP = JP + 1
      J = MIN(JP,NDIM2)
      IF (NDIM1.EQ.10) J = MIN(J,20)
   30 IF (K.LT.J) THEN
          K = K + 1
          IF (NDIM1.EQ.10) THEN
              MJ = MOD(JP,10)
              MJM2 = MOD(JP-2,10)
              MJ1 = MOD(JP-K+1,10)
              MJ2 = MOD(JP-K+2,10)
              MJK = MOD(JP-K,10)
              IF (MJ.EQ.0) MJ = 10
              IF (MJM2.EQ.0) MJM2 = 10
              IF (MJ1.EQ.0) MJ1 = 10
              IF (MJ2.EQ.0) MJ2 = 10
              IF (MJK.EQ.0) MJK = 10

          ELSE
              MJ = JP
              MJM2 = JP - 2
              MJ1 = JP - K + 1
              MJ2 = JP - K + 2
              MJK = JP - K
          END IF

          IF (K.EQ.1) THEN
              WORK(MJ,K) = QRULE(JP-1,AZERO,HASPER,RFIRST,NQUAD,NDIM1,
     .                     NDIM2,GAUSS,HFUN,GPER,SAVPER,WEIGHT,ABSCIS,
     .                     QLIST,ISTATE)

          ELSE
              WORK(MJ1,K) = (WORK(MJ1,K-1)+WORK(MJ2,K-1))/2.0D0
              IF (DABS(WORK(MJ1,K)).LT.WMIN) THEN
                  WMIN = DABS(WORK(MJ1,K))
                  NOW = K
                  NROW = MJ1
                  NOWJP = JP
              END IF

              CURR = ABS(WORK(MJ1,K))
              PREV = ABS(WORK(MJK,K))
              IF (JP.NE.K) THEN
                  IF ((CURR.LT.EPS) .AND. (PREV.LT.EPS)) THEN
                      NOW = K
                      NROW = MJ1
                      NOWJP = JP
                      GO TO 50

                  END IF

              END IF

          END IF

   40     GO TO 30

      END IF

      GO TO 20
C
   50 CONTINUE
      DO 60 I = 1,NOWJP - NOW
         S = S + QLIST(I)
   60 CONTINUE
      IF (NDIM1.NE.10) GO TO 110
      NROUND = NOW - 10
      IF (NROUND.LE.0) NROUND = 0
      IF (NROUND.LE.0) GO TO 110
C
      DO 70 I = NOWJP - NOW + 1,NOWJP - 10
         S = S + QLIST(I)
   70 CONTINUE
      ISUB = NOWJP - 9
   80 IF (ISUB.GT.10) ISUB = ISUB - 10
      IF (ISUB.GT.10) GO TO 80
      DO 90 J = 1,NROUND
         S = S + WORK(ISUB,J)/2.0D0
   90 CONTINUE
      DO 100 I = NROW,NROW + NROUND - 1
         II = I
         IF (I.GT.10) II = I - 10
         S = S - WORK(II,NROUND+1)
  100 CONTINUE
C
  110 DO 120 J = NROUND + 1,NOW - 1
         S = S + WORK(NROW,J)/2.0D0
  120 CONTINUE
      S = S + WORK(NROW,NOW)
      RESULT = S
      ISTATE(3) = JP
      ISTATE(4) = NOW
      ISTATE(5) = NROW
      NML = ISTATE(3) - ISTATE(2)
      IF (NML.LT.4 .AND. ISTATE(1).EQ.0) ISTATE(1) = MAX(0,4-NML)
  130 CONTINUE
      RETURN
      END
C
C ******** END OF OSCINT *********
C
C
C
C *********** BEGIN FUNCTION QRULE ************
C
      FUNCTION QRULE(J,AZERO,HASPER,RFIRST,NQUAD,NDIM1,NDIM2,GAUSS,HFUN,
     .               GPER,SAVPER,WEIGHT,ABSCIS,QLIST,ISTATE)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C          THIS ROUTINE EVALUATES THE INTEGRAL OF THE FUNCTION,
C     HFUN(X)*GPER(X) OVER THE INTERVAL (A,B) WHERE:
C
C          GENERALLY (J>0)     A = PREVIOUS VALUE OF B
C                              B = A + HASPER
C                    (J=0)     A = AZERO
C                              B = RFIRST WHEN RFIRST > AZERO
C                              B = AZERO + HASPER WHEN RFIRST <= AZERO
C
C
C      INPUT PARAMETERS:
C
C               J                  DEFINES WHICH TERM, QLIST(J), OF
C                                  THE SERIES IS BEING EVALUATED
C
C               HASPER             HALF THE PERIOD
C
C
C      OTHER INPUT AND OUTPUT PARAMETERS ARE IDENTICAL TO THOSE IN
C      OSCINT (DESCRIBED ABOVE).
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      SAVEB,TENDPT
      EXTERNAL GAUSS,HFUN,GPER

      DIMENSION QLIST(100),ISTATE(6)
      DIMENSION SAVPER(*),WEIGHT(*),ABSCIS(*)
C
      NPTS = ABS(NQUAD)
C
      IF (J.EQ.0) THEN
          INDEX = 0
          DO 10 I = 1,100
             QLIST(I) = 0.0D0
   10     CONTINUE
C        CALL GAUSS IF NQUAD < 0
          IF (NQUAD.LT.0) THEN
              ITYPE = 0
              AA = -1.0D0
              BB = 1.0D0
              CC = 0.0D0
              DD = 0.0D0
              IFAIL = 0
              CALL GAUSS(ITYPE,AA,BB,CC,DD,NPTS,WEIGHT,ABSCIS,IFAIL)
              IF (IFAIL.NE.0) THEN
                  ISTATE(1) = -4000
                  GO TO 40

              END IF

          END IF

      END IF

      QRULE = 0.0D0
C
C     SET INTERVAL ENDPOINTS, A AND B
      IF (J.NE.0) THEN
          A = B

      ELSE
          A = AZERO
      END IF

      IF (RFIRST.LE.AZERO .OR. J.NE.0) THEN
          B = A + HASPER

      ELSE
          B = RFIRST
      END IF
C
C     LOOP ON ABSCISSAS FOR INTERVAL #J - STARTS TO CALCULATE QRULE
      DO 30 I = 1,NPTS
         XI = I
C
C        CALCULATE ABSCISSA Y
         IF (NQUAD.LT.0) THEN
             Y = (B-A)*ABSCIS(I)/2.0D0 + (B+A)/2.0D0
             WT = WEIGHT(I)

         ELSE
             Y = ((XI-1)*B+A* (NPTS-I))/ (NPTS-1)
             WT = 1.0D0
         END IF
C
C        IELM IS LOCATION IN SAVPER FOR GPER FUNCTION VALUES
C        J=0: IGNORES. J=1,2: WHERE TO PUT VALUE. J>2: WHERE TO GET
C        VALUE FROM
         IELM = NPTS*MOD(J-1,2) + I
C
         IF (J.GT.0 .AND. I.EQ.1 .AND. NQUAD.GT.0) GO TO 20
         IF (J.EQ.0) THEN
             FUN = HFUN(Y)*GPER(Y)

         ELSE IF (J.LT.3) THEN
             SAVPER(IELM) = GPER(Y)
C           CHECK FOR CONSTANT FUNCTION
             IF (SAVPER(IELM).EQ.SAVPER(1)) INDEX = INDEX + 1
             IF (DABS(SAVPER(IELM)).GT.DABS(SAVPER(IELM-1))) THEN
                 GMAX = DABS(SAVPER(IELM))
             END IF

             FUN = HFUN(Y)*SAVPER(IELM)

         ELSE IF (J.LT.5) THEN
C           CHECK THAT GPER IS PERIODIC WITH PERIOD=PERIOD
             DIFF = DABS(SAVPER(IELM)-GPER(Y))
             IF (DIFF.LT.GMAX*1.0D-5) THEN
                 FUN = HFUN(Y)*SAVPER(IELM)

             ELSE
                 ISTATE(1) = -3000
             END IF

         ELSE
             IF (INDEX.EQ.2*NPTS) THEN
                 FUN = HFUN(Y)

             ELSE
                 FUN = HFUN(Y)*SAVPER(IELM)
             END IF

         END IF

         ISTATE(6) = ISTATE(6) + 1
C
   20    CONTINUE
         IF (NQUAD.GT.0) THEN
             IF (I.EQ.1) THEN
                 IF (J.EQ.0) FUN = FUN/2.0D0
                 IF (J.GT.0) FUN = TENDPT
             END IF

             IF (I.EQ.NPTS) THEN
                 FUN = FUN/2.0D0
                 TENDPT = FUN
             END IF

             QRULE = QRULE + FUN

         ELSE
             QRULE = QRULE + WT*FUN
         END IF
C
   30 CONTINUE
C     LOOP ON ABSCISSA FOR INTERVAL #J ENDS
      IF (INDEX.EQ.2*NPTS .AND. SAVPER(1).NE.1) THEN
          QRULE = QRULE*SAVPER(1)
      END IF

      IF (NQUAD.GT.0) WSUM = NPTS - 1
      IF (NQUAD.LT.0) WSUM = 2.0D0
      QRULE = QRULE* (B-A)/WSUM
      QLIST(J+1) = QRULE
C
      IF (QRULE*QLIST(J).GT.0) ISTATE(2) = J
      IF (ISTATE(2).GT.9) ISTATE(1) = -200
C
   40 CONTINUE
C
      RETURN
      END
