*DECK DRC
      DOUBLE PRECISION FUNCTION DRC (X, Y, IER)
C***BEGIN PROLOGUE  DRC
C***PURPOSE  Calculate a double precision approximation to
C             DRC(X,Y) = Integral from zero to infinity of
C                              -1/2     -1
C                    (1/2)(t+X)    (t+Y)  dt,
C            where X is nonnegative and Y is positive.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      DOUBLE PRECISION (RC-S, DRC-D)
C***KEYWORDS  DUPLICATION THEOREM, ELEMENTARY FUNCTIONS,
C             ELLIPTIC INTEGRAL, TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     DRC
C          Standard FORTRAN function routine
C          Double precision version
C          The routine calculates an approximation result to
C          DRC(X,Y) = integral from zero to infinity of
C
C                              -1/2     -1
C                    (1/2)(t+X)    (t+Y)  dt,
C
C          where X is nonnegative and Y is positive.  The duplication
C          theorem is iterated until the variables are nearly equal,
C          and the function is then expanded in Taylor series to fifth
C          order.  Logarithmic, inverse circular, and inverse hyper-
C          bolic functions can be expressed in terms of DRC.
C
C   2.     Calling Sequence
C          DRC( X, Y, IER )
C
C          Parameters On Entry
C          Values assigned by the calling routine
C
C          X      - Double precision, nonnegative variable
C
C          Y      - Double precision, positive variable
C
C
C
C          On Return  (values assigned by the DRC routine)
C
C          DRC    - Double precision approximation to the integral
C
C          IER    - Integer to indicate normal or abnormal termination.
C
C                     IER = 0 Normal and reliable termination of the
C                             routine.  It is assumed that the requested
C                             accuracy has been achieved.
C
C                     IER > 0 Abnormal termination of the routine
C
C          X and Y are unaltered.
C
C   3.    Error messages
C
C         Value of IER assigned by the DRC routine
C
C                  Value assigned         Error message printed
C                  IER = 1                X.LT.0.0D0.OR.Y.LE.0.0D0
C                      = 2                X+Y.LT.LOLIM
C                      = 3                MAX(X,Y) .GT. UPLIM
C
C   4.     Control parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X and Y
C
C          LOLIM  - Lower limit of valid arguments
C
C                   Not less  than 5 * (machine minimum)  .
C
C          UPLIM  - Upper limit of valid arguments
C
C                   Not greater than (machine maximum) / 5 .
C
C
C                     Acceptable values for:   LOLIM       UPLIM
C                     IBM 360/370 SERIES   :   3.0D-78     1.0D+75
C                     CDC 6000/7000 SERIES :   1.0D-292    1.0D+321
C                     UNIVAC 1100 SERIES   :   1.0D-307    1.0D+307
C                     CRAY                 :   2.3D-2466   1.0D+2465
C                     VAX 11 SERIES        :   1.5D-38     3.0D+37
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C          ERRTOL  - relative error due to truncation is less than
C                    16 * ERRTOL ** 6 / (1 - 2 * ERRTOL).
C
C
C              The accuracy of the computed approximation to the inte-
C              gral can be controlled by choosing the value of ERRTOL.
C              Truncation of a Taylor series after terms of fifth order
C              introduces an error less than the amount shown in the
C              second column of the following table for each value of
C              ERRTOL in the first column.  In addition to the trunca-
C              tion error there will be round-off error, but in prac-
C              tice the total error from both sources is usually less
C              than the amount given in the table.
C
C
C
C          Sample choices:  ERRTOL   Relative truncation
C                                    error less than
C                           1.0D-3    2.0D-17
C                           3.0D-3    2.0D-14
C                           1.0D-2    2.0D-11
C                           3.0D-2    2.0D-8
C                           1.0D-1    2.0D-5
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   DRC special comments
C
C
C
C
C                  Check: DRC(X,X+Z) + DRC(Y,Y+Z) = DRC(0,Z)
C
C                  where X, Y, and Z are positive and X * Y = Z * Z
C
C
C          On Input:
C
C          X, and Y are the variables in the integral DRC(X,Y).
C
C          On Output:
C
C          X and Y are unaltered.
C
C
C
C                    DRC(0,1/4)=DRC(1/16,1/8)=PI=3.14159...
C
C                    DRC(9/4,2)=LN(2)
C
C
C
C          ********************************************************
C
C          WARNING: Changes in the program may improve speed at the
C                   expense of robustness.
C
C
C   --------------------------------------------------------------------
C
C   Special functions via DRC
C
C
C
C                  LN X                X .GT. 0
C
C                                             2
C                  LN(X) = (X-1) DRC(((1+X)/2)  , X )
C
C
C   --------------------------------------------------------------------
C
C                  ARCSIN X            -1 .LE. X .LE. 1
C
C                                       2
C                  ARCSIN X = X DRC (1-X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCCOS X            0 .LE. X .LE. 1
C
C
C                                     2       2
C                  ARCCOS X = SQRT(1-X ) DRC(X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCTAN X            -INF .LT. X .LT. +INF
C
C                                        2
C                  ARCTAN X = X DRC(1,1+X  )
C
C   --------------------------------------------------------------------
C
C                  ARCCOT X            0 .LE. X .LT. INF
C
C                                  2   2
C                  ARCCOT X = DRC(X  ,X +1 )
C
C   --------------------------------------------------------------------
C
C                  ARCSINH X           -INF .LT. X .LT. +INF
C
C                                       2
C                  ARCSINH X = X DRC(1+X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCCOSH X           X .GE. 1
C
C                                    2         2
C                  ARCCOSH X = SQRT(X -1) DRC(X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCTANH X           -1 .LT. X .LT. 1
C
C                                         2
C                  ARCTANH X = X DRC(1,1-X  )
C
C   --------------------------------------------------------------------
C
C                  ARCCOTH X           X .GT. 1
C
C                                   2   2
C                  ARCCOTH X = DRC(X  ,X -1 )
C
C   --------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC))
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DRC
      CHARACTER*16 XERN3, XERN4, XERN5
      INTEGER IER
      DOUBLE PRECISION C1, C2, ERRTOL, LAMDA, LOLIM, D1MACH
      DOUBLE PRECISION MU, S, SN, UPLIM, X, XN, Y, YN
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  DRC
      IF (FIRST) THEN
         ERRTOL = (D1MACH(3)/16.0D0)**(1.0D0/6.0D0)
         LOLIM  = 5.0D0 * D1MACH(1)
         UPLIM  = D1MACH(2) / 5.0D0
C
         C1 = 1.0D0/7.0D0
         C2 = 9.0D0/22.0D0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      DRC = 0.0D0
      IF (X.LT.0.0D0.OR.Y.LE.0.0D0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         CALL XERMSG ('SLATEC', 'DRC',
     *      'X.LT.0 .OR. Y.LE.0 WHERE X = ' // XERN3 // ' AND Y = ' //
     *      XERN4, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'DRC',
     *      'MAX(X,Y).GT.UPLIM WHERE X = '  // XERN3 // ' Y = ' //
     *      XERN4 // ' AND UPLIM = ' // XERN5, 3, 1)
         RETURN
      ENDIF
C
      IF (X+Y.LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'DRC',
     *      'X+Y.LT.LOLIM WHERE X = ' // XERN3 // ' Y = ' // XERN4 //
     *      ' AND LOLIM = ' // XERN5, 2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
C
   30 MU = (XN+YN+YN)/3.0D0
      SN = (YN+MU)/MU - 2.0D0
      IF (ABS(SN).LT.ERRTOL) GO TO 40
      LAMDA = 2.0D0*SQRT(XN)*SQRT(YN) + YN
      XN = (XN+LAMDA)*0.250D0
      YN = (YN+LAMDA)*0.250D0
      GO TO 30
C
   40 S = SN*SN*(0.30D0+SN*(C1+SN*(0.3750D0+SN*C2)))
      DRC = (1.0D0+S)/SQRT(MU)
      RETURN
      END
*DECK DRC3JJ
      SUBROUTINE DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM,
     +   IER)
C***BEGIN PROLOGUE  DRC3JJ
C***PURPOSE  Evaluate the 3j symbol f(L1) = (  L1   L2 L3)
C                                           (-M2-M3 M2 M3)
C            for all allowed values of L1, the other parameters
C            being held fixed.
C***LIBRARY   SLATEC
C***CATEGORY  C19
C***TYPE      DOUBLE PRECISION (RC3JJ-S, DRC3JJ-D)
C***KEYWORDS  3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS,
C             RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS,
C             WIGNER COEFFICIENTS
C***AUTHOR  Gordon, R. G., Harvard University
C           Schulten, K., Max Planck Institute
C***DESCRIPTION
C
C *Usage:
C
C        DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
C        INTEGER NDIM, IER
C
C        CALL DRC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER)
C
C *Arguments:
C
C     L2 :IN      Parameter in 3j symbol.
C
C     L3 :IN      Parameter in 3j symbol.
C
C     M2 :IN      Parameter in 3j symbol.
C
C     M3 :IN      Parameter in 3j symbol.
C
C     L1MIN :OUT  Smallest allowable L1 in 3j symbol.
C
C     L1MAX :OUT  Largest allowable L1 in 3j symbol.
C
C     THRCOF :OUT Set of 3j coefficients generated by evaluating the
C                 3j symbol for all allowed values of L1.  THRCOF(I)
C                 will contain f(L1MIN+I-1), I=1,2,...,L1MAX+L1MIN+1.
C
C     NDIM :IN    Declared length of THRCOF in calling program.
C
C     IER :OUT    Error flag.
C                 IER=0 No errors.
C                 IER=1 Either L2.LT.ABS(M2) or L3.LT.ABS(M3).
C                 IER=2 Either L2+ABS(M2) or L3+ABS(M3) non-integer.
C                 IER=3 L1MAX-L1MIN not an integer.
C                 IER=4 L1MAX less than L1MIN.
C                 IER=5 NDIM less than L1MAX-L1MIN+1.
C
C *Description:
C
C     Although conventionally the parameters of the vector addition
C  coefficients satisfy certain restrictions, such as being integers
C  or integers plus 1/2, the restrictions imposed on input to this
C  subroutine are somewhat weaker. See, for example, Section 27.9 of
C  Abramowitz and Stegun or Appendix C of Volume II of A. Messiah.
C  The restrictions imposed by this subroutine are
C       1. L2 .GE. ABS(M2) and L3 .GE. ABS(M3);
C       2. L2+ABS(M2) and L3+ABS(M3) must be integers;
C       3. L1MAX-L1MIN must be a non-negative integer, where
C          L1MAX=L2+L3 and L1MIN=MAX(ABS(L2-L3),ABS(M2+M3)).
C  If the conventional restrictions are satisfied, then these
C  restrictions are met.
C
C     The user should be cautious in using input parameters that do
C  not satisfy the conventional restrictions. For example, the
C  the subroutine produces values of
C       f(L1) = ( L1  2.5  5.8)
C               (-0.3 1.5 -1.2)
C  for L1=3.3,4.3,...,8.3 but none of the symmetry properties of the 3j
C  symbol, set forth on page 1056 of Messiah, is satisfied.
C
C     The subroutine generates f(L1MIN), f(L1MIN+1), ..., f(L1MAX)
C  where L1MIN and L1MAX are defined above. The sequence f(L1) is
C  generated by a three-term recurrence algorithm with scaling to
C  control overflow. Both backward and forward recurrence are used to
C  maintain numerical stability. The two recurrence sequences are
C  matched at an interior point and are normalized from the unitary
C  property of 3j coefficients and Wigner's phase convention.
C
C    The algorithm is suited to applications in which large quantum
C  numbers arise, such as in molecular dynamics.
C
C***REFERENCES  1. Abramowitz, M., and Stegun, I. A., Eds., Handbook
C                  of Mathematical Functions with Formulas, Graphs
C                  and Mathematical Tables, NBS Applied Mathematics
C                  Series 55, June 1964 and subsequent printings.
C               2. Messiah, Albert., Quantum Mechanics, Volume II,
C                  North-Holland Publishing Company, 1963.
C               3. Schulten, Klaus and Gordon, Roy G., Exact recursive
C                  evaluation of 3j and 6j coefficients for quantum-
C                  mechanical coupling of angular momenta, J Math
C                  Phys, v 16, no. 10, October 1975, pp. 1961-1970.
C               4. Schulten, Klaus and Gordon, Roy G., Semiclassical
C                  approximations to 3j  and 6j coefficients for
C                  quantum-mechanical coupling of angular momenta,
C                  J Math Phys, v 16, no. 10, October 1975,
C                  pp. 1971-1988.
C               5. Schulten, Klaus and Gordon, Roy G., Recursive
C                  evaluation of 3j and 6j coefficients, Computer
C                  Phys Comm, v 11, 1976, pp. 269-278.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   880515  SLATEC prologue added by G. C. Nielson, NBS; parameters
C           HUGE and TINY revised to depend on D1MACH.
C   891229  Prologue description rewritten; other prologue sections
C           revised; LMATCH (location of match point for recurrences)
C           removed from argument list; argument IER changed to serve
C           only as an error flag (previously, in cases without error,
C           it returned the number of scalings); number of error codes
C           increased to provide more precise error information;
C           program comments revised; SLATEC error handler calls
C           introduced to enable printing of error messages to meet
C           SLATEC standards. These changes were done by D. W. Lozier,
C           M. A. McClain and J. M. Smith of the National Institute
C           of Standards and Technology, formerly NBS.
C   910415  Mixed type expressions eliminated; variable C1 initialized;
C           description of THRCOF expanded. These changes were done by
C           D. W. Lozier.
C***END PROLOGUE  DRC3JJ
C
      INTEGER NDIM, IER
      DOUBLE PRECISION L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
C
      INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM,
     +        NSTEP2
      DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH,
     +                 DENOM, DV, EPS, HUGE, L1, M1, NEWFAC, OLDFAC,
     +                 ONE, RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1,
     +                 SUM2, SUMBAC, SUMFOR, SUMUNI, THREE, THRESH,
     +                 TINY, TWO, X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO
C
      DATA  ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/
C
C***FIRST EXECUTABLE STATEMENT  DRC3JJ
      IER=0
C  HUGE is the square root of one twentieth of the largest floating
C  point number, approximately.
      HUGE = SQRT(D1MACH(2)/20.0D0)
      SRHUGE = SQRT(HUGE)
      TINY = 1.0D0/HUGE
      SRTINY = 1.0D0/SRHUGE
C
C     LMATCH = ZERO
      M1 = - M2 - M3
C
C  Check error conditions 1 and 2.
      IF((L2-ABS(M2)+EPS.LT.ZERO).OR.
     +   (L3-ABS(M3)+EPS.LT.ZERO))THEN
         IER=1
         CALL XERMSG('SLATEC','DRC3JJ','L2-ABS(M2) or L3-ABS(M3) '//
     +      'less than zero.',IER,1)
         RETURN
      ELSEIF((MOD(L2+ABS(M2)+EPS,ONE).GE.EPS+EPS).OR.
     +   (MOD(L3+ABS(M3)+EPS,ONE).GE.EPS+EPS))THEN
         IER=2
         CALL XERMSG('SLATEC','DRC3JJ','L2+ABS(M2) or L3+ABS(M3) '//
     +      'not integer.',IER,1)
         RETURN
      ENDIF
C
C
C
C  Limits for L1
C
      L1MIN = MAX(ABS(L2-L3),ABS(M1))
      L1MAX = L2 + L3
C
C  Check error condition 3.
      IF(MOD(L1MAX-L1MIN+EPS,ONE).GE.EPS+EPS)THEN
         IER=3
         CALL XERMSG('SLATEC','DRC3JJ','L1MAX-L1MIN not integer.',IER,1)
         RETURN
      ENDIF
      IF(L1MIN.LT.L1MAX-EPS)   GO TO 20
      IF(L1MIN.LT.L1MAX+EPS)   GO TO 10
C
C  Check error condition 4.
      IER=4
      CALL XERMSG('SLATEC','DRC3JJ','L1MIN greater than L1MAX.',IER,1)
      RETURN
C
C  This is reached in case that L1 can take only one value,
C  i.e. L1MIN = L1MAX
C
   10 CONTINUE
C     LSCALE = 0
      THRCOF(1) = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS) /
     1 SQRT(L1MIN + L2 + L3 + ONE)
      RETURN
C
C  This is reached in case that L1 takes more than one value,
C  i.e. L1MIN < L1MAX.
C
   20 CONTINUE
C     LSCALE = 0
      NFIN = INT(L1MAX-L1MIN+ONE+EPS)
      IF(NDIM-NFIN)  21, 23, 23
C
C  Check error condition 5.
   21 IER = 5
      CALL XERMSG('SLATEC','DRC3JJ','Dimension of result array for '//
     +            '3j coefficients too small.',IER,1)
      RETURN
C
C
C  Starting forward recursion from L1MIN taking NSTEP1 steps
C
   23 L1 = L1MIN
      NEWFAC = 0.0D0
      C1 = 0.0D0
      THRCOF(1) = SRTINY
      SUM1 = (L1+L1+ONE) * TINY
C
C
      LSTEP = 1
   30 LSTEP = LSTEP + 1
      L1 = L1 + ONE
C
C
      OLDFAC = NEWFAC
      A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE)
      A2 = (L1+M1) * (L1-M1)
      NEWFAC = SQRT(A1*A2)
      IF(L1.LT.ONE+EPS)   GO TO 40
C
C
      DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2)
      DENOM = (L1-ONE) * NEWFAC
C
      IF(LSTEP-2)  32, 32, 31
C
   31 C1OLD = ABS(C1)
   32 C1 = - (L1+L1-ONE) * DV / DENOM
      GO TO 50
C
C  If L1 = 1, (L1-1) has to be factored out of DV, hence
C
   40 C1 = - (L1+L1-ONE) * L1 * (M3-M2) / NEWFAC
C
   50 IF(LSTEP.GT.2)   GO TO 60
C
C
C  If L1 = L1MIN + 1, the third term in the recursion equation vanishes,
C  hence
      X = SRTINY * C1
      THRCOF(2) = X
      SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1*C1
      IF(LSTEP.EQ.NFIN)   GO TO 220
      GO TO 30
C
C
   60 C2 = - L1 * OLDFAC / DENOM
C
C  Recursion to the next 3j coefficient X
C
      X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2)
      THRCOF(LSTEP) = X
      SUMFOR = SUM1
      SUM1 = SUM1 + (L1+L1+ONE) * X*X
      IF(LSTEP.EQ.NFIN)   GO TO 100
C
C  See if last unnormalized 3j coefficient exceeds SRHUGE
C
      IF(ABS(X).LT.SRHUGE)   GO TO 80
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(1), ... , THRCOF(LSTEP)
C  has to be rescaled to prevent overflow
C
C     LSCALE = LSCALE + 1
      DO 70 I=1,LSTEP
      IF(ABS(THRCOF(I)).LT.SRTINY)   THRCOF(I) = ZERO
   70 THRCOF(I) = THRCOF(I) / SRHUGE
      SUM1 = SUM1 / HUGE
      SUMFOR = SUMFOR / HUGE
      X = X / SRHUGE
C
C  As long as ABS(C1) is decreasing, the recursion proceeds towards
C  increasing 3j values and, hence, is numerically stable.  Once
C  an increase of ABS(C1) is detected, the recursion direction is
C  reversed.
C
   80 IF(C1OLD-ABS(C1))   100, 100, 30
C
C
C  Keep three 3j coefficients around LMATCH for comparison with
C  backward recursion.
C
  100 CONTINUE
C     LMATCH = L1 - 1
      X1 = X
      X2 = THRCOF(LSTEP-1)
      X3 = THRCOF(LSTEP-2)
      NSTEP2 = NFIN - LSTEP + 3
C
C
C
C
C  Starting backward recursion from L1MAX taking NSTEP2 steps, so
C  that forward and backward recursion overlap at three points
C  L1 = LMATCH+1, LMATCH, LMATCH-1.
C
      NFINP1 = NFIN + 1
      NFINP2 = NFIN + 2
      NFINP3 = NFIN + 3
      L1 = L1MAX
      THRCOF(NFIN) = SRTINY
      SUM2 = TINY * (L1+L1+ONE)
C
      L1 = L1 + TWO
      LSTEP = 1
  110 LSTEP = LSTEP + 1
      L1 = L1 - ONE
C
      OLDFAC = NEWFAC
      A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO)
      A2S = (L1+M1-ONE) * (L1-M1-ONE)
      NEWFAC = SQRT(A1S*A2S)
C
      DV = - L2*(L2+ONE) * M1 + L3*(L3+ONE) * M1 + L1*(L1-ONE) * (M3-M2)
C
      DENOM = L1 * NEWFAC
      C1 = - (L1+L1-ONE) * DV / DENOM
      IF(LSTEP.GT.2)   GO TO 120
C
C  If L1 = L1MAX + 1, the third term in the recursion formula vanishes
C
      Y = SRTINY * C1
      THRCOF(NFIN-1) = Y
      SUMBAC = SUM2
      SUM2 = SUM2 + TINY * (L1+L1-THREE) * C1*C1
C
      GO TO 110
C
C
  120 C2 = - (L1 - ONE) * OLDFAC / DENOM
C
C  Recursion to the next 3j coefficient Y
C
      Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP)
C
      IF(LSTEP.EQ.NSTEP2)   GO TO 200
C
      THRCOF(NFINP1-LSTEP) = Y
      SUMBAC = SUM2
      SUM2 = SUM2 + (L1+L1-THREE) * Y*Y
C
C  See if last unnormalized 3j coefficient exceeds SRHUGE
C
      IF(ABS(Y).LT.SRHUGE)   GO TO 110
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(NFIN), ... ,THRCOF(NFIN-LSTEP+1)
C  has to be rescaled to prevent overflow
C
C     LSCALE = LSCALE + 1
      DO 130 I=1,LSTEP
      INDEX = NFIN - I + 1
      IF(ABS(THRCOF(INDEX)).LT.SRTINY)   THRCOF(INDEX) = ZERO
  130 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE
      SUM2 = SUM2 / HUGE
      SUMBAC = SUMBAC / HUGE
C
C
      GO TO 110
C
C
C  The forward recursion 3j coefficients X1, X2, X3 are to be matched
C  with the corresponding backward recursion values Y1, Y2, Y3.
C
  200 Y3 = Y
      Y2 = THRCOF(NFINP2-LSTEP)
      Y1 = THRCOF(NFINP3-LSTEP)
C
C
C  Determine now RATIO such that YI = RATIO * XI  (I=1,2,3) holds
C  with minimal error.
C
      RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 )
      NLIM = NFIN - NSTEP2 + 1
C
      IF(ABS(RATIO).LT.ONE)   GO TO 211
C
      DO 210 N=1,NLIM
  210 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC
      GO TO 230
C
  211 NLIM = NLIM + 1
      RATIO = ONE / RATIO
      DO 212 N=NLIM,NFIN
  212 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC
      GO TO 230
C
  220 SUMUNI = SUM1
C
C
C  Normalize 3j coefficients
C
  230 CNORM = ONE / SQRT(SUMUNI)
C
C  Sign convention for last 3j coefficient determines overall phase
C
      SIGN1 = SIGN(ONE,THRCOF(NFIN))
      SIGN2 = (-ONE) ** INT(ABS(L2+M2-L3+M3)+EPS)
      IF(SIGN1*SIGN2) 235,235,236
  235 CNORM = - CNORM
C
  236 IF(ABS(CNORM).LT.ONE)   GO TO 250
C
      DO 240 N=1,NFIN
  240 THRCOF(N) = CNORM * THRCOF(N)
      RETURN
C
  250 THRESH = TINY / ABS(CNORM)
      DO 251 N=1,NFIN
      IF(ABS(THRCOF(N)).LT.THRESH)   THRCOF(N) = ZERO
  251 THRCOF(N) = CNORM * THRCOF(N)
C
      RETURN
      END
*DECK DRC3JM
      SUBROUTINE DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM,
     +   IER)
C***BEGIN PROLOGUE  DRC3JM
C***PURPOSE  Evaluate the 3j symbol g(M2) = (L1 L2   L3  )
C                                           (M1 M2 -M1-M2)
C            for all allowed values of M2, the other parameters
C            being held fixed.
C***LIBRARY   SLATEC
C***CATEGORY  C19
C***TYPE      DOUBLE PRECISION (RC3JM-S, DRC3JM-D)
C***KEYWORDS  3J COEFFICIENTS, 3J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS,
C             RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS,
C             WIGNER COEFFICIENTS
C***AUTHOR  Gordon, R. G., Harvard University
C           Schulten, K., Max Planck Institute
C***DESCRIPTION
C
C *Usage:
C
C        DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM)
C        INTEGER NDIM, IER
C
C        CALL DRC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER)
C
C *Arguments:
C
C     L1 :IN      Parameter in 3j symbol.
C
C     L2 :IN      Parameter in 3j symbol.
C
C     L3 :IN      Parameter in 3j symbol.
C
C     M1 :IN      Parameter in 3j symbol.
C
C     M2MIN :OUT  Smallest allowable M2 in 3j symbol.
C
C     M2MAX :OUT  Largest allowable M2 in 3j symbol.
C
C     THRCOF :OUT Set of 3j coefficients generated by evaluating the
C                 3j symbol for all allowed values of M2.  THRCOF(I)
C                 will contain g(M2MIN+I-1), I=1,2,...,M2MAX-M2MIN+1.
C
C     NDIM :IN    Declared length of THRCOF in calling program.
C
C     IER :OUT    Error flag.
C                 IER=0 No errors.
C                 IER=1 Either L1.LT.ABS(M1) or L1+ABS(M1) non-integer.
C                 IER=2 ABS(L1-L2).LE.L3.LE.L1+L2 not satisfied.
C                 IER=3 L1+L2+L3 not an integer.
C                 IER=4 M2MAX-M2MIN not an integer.
C                 IER=5 M2MAX less than M2MIN.
C                 IER=6 NDIM less than M2MAX-M2MIN+1.
C
C *Description:
C
C     Although conventionally the parameters of the vector addition
C  coefficients satisfy certain restrictions, such as being integers
C  or integers plus 1/2, the restrictions imposed on input to this
C  subroutine are somewhat weaker. See, for example, Section 27.9 of
C  Abramowitz and Stegun or Appendix C of Volume II of A. Messiah.
C  The restrictions imposed by this subroutine are
C       1. L1.GE.ABS(M1) and L1+ABS(M1) must be an integer;
C       2. ABS(L1-L2).LE.L3.LE.L1+L2;
C       3. L1+L2+L3 must be an integer;
C       4. M2MAX-M2MIN must be an integer, where
C          M2MAX=MIN(L2,L3-M1) and M2MIN=MAX(-L2,-L3-M1).
C  If the conventional restrictions are satisfied, then these
C  restrictions are met.
C
C     The user should be cautious in using input parameters that do
C  not satisfy the conventional restrictions. For example, the
C  the subroutine produces values of
C       g(M2) = (0.75 1.50   1.75  )
C               (0.25  M2  -0.25-M2)
C  for M2=-1.5,-0.5,0.5,1.5 but none of the symmetry properties of the
C  3j symbol, set forth on page 1056 of Messiah, is satisfied.
C
C     The subroutine generates g(M2MIN), g(M2MIN+1), ..., g(M2MAX)
C  where M2MIN and M2MAX are defined above. The sequence g(M2) is
C  generated by a three-term recurrence algorithm with scaling to
C  control overflow. Both backward and forward recurrence are used to
C  maintain numerical stability. The two recurrence sequences are
C  matched at an interior point and are normalized from the unitary
C  property of 3j coefficients and Wigner's phase convention.
C
C    The algorithm is suited to applications in which large quantum
C  numbers arise, such as in molecular dynamics.
C
C***REFERENCES  1. Abramowitz, M., and Stegun, I. A., Eds., Handbook
C                  of Mathematical Functions with Formulas, Graphs
C                  and Mathematical Tables, NBS Applied Mathematics
C                  Series 55, June 1964 and subsequent printings.
C               2. Messiah, Albert., Quantum Mechanics, Volume II,
C                  North-Holland Publishing Company, 1963.
C               3. Schulten, Klaus and Gordon, Roy G., Exact recursive
C                  evaluation of 3j and 6j coefficients for quantum-
C                  mechanical coupling of angular momenta, J Math
C                  Phys, v 16, no. 10, October 1975, pp. 1961-1970.
C               4. Schulten, Klaus and Gordon, Roy G., Semiclassical
C                  approximations to 3j and 6j coefficients for
C                  quantum-mechanical coupling of angular momenta,
C                  J Math Phys, v 16, no. 10, October 1975,
C                  pp. 1971-1988.
C               5. Schulten, Klaus and Gordon, Roy G., Recursive
C                  evaluation of 3j and 6j coefficients, Computer
C                  Phys Comm, v 11, 1976, pp. 269-278.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   880515  SLATEC prologue added by G. C. Nielson, NBS; parameters
C           HUGE and TINY revised to depend on D1MACH.
C   891229  Prologue description rewritten; other prologue sections
C           revised; MMATCH (location of match point for recurrences)
C           removed from argument list; argument IER changed to serve
C           only as an error flag (previously, in cases without error,
C           it returned the number of scalings); number of error codes
C           increased to provide more precise error information;
C           program comments revised; SLATEC error handler calls
C           introduced to enable printing of error messages to meet
C           SLATEC standards. These changes were done by D. W. Lozier,
C           M. A. McClain and J. M. Smith of the National Institute
C           of Standards and Technology, formerly NBS.
C   910415  Mixed type expressions eliminated; variable C1 initialized;
C           description of THRCOF expanded. These changes were done by
C           D. W. Lozier.
C***END PROLOGUE  DRC3JM
C
      INTEGER NDIM, IER
      DOUBLE PRECISION L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM)
C
      INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM,
     +        NSTEP2
      DOUBLE PRECISION A1, A1S, C1, C1OLD, C2, CNORM, D1MACH, DV, EPS,
     +                 HUGE, M2, M3, NEWFAC, OLDFAC, ONE, RATIO, SIGN1,
     +                 SIGN2, SRHUGE, SRTINY, SUM1, SUM2, SUMBAC,
     +                 SUMFOR, SUMUNI, THRESH, TINY, TWO, X, X1, X2, X3,
     +                 Y, Y1, Y2, Y3, ZERO
C
      DATA  ZERO,EPS,ONE,TWO /0.0D0,0.01D0,1.0D0,2.0D0/
C
C***FIRST EXECUTABLE STATEMENT  DRC3JM
      IER=0
C  HUGE is the square root of one twentieth of the largest floating
C  point number, approximately.
      HUGE = SQRT(D1MACH(2)/20.0D0)
      SRHUGE = SQRT(HUGE)
      TINY = 1.0D0/HUGE
      SRTINY = 1.0D0/SRHUGE
C
C     MMATCH = ZERO
C
C
C  Check error conditions 1, 2, and 3.
      IF((L1-ABS(M1)+EPS.LT.ZERO).OR.
     +   (MOD(L1+ABS(M1)+EPS,ONE).GE.EPS+EPS))THEN
         IER=1
         CALL XERMSG('SLATEC','DRC3JM','L1-ABS(M1) less than zero or '//
     +      'L1+ABS(M1) not integer.',IER,1)
         RETURN
      ELSEIF((L1+L2-L3.LT.-EPS).OR.(L1-L2+L3.LT.-EPS).OR.
     +   (-L1+L2+L3.LT.-EPS))THEN
         IER=2
         CALL XERMSG('SLATEC','DRC3JM','L1, L2, L3 do not satisfy '//
     +      'triangular condition.',IER,1)
         RETURN
      ELSEIF(MOD(L1+L2+L3+EPS,ONE).GE.EPS+EPS)THEN
         IER=3
         CALL XERMSG('SLATEC','DRC3JM','L1+L2+L3 not integer.',IER,1)
         RETURN
      ENDIF
C
C
C  Limits for M2
      M2MIN = MAX(-L2,-L3-M1)
      M2MAX = MIN(L2,L3-M1)
C
C  Check error condition 4.
      IF(MOD(M2MAX-M2MIN+EPS,ONE).GE.EPS+EPS)THEN
         IER=4
         CALL XERMSG('SLATEC','DRC3JM','M2MAX-M2MIN not integer.',IER,1)
         RETURN
      ENDIF
      IF(M2MIN.LT.M2MAX-EPS)   GO TO 20
      IF(M2MIN.LT.M2MAX+EPS)   GO TO 10
C
C  Check error condition 5.
      IER=5
      CALL XERMSG('SLATEC','DRC3JM','M2MIN greater than M2MAX.',IER,1)
      RETURN
C
C
C  This is reached in case that M2 and M3 can take only one value.
   10 CONTINUE
C     MSCALE = 0
      THRCOF(1) = (-ONE) ** INT(ABS(L2-L3-M1)+EPS) /
     1 SQRT(L1+L2+L3+ONE)
      RETURN
C
C  This is reached in case that M1 and M2 take more than one value.
   20 CONTINUE
C     MSCALE = 0
      NFIN = INT(M2MAX-M2MIN+ONE+EPS)
      IF(NDIM-NFIN)   21, 23, 23
C
C  Check error condition 6.
   21 IER = 6
      CALL XERMSG('SLATEC','DRC3JM','Dimension of result array for '//
     +            '3j coefficients too small.',IER,1)
      RETURN
C
C
C
C  Start of forward recursion from M2 = M2MIN
C
   23 M2 = M2MIN
      THRCOF(1) = SRTINY
      NEWFAC = 0.0D0
      C1 = 0.0D0
      SUM1 = TINY
C
C
      LSTEP = 1
   30 LSTEP = LSTEP + 1
      M2 = M2 + ONE
      M3 = - M1 - M2
C
C
      OLDFAC = NEWFAC
      A1 = (L2-M2+ONE) * (L2+M2) * (L3+M3+ONE) * (L3-M3)
      NEWFAC = SQRT(A1)
C
C
      DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE)
     1                               - (L2+M2-ONE)*(L3-M3-ONE)
C
      IF(LSTEP-2)  32, 32, 31
C
   31 C1OLD = ABS(C1)
   32 C1 = - DV / NEWFAC
C
      IF(LSTEP.GT.2)   GO TO 60
C
C
C  If M2 = M2MIN + 1, the third term in the recursion equation vanishes,
C  hence
C
      X = SRTINY * C1
      THRCOF(2) = X
      SUM1 = SUM1 + TINY * C1*C1
      IF(LSTEP.EQ.NFIN)   GO TO 220
      GO TO 30
C
C
   60 C2 = - OLDFAC / NEWFAC
C
C  Recursion to the next 3j coefficient
      X = C1 * THRCOF(LSTEP-1) + C2 * THRCOF(LSTEP-2)
      THRCOF(LSTEP) = X
      SUMFOR = SUM1
      SUM1 = SUM1 + X*X
      IF(LSTEP.EQ.NFIN)   GO TO 100
C
C  See if last unnormalized 3j coefficient exceeds SRHUGE
C
      IF(ABS(X).LT.SRHUGE)   GO TO 80
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(1), ... , THRCOF(LSTEP)
C  has to be rescaled to prevent overflow
C
C     MSCALE = MSCALE + 1
      DO 70 I=1,LSTEP
      IF(ABS(THRCOF(I)).LT.SRTINY)   THRCOF(I) = ZERO
   70 THRCOF(I) = THRCOF(I) / SRHUGE
      SUM1 = SUM1 / HUGE
      SUMFOR = SUMFOR / HUGE
      X = X / SRHUGE
C
C
C  As long as ABS(C1) is decreasing, the recursion proceeds towards
C  increasing 3j values and, hence, is numerically stable.  Once
C  an increase of ABS(C1) is detected, the recursion direction is
C  reversed.
C
   80 IF(C1OLD-ABS(C1))   100, 100, 30
C
C
C  Keep three 3j coefficients around MMATCH for comparison later
C  with backward recursion values.
C
  100 CONTINUE
C     MMATCH = M2 - 1
      NSTEP2 = NFIN - LSTEP + 3
      X1 = X
      X2 = THRCOF(LSTEP-1)
      X3 = THRCOF(LSTEP-2)
C
C  Starting backward recursion from M2MAX taking NSTEP2 steps, so
C  that forwards and backwards recursion overlap at the three points
C  M2 = MMATCH+1, MMATCH, MMATCH-1.
C
      NFINP1 = NFIN + 1
      NFINP2 = NFIN + 2
      NFINP3 = NFIN + 3
      THRCOF(NFIN) = SRTINY
      SUM2 = TINY
C
C
C
      M2 = M2MAX + TWO
      LSTEP = 1
  110 LSTEP = LSTEP + 1
      M2 = M2 - ONE
      M3 = - M1 - M2
      OLDFAC = NEWFAC
      A1S = (L2-M2+TWO) * (L2+M2-ONE) * (L3+M3+TWO) * (L3-M3-ONE)
      NEWFAC = SQRT(A1S)
      DV = (L1+L2+L3+ONE)*(L2+L3-L1) - (L2-M2+ONE)*(L3+M3+ONE)
     1                               - (L2+M2-ONE)*(L3-M3-ONE)
      C1 = - DV / NEWFAC
      IF(LSTEP.GT.2)   GO TO 120
C
C  If M2 = M2MAX + 1 the third term in the recursion equation vanishes
C
      Y = SRTINY * C1
      THRCOF(NFIN-1) = Y
      IF(LSTEP.EQ.NSTEP2)   GO TO 200
      SUMBAC = SUM2
      SUM2 = SUM2 + Y*Y
      GO TO 110
C
  120 C2 = - OLDFAC / NEWFAC
C
C  Recursion to the next 3j coefficient
C
      Y = C1 * THRCOF(NFINP2-LSTEP) + C2 * THRCOF(NFINP3-LSTEP)
C
      IF(LSTEP.EQ.NSTEP2)   GO TO 200
C
      THRCOF(NFINP1-LSTEP) = Y
      SUMBAC = SUM2
      SUM2 = SUM2 + Y*Y
C
C
C  See if last 3j coefficient exceeds SRHUGE
C
      IF(ABS(Y).LT.SRHUGE)   GO TO 110
C
C  This is reached if last 3j coefficient larger than SRHUGE,
C  so that the recursion series THRCOF(NFIN), ... , THRCOF(NFIN-LSTEP+1)
C  has to be rescaled to prevent overflow.
C
C     MSCALE = MSCALE + 1
      DO 111 I=1,LSTEP
      INDEX = NFIN - I + 1
      IF(ABS(THRCOF(INDEX)).LT.SRTINY)
     1  THRCOF(INDEX) = ZERO
  111 THRCOF(INDEX) = THRCOF(INDEX) / SRHUGE
      SUM2 = SUM2 / HUGE
      SUMBAC = SUMBAC / HUGE
C
      GO TO 110
C
C
C
C  The forward recursion 3j coefficients X1, X2, X3 are to be matched
C  with the corresponding backward recursion values Y1, Y2, Y3.
C
  200 Y3 = Y
      Y2 = THRCOF(NFINP2-LSTEP)
      Y1 = THRCOF(NFINP3-LSTEP)
C
C
C  Determine now RATIO such that YI = RATIO * XI  (I=1,2,3) holds
C  with minimal error.
C
      RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 )
      NLIM = NFIN - NSTEP2 + 1
C
      IF(ABS(RATIO).LT.ONE)   GO TO 211
C
      DO 210 N=1,NLIM
  210 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC
      GO TO 230
C
  211 NLIM = NLIM + 1
      RATIO = ONE / RATIO
      DO 212 N=NLIM,NFIN
  212 THRCOF(N) = RATIO * THRCOF(N)
      SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC
      GO TO 230
C
  220 SUMUNI = SUM1
C
C
C  Normalize 3j coefficients
C
  230 CNORM = ONE / SQRT((L1+L1+ONE) * SUMUNI)
C
C  Sign convention for last 3j coefficient determines overall phase
C
      SIGN1 = SIGN(ONE,THRCOF(NFIN))
      SIGN2 = (-ONE) ** INT(ABS(L2-L3-M1)+EPS)
      IF(SIGN1*SIGN2)  235,235,236
  235 CNORM = - CNORM
C
  236 IF(ABS(CNORM).LT.ONE)   GO TO 250
C
      DO 240 N=1,NFIN
  240 THRCOF(N) = CNORM * THRCOF(N)
      RETURN
C
  250 THRESH = TINY / ABS(CNORM)
      DO 251 N=1,NFIN
      IF(ABS(THRCOF(N)).LT.THRESH)   THRCOF(N) = ZERO
  251 THRCOF(N) = CNORM * THRCOF(N)
C
C
C
      RETURN
      END
*DECK DRC6J
      SUBROUTINE DRC6J (L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM,
     +   IER)
C***BEGIN PROLOGUE  DRC6J
C***PURPOSE  Evaluate the 6j symbol h(L1) = {L1 L2 L3}
C                                           {L4 L5 L6}
C            for all allowed values of L1, the other parameters
C            being held fixed.
C***LIBRARY   SLATEC
C***CATEGORY  C19
C***TYPE      DOUBLE PRECISION (RC6J-S, DRC6J-D)
C***KEYWORDS  6J COEFFICIENTS, 6J SYMBOLS, CLEBSCH-GORDAN COEFFICIENTS,
C             RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS,
C             WIGNER COEFFICIENTS
C***AUTHOR  Gordon, R. G., Harvard University
C           Schulten, K., Max Planck Institute
C***DESCRIPTION
C
C *Usage:
C
C        DOUBLE PRECISION L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM)
C        INTEGER NDIM, IER
C
C        CALL DRC6J(L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM, IER)
C
C *Arguments:
C
C     L2 :IN      Parameter in 6j symbol.
C
C     L3 :IN      Parameter in 6j symbol.
C
C     L4 :IN      Parameter in 6j symbol.
C
C     L5 :IN      Parameter in 6j symbol.
C
C     L6 :IN      Parameter in 6j symbol.
C
C     L1MIN :OUT  Smallest allowable L1 in 6j symbol.
C
C     L1MAX :OUT  Largest allowable L1 in 6j symbol.
C
C     SIXCOF :OUT Set of 6j coefficients generated by evaluating the
C                 6j symbol for all allowed values of L1.  SIXCOF(I)
C                 will contain h(L1MIN+I-1), I=1,2,...,L1MAX-L1MIN+1.
C
C     NDIM :IN    Declared length of SIXCOF in calling program.
C
C     IER :OUT    Error flag.
C                 IER=0 No errors.
C                 IER=1 L2+L3+L5+L6 or L4+L2+L6 not an integer.
C                 IER=2 L4, L2, L6 triangular condition not satisfied.
C                 IER=3 L4, L5, L3 triangular condition not satisfied.
C                 IER=4 L1MAX-L1MIN not an integer.
C                 IER=5 L1MAX less than L1MIN.
C                 IER=6 NDIM less than L1MAX-L1MIN+1.
C
C *Description:
C
C     The definition and properties of 6j symbols can be found, for
C  example, in Appendix C of Volume II of A. Messiah. Although the
C  parameters of the vector addition coefficients satisfy certain
C  conventional restrictions, the restriction that they be non-negative
C  integers or non-negative integers plus 1/2 is not imposed on input
C  to this subroutine. The restrictions imposed are
C       1. L2+L3+L5+L6 and L2+L4+L6 must be integers;
C       2. ABS(L2-L4).LE.L6.LE.L2+L4 must be satisfied;
C       3. ABS(L4-L5).LE.L3.LE.L4+L5 must be satisfied;
C       4. L1MAX-L1MIN must be a non-negative integer, where
C          L1MAX=MIN(L2+L3,L5+L6) and L1MIN=MAX(ABS(L2-L3),ABS(L5-L6)).
C  If all the conventional restrictions are satisfied, then these
C  restrictions are met. Conversely, if input to this subroutine meets
C  all of these restrictions and the conventional restriction stated
C  above, then all the conventional restrictions are satisfied.
C
C     The user should be cautious in using input parameters that do
C  not satisfy the conventional restrictions. For example, the
C  the subroutine produces values of
C       h(L1) = { L1 2/3  1 }
C               {2/3 2/3 2/3}
C  for L1=1/3 and 4/3 but none of the symmetry properties of the 6j
C  symbol, set forth on pages 1063 and 1064 of Messiah, is satisfied.
C
C     The subroutine generates h(L1MIN), h(L1MIN+1), ..., h(L1MAX)
C  where L1MIN and L1MAX are defined above. The sequence h(L1) is
C  generated by a three-term recurrence algorithm with scaling to
C  control overflow. Both backward and forward recurrence are used to
C  maintain numerical stability. The two recurrence sequences are
C  matched at an interior point and are normalized from the unitary
C  property of 6j coefficients and Wigner's phase convention.
C
C    The algorithm is suited to applications in which large quantum
C  numbers arise, such as in molecular dynamics.
C
C***REFERENCES  1. Messiah, Albert., Quantum Mechanics, Volume II,
C                  North-Holland Publishing Company, 1963.
C               2. Schulten, Klaus and Gordon, Roy G., Exact recursive
C                  evaluation of 3j and 6j coefficients for quantum-
C                  mechanical coupling of angular momenta, J Math
C                  Phys, v 16, no. 10, October 1975, pp. 1961-1970.
C               3. Schulten, Klaus and Gordon, Roy G., Semiclassical
C                  approximations to 3j and 6j coefficients for
C                  quantum-mechanical coupling of angular momenta,
C                  J Math Phys, v 16, no. 10, October 1975,
C                  pp. 1971-1988.
C               4. Schulten, Klaus and Gordon, Roy G., Recursive
C                  evaluation of 3j and 6j coefficients, Computer
C                  Phys Comm, v 11, 1976, pp. 269-278.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  DATE WRITTEN
C   880515  SLATEC prologue added by G. C. Nielson, NBS; parameters
C           HUGE and TINY revised to depend on D1MACH.
C   891229  Prologue description rewritten; other prologue sections
C           revised; LMATCH (location of match point for recurrences)
C           removed from argument list; argument IER changed to serve
C           only as an error flag (previously, in cases without error,
C           it returned the number of scalings); number of error codes
C           increased to provide more precise error information;
C           program comments revised; SLATEC error handler calls
C           introduced to enable printing of error messages to meet
C           SLATEC standards. These changes were done by D. W. Lozier,
C           M. A. McClain and J. M. Smith of the National Institute
C           of Standards and Technology, formerly NBS.
C   910415  Mixed type expressions eliminated; variable C1 initialized;
C           description of SIXCOF expanded. These changes were done by
C           D. W. Lozier.
C***END PROLOGUE  DRC6J
C
      INTEGER NDIM, IER
      DOUBLE PRECISION L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM)
C
      INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM,
     +        NSTEP2
      DOUBLE PRECISION A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, D1MACH,
     +                 DENOM, DV, EPS, HUGE, L1, NEWFAC, OLDFAC, ONE,
     +                 RATIO, SIGN1, SIGN2, SRHUGE, SRTINY, SUM1, SUM2,
     +                 SUMBAC, SUMFOR, SUMUNI, THREE, THRESH, TINY, TWO,
     +                 X, X1, X2, X3, Y, Y1, Y2, Y3, ZERO
C
      DATA  ZERO,EPS,ONE,TWO,THREE /0.0D0,0.01D0,1.0D0,2.0D0,3.0D0/
C
C***FIRST EXECUTABLE STATEMENT  DRC6J
      IER=0
C  HUGE is the square root of one twentieth of the largest floating
C  point number, approximately.
      HUGE = SQRT(D1MACH(2)/20.0D0)
      SRHUGE = SQRT(HUGE)
      TINY = 1.0D0/HUGE
      SRTINY = 1.0D0/SRHUGE
C
C     LMATCH = ZERO
C
C  Check error conditions 1, 2, and 3.
      IF((MOD(L2+L3+L5+L6+EPS,ONE).GE.EPS+EPS).OR.
     +   (MOD(L4+L2+L6+EPS,ONE).GE.EPS+EPS))THEN
         IER=1
         CALL XERMSG('SLATEC','DRC6J','L2+L3+L5+L6 or L4+L2+L6 not '//
     +      'integer.',IER,1)
         RETURN
      ELSEIF((L4+L2-L6.LT.ZERO).OR.(L4-L2+L6.LT.ZERO).OR.
     +   (-L4+L2+L6.LT.ZERO))THEN
         IER=2
         CALL XERMSG('SLATEC','DRC6J','L4, L2, L6 triangular '//
     +      'condition not satisfied.',IER,1)
         RETURN
      ELSEIF((L4-L5+L3.LT.ZERO).OR.(L4+L5-L3.LT.ZERO).OR.
     +   (-L4+L5+L3.LT.ZERO))THEN
         IER=3
         CALL XERMSG('SLATEC','DRC6J','L4, L5, L3 triangular '//
     +      'condition not satisfied.',IER,1)
         RETURN
      ENDIF
C
C  Limits for L1
C
      L1MIN = MAX(ABS(L2-L3),ABS(L5-L6))
      L1MAX = MIN(L2+L3,L5+L6)
C
C  Check error condition 4.
      IF(MOD(L1MAX-L1MIN+EPS,ONE).GE.EPS+EPS)THEN
         IER=4
         CALL XERMSG('SLATEC','DRC6J','L1MAX-L1MIN not integer.',IER,1)
         RETURN
      ENDIF
      IF(L1MIN.LT.L1MAX-EPS)   GO TO 20
      IF(L1MIN.LT.L1MAX+EPS)   GO TO 10
C
C  Check error condition 5.
      IER=5
      CALL XERMSG('SLATEC','DRC6J','L1MIN greater than L1MAX.',IER,1)
      RETURN
C
C
C  This is reached in case that L1 can take only one value
C
   10 CONTINUE
C     LSCALE = 0
      SIXCOF(1) = (-ONE) ** INT(L2+L3+L5+L6+EPS) /
     1            SQRT((L1MIN+L1MIN+ONE)*(L4+L4+ONE))
      RETURN
C
C
C  This is reached in case that L1 can take more than one value.
C
   20 CONTINUE
C     LSCALE = 0
      NFIN = INT(L1MAX-L1MIN+ONE+EPS)
      IF(NDIM-NFIN)   21, 23, 23
C
C  Check error condition 6.
   21 IER = 6
      CALL XERMSG('SLATEC','DRC6J','Dimension of result array for 6j '//
     +            'coefficients too small.',IER,1)
      RETURN
C
C
C  Start of forward recursion
C
   23 L1 = L1MIN
      NEWFAC = 0.0D0
      C1 = 0.0D0
      SIXCOF(1) = SRTINY
      SUM1 = (L1+L1+ONE) * TINY
C
      LSTEP = 1
   30 LSTEP = LSTEP + 1
      L1 = L1 + ONE
C
      OLDFAC = NEWFAC
      A1 = (L1+L2+L3+ONE) * (L1-L2+L3) * (L1+L2-L3) * (-L1+L2+L3+ONE)
      A2 = (L1+L5+L6+ONE) * (L1-L5+L6) * (L1+L5-L6) * (-L1+L5+L6+ONE)
      NEWFAC = SQRT(A1*A2)
C
      IF(L1.LT.ONE+EPS)   GO TO 40
C
      DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE)
     1           - L1*(L1-ONE)*L4*(L4+ONE) )
     2                   - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE))
     3                   * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE))
C
      DENOM = (L1-ONE) * NEWFAC
C
      IF(LSTEP-2)  32, 32, 31
C
   31 C1OLD = ABS(C1)
   32 C1 = - (L1+L1-ONE) * DV / DENOM
      GO TO 50
C
C  If L1 = 1, (L1 - 1) has to be factored out of DV, hence
C
   40 C1 = - TWO * ( L2*(L2+ONE) + L5*(L5+ONE) - L4*(L4+ONE) )
     1 / NEWFAC
C
   50 IF(LSTEP.GT.2)   GO TO 60
C
C  If L1 = L1MIN + 1, the third term in recursion equation vanishes
C
      X = SRTINY * C1
      SIXCOF(2) = X
      SUM1 = SUM1 + TINY * (L1+L1+ONE) * C1 * C1
C
      IF(LSTEP.EQ.NFIN)   GO TO 220
      GO TO 30
C
C
   60 C2 = - L1 * OLDFAC / DENOM
C
C  Recursion to the next 6j coefficient X
C
      X = C1 * SIXCOF(LSTEP-1) + C2 * SIXCOF(LSTEP-2)
      SIXCOF(LSTEP) = X
C
      SUMFOR = SUM1
      SUM1 = SUM1 + (L1+L1+ONE) * X * X
      IF(LSTEP.EQ.NFIN)   GO TO 100
C
C  See if last unnormalized 6j coefficient exceeds SRHUGE
C
      IF(ABS(X).LT.SRHUGE)   GO TO 80
C
C  This is reached if last 6j coefficient larger than SRHUGE,
C  so that the recursion series SIXCOF(1), ... ,SIXCOF(LSTEP)
C  has to be rescaled to prevent overflow
C
C     LSCALE = LSCALE + 1
      DO 70 I=1,LSTEP
      IF(ABS(SIXCOF(I)).LT.SRTINY)   SIXCOF(I) = ZERO
   70 SIXCOF(I) = SIXCOF(I) / SRHUGE
      SUM1 = SUM1 / HUGE
      SUMFOR = SUMFOR / HUGE
      X = X / SRHUGE
C
C
C  As long as the coefficient ABS(C1) is decreasing, the recursion
C  proceeds towards increasing 6j values and, hence, is numerically
C  stable.  Once an increase of ABS(C1) is detected, the recursion
C  direction is reversed.
C
   80 IF(C1OLD-ABS(C1))   100, 100, 30
C
C
C  Keep three 6j coefficients around LMATCH for comparison later
C  with backward recursion.
C
  100 CONTINUE
C     LMATCH = L1 - 1
      X1 = X
      X2 = SIXCOF(LSTEP-1)
      X3 = SIXCOF(LSTEP-2)
C
C
C
C  Starting backward recursion from L1MAX taking NSTEP2 steps, so
C  that forward and backward recursion overlap at the three points
C  L1 = LMATCH+1, LMATCH, LMATCH-1.
C
      NFINP1 = NFIN + 1
      NFINP2 = NFIN + 2
      NFINP3 = NFIN + 3
      NSTEP2 = NFIN - LSTEP + 3
      L1 = L1MAX
C
      SIXCOF(NFIN) = SRTINY
      SUM2 = (L1+L1+ONE) * TINY
C
C
      L1 = L1 + TWO
      LSTEP = 1
  110 LSTEP = LSTEP + 1
      L1 = L1 - ONE
C
      OLDFAC = NEWFAC
      A1S = (L1+L2+L3)*(L1-L2+L3-ONE)*(L1+L2-L3-ONE)*(-L1+L2+L3+TWO)
      A2S = (L1+L5+L6)*(L1-L5+L6-ONE)*(L1+L5-L6-ONE)*(-L1+L5+L6+TWO)
      NEWFAC = SQRT(A1S*A2S)
C
      DV = TWO * ( L2*(L2+ONE)*L5*(L5+ONE) + L3*(L3+ONE)*L6*(L6+ONE)
     1           - L1*(L1-ONE)*L4*(L4+ONE) )
     2                   - (L2*(L2+ONE) + L3*(L3+ONE) - L1*(L1-ONE))
     3                   * (L5*(L5+ONE) + L6*(L6+ONE) - L1*(L1-ONE))
C
      DENOM = L1 * NEWFAC
      C1 = - (L1+L1-ONE) * DV / DENOM
      IF(LSTEP.GT.2)   GO TO 120
C
C  If L1 = L1MAX + 1 the third term in the recursion equation vanishes
C
      Y = SRTINY * C1
      SIXCOF(NFIN-1) = Y
      IF(LSTEP.EQ.NSTEP2)   GO TO 200
      SUMBAC = SUM2
      SUM2 = SUM2 + (L1+L1-THREE) * C1 * C1 * TINY
      GO TO 110
C
C
  120 C2 = - (L1-ONE) * OLDFAC / DENOM
C
C  Recursion to the next 6j coefficient Y
C
      Y = C1 * SIXCOF(NFINP2-LSTEP) + C2 * SIXCOF(NFINP3-LSTEP)
      IF(LSTEP.EQ.NSTEP2)   GO TO 200
      SIXCOF(NFINP1-LSTEP) = Y
      SUMBAC = SUM2
      SUM2 = SUM2 + (L1+L1-THREE) * Y * Y
C
C  See if last unnormalized 6j coefficient exceeds SRHUGE
C
      IF(ABS(Y).LT.SRHUGE)   GO TO 110
C
C  This is reached if last 6j coefficient larger than SRHUGE,
C  so that the recursion series SIXCOF(NFIN), ... ,SIXCOF(NFIN-LSTEP+1)
C  has to be rescaled to prevent overflow
C
C     LSCALE = LSCALE + 1
      DO 130 I=1,LSTEP
      INDEX = NFIN-I+1
      IF(ABS(SIXCOF(INDEX)).LT.SRTINY)   SIXCOF(INDEX) = ZERO
  130 SIXCOF(INDEX) = SIXCOF(INDEX) / SRHUGE
      SUMBAC = SUMBAC / HUGE
      SUM2 = SUM2 / HUGE
C
      GO TO 110
C
C
C  The forward recursion 6j coefficients X1, X2, X3 are to be matched
C  with the corresponding backward recursion values Y1, Y2, Y3.
C
  200 Y3 = Y
      Y2 = SIXCOF(NFINP2-LSTEP)
      Y1 = SIXCOF(NFINP3-LSTEP)
C
C
C  Determine now RATIO such that YI = RATIO * XI  (I=1,2,3) holds
C  with minimal error.
C
      RATIO = ( X1*Y1 + X2*Y2 + X3*Y3 ) / ( X1*X1 + X2*X2 + X3*X3 )
      NLIM = NFIN - NSTEP2 + 1
C
      IF(ABS(RATIO).LT.ONE)   GO TO 211
C
      DO 210 N=1,NLIM
  210 SIXCOF(N) = RATIO * SIXCOF(N)
      SUMUNI = RATIO * RATIO * SUMFOR + SUMBAC
      GO TO 230
C
  211 NLIM = NLIM + 1
      RATIO = ONE / RATIO
      DO 212 N=NLIM,NFIN
  212 SIXCOF(N) = RATIO * SIXCOF(N)
      SUMUNI = SUMFOR + RATIO*RATIO*SUMBAC
      GO TO 230
C
  220 SUMUNI = SUM1
C
C
C  Normalize 6j coefficients
C
  230 CNORM = ONE / SQRT((L4+L4+ONE)*SUMUNI)
C
C  Sign convention for last 6j coefficient determines overall phase
C
      SIGN1 = SIGN(ONE,SIXCOF(NFIN))
      SIGN2 = (-ONE) ** INT(L2+L3+L5+L6+EPS)
      IF(SIGN1*SIGN2) 235,235,236
  235 CNORM = - CNORM
C
  236 IF(ABS(CNORM).LT.ONE)   GO TO 250
C
      DO 240 N=1,NFIN
  240 SIXCOF(N) = CNORM * SIXCOF(N)
      RETURN
C
  250 THRESH = TINY / ABS(CNORM)
      DO 251 N=1,NFIN
      IF(ABS(SIXCOF(N)).LT.THRESH)   SIXCOF(N) = ZERO
  251 SIXCOF(N) = CNORM * SIXCOF(N)
C
      RETURN
      END
*DECK DRD
      DOUBLE PRECISION FUNCTION DRD (X, Y, Z, IER)
C***BEGIN PROLOGUE  DRD
C***PURPOSE  Compute the incomplete or complete elliptic integral of
C            the 2nd kind. For X and Y nonnegative, X+Y and Z positive,
C            DRD(X,Y,Z) = Integral from zero to infinity of
C                                -1/2     -1/2     -3/2
C                      (3/2)(t+X)    (t+Y)    (t+Z)    dt.
C            If X or Y is zero, the integral is complete.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      DOUBLE PRECISION (RD-S, DRD-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE SECOND KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     DRD
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the second kind
C          Standard FORTRAN function routine
C          Double precision version
C          The routine calculates an approximation result to
C          DRD(X,Y,Z) = Integral from zero to infinity of
C                              -1/2     -1/2     -3/2
C                    (3/2)(t+X)    (t+Y)    (t+Z)    dt,
C          where X and Y are nonnegative, X + Y is positive, and Z is
C          positive.  If X or Y is zero, the integral is COMPLETE.
C          The duplication theorem is iterated until the variables are
C          nearly equal, and the function is then expanded in Taylor
C          series to fifth order.
C
C   2.     Calling Sequence
C
C          DRD( X, Y, Z, IER )
C
C          Parameters On Entry
C          Values assigned by the calling routine
C
C          X      - Double precision, nonnegative variable
C
C          Y      - Double precision, nonnegative variable
C
C                   X + Y is positive
C
C          Z      - Double precision, positive variable
C
C
C
C          On Return    (values assigned by the DRD routine)
C
C          DRD     - Double precision approximation to the integral
C
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine. It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C
C          X, Y, Z are unaltered.
C
C   3.    Error Messages
C
C         Value of IER assigned by the DRD routine
C
C                  Value assigned         Error message printed
C                  IER = 1                MIN(X,Y) .LT. 0.0D0
C                      = 2                MIN(X + Y, Z ) .LT. LOLIM
C                      = 3                MAX(X,Y,Z) .GT. UPLIM
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X, Y, and Z
C
C          LOLIM  - Lower limit of valid arguments
C
C                    Not less  than 2 / (machine maximum) ** (2/3).
C
C          UPLIM  - Upper limit of valid arguments
C
C                 Not greater than (0.1D0 * ERRTOL / machine
C                 minimum) ** (2/3), where ERRTOL is described below.
C                 In the following table it is assumed that ERRTOL will
C                 never be chosen smaller than 1.0D-5.
C
C
C                    Acceptable values for:   LOLIM      UPLIM
C                    IBM 360/370 SERIES   :   6.0D-51     1.0D+48
C                    CDC 6000/7000 SERIES :   5.0D-215    2.0D+191
C                    UNIVAC 1100 SERIES   :   1.0D-205    2.0D+201
C                    CRAY                 :   3.0D-1644   1.69D+1640
C                    VAX 11 SERIES        :   1.0D-25     4.5D+21
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C          ERRTOL    Relative error due to truncation is less than
C                    3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2.
C
C
C
C        The accuracy of the computed approximation to the integral
C        can be controlled by choosing the value of ERRTOL.
C        Truncation of a Taylor series after terms of fifth order
C        introduces an error less than the amount shown in the
C        second column of the following table for each value of
C        ERRTOL in the first column.  In addition to the truncation
C        error there will be round-off error, but in practice the
C        total error from both sources is usually less than the
C        amount given in the table.
C
C
C
C
C          Sample choices:  ERRTOL   Relative truncation
C                                    error less than
C                           1.0D-3    4.0D-18
C                           3.0D-3    3.0D-15
C                           1.0D-2    4.0D-12
C                           3.0D-2    3.0D-9
C                           1.0D-1    4.0D-6
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   DRD Special Comments
C
C
C
C          Check: DRD(X,Y,Z) + DRD(Y,Z,X) + DRD(Z,X,Y)
C          = 3 / SQRT(X * Y * Z), where X, Y, and Z are positive.
C
C
C          On Input:
C
C          X, Y, and Z are the variables in the integral DRD(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, Z are unaltered.
C
C
C
C          ********************************************************
C
C          WARNING: Changes in the program may improve speed at the
C                   expense of robustness.
C
C
C
C    -------------------------------------------------------------------
C
C
C   Special double precision functions via DRD and DRF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 2nd kind
C
C                  -----------------------------------------
C
C
C                                             2         2   2
C                  E(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1) -
C
C                     2      3             2         2   2
C                  -(K/3) SIN (PHI) DRD(COS (PHI),1-K SIN (PHI),1)
C
C
C                                  2        2            2
C                  E(K) = DRF(0,1-K ,1) - (K/3) DRD(0,1-K ,1)
C
C                         PI/2     2   2      1/2
C                       = INT  (1-K SIN (PHI) )  D PHI
C                          0
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind
C
C                  -----------------------------------------
C
C                                               2 2    2
C                  EL2(X,KC,A,B) = AX DRF(1,1+KC X ,1+X ) +
C
C                                              3          2 2    2
C                                 +(1/3)(B-A) X DRD(1,1+KC X ,1+X )
C
C
C
C
C                  Legendre form of alternative ELLIPTIC INTEGRAL
C                  of 2nd kind
C
C                  -----------------------------------------
C
C
C
C                            Q     2       2   2  -1/2
C                  D(Q,K) = INT SIN P  (1-K SIN P)     DP
C                            0
C
C
C
C                                     3          2     2   2
C                  D(Q,K) = (1/3) (SIN Q) DRD(COS Q,1-K SIN Q,1)
C
C
C
C
C                  Lemniscate constant  B
C
C                  -----------------------------------------
C
C
C
C
C                       1    2    4 -1/2
C                  B = INT  S (1-S )    DS
C                       0
C
C
C                  B = (1/3) DRD (0,2,1)
C
C
C                  Heuman's LAMBDA function
C
C                  -----------------------------------------
C
C
C
C                  (PI/2) LAMBDA0(A,B) =
C
C                                    2                2
C                 = SIN(B) (DRF(0,COS (A),1)-(1/3) SIN (A) *
C
C                            2               2         2       2
C                  *DRD(0,COS (A),1)) DRF(COS (B),1-COS (A) SIN (B),1)
C
C                            2       3             2
C                  -(1/3) COS (A) SIN (B) DRF(0,COS (A),1) *
C
C                           2         2       2
C                   *DRD(COS (B),1-COS (A) SIN (B),1)
C
C
C
C                  Jacobi ZETA function
C
C                  -----------------------------------------
C
C                             2                 2       2   2
C                  Z(B,K) = (K/3) SIN(B) DRF(COS (B),1-K SIN (B),1)
C
C
C                                       2             2
C                             *DRD(0,1-K ,1)/DRF(0,1-K ,1)
C
C                               2       3           2       2   2
C                            -(K /3) SIN (B) DRD(COS (B),1-K SIN (B),1)
C
C
C ---------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Modify calls to XERMSG to put in standard form.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DRD
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      DOUBLE PRECISION LOLIM, TUPLIM, UPLIM, EPSLON, ERRTOL, D1MACH
      DOUBLE PRECISION C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA
      DOUBLE PRECISION MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV
      DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL, LOLIM, UPLIM, C1, C2, C3, C4, FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  DRD
      IF (FIRST) THEN
         ERRTOL = (D1MACH(3)/3.0D0)**(1.0D0/6.0D0)
         LOLIM  = 2.0D0/(D1MACH(2))**(2.0D0/3.0D0)
         TUPLIM = D1MACH(1)**(1.0E0/3.0E0)
         TUPLIM = (0.10D0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM
         UPLIM  = TUPLIM**2.0D0
C
         C1 = 3.0D0/14.0D0
         C2 = 1.0D0/6.0D0
         C3 = 9.0D0/22.0D0
         C4 = 3.0D0/26.0D0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      DRD = 0.0D0
      IF( MIN(X,Y).LT.0.0D0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         CALL XERMSG ('SLATEC', 'DRD',
     *      'MIN(X,Y).LT.0 WHERE X = ' // XERN3 // ' AND Y = ' //
     *      XERN4, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y,Z).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'DRD',
     *      'MAX(X,Y,Z).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6,
     *      3, 1)
         RETURN
      ENDIF
C
      IF (MIN(X+Y,Z).LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'DRD',
     *      'MIN(X+Y,Z).LT.LOLIM WHERE X = ' // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // XERN6,
     *      2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
      SIGMA = 0.0D0
      POWER4 = 1.0D0
C
   30 MU = (XN+YN+3.0D0*ZN)*0.20D0
      XNDEV = (MU-XN)/MU
      YNDEV = (MU-YN)/MU
      ZNDEV = (MU-ZN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT = SQRT(XN)
      YNROOT = SQRT(YN)
      ZNROOT = SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA))
      POWER4 = POWER4*0.250D0
      XN = (XN+LAMDA)*0.250D0
      YN = (YN+LAMDA)*0.250D0
      ZN = (ZN+LAMDA)*0.250D0
      GO TO 30
C
   40 EA = XNDEV*YNDEV
      EB = ZNDEV*ZNDEV
      EC = EA - EB
      ED = EA - 6.0D0*EB
      EF = ED + EC + EC
      S1 = ED*(-C1+0.250D0*C3*ED-1.50D0*C4*ZNDEV*EF)
      S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA))
      DRD = 3.0D0*SIGMA + POWER4*(1.0D0+S1+S2)/(MU*SQRT(MU))
C
      RETURN
      END
*DECK DREADP
      SUBROUTINE DREADP (IPAGE, LIST, RLIST, LPAGE, IREC)
C***BEGIN PROLOGUE  DREADP
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SREADP-S, DREADP-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     READ RECORD NUMBER IRECN, OF LENGTH LPG, FROM UNIT
C     NUMBER IPAGEF INTO THE STORAGE ARRAY, LIST(*).
C     READ RECORD  IRECN+1, OF LENGTH LPG, FROM UNIT NUMBER
C     IPAGEF INTO THE STORAGE ARRAY RLIST(*).
C
C     TO CONVERT THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE
C     /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890605  Corrected references to XERRWV.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C***END PROLOGUE  DREADP
      INTEGER LIST(*)
      DOUBLE PRECISION RLIST(*)
      CHARACTER*8 XERN1, XERN2
C***FIRST EXECUTABLE STATEMENT  DREADP
      IPAGEF=IPAGE
      LPG   =LPAGE
      IRECN=IREC
      READ(IPAGEF,REC=IRECN,ERR=100)(LIST(I),I=1,LPG)
      READ(IPAGEF,REC=IRECN+1,ERR=100)(RLIST(I),I=1,LPG)
      RETURN
C
  100 WRITE (XERN1, '(I8)') LPG
      WRITE (XERN2, '(I8)') IRECN
      CALL XERMSG ('SLATEC', 'DREADP', 'IN DSPLP, LPG = ' // XERN1 //
     *   ' IRECN = ' // XERN2, 100, 1)
      RETURN
      END
*DECK DREORT
      SUBROUTINE DREORT (NCOMP, Y, YP, YHP, NIV, W, S, P, IP, STOWA,
     +   IFLAG)
C***BEGIN PROLOGUE  DREORT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (REORT-S, DREORT-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C   INPUT
C *********
C     Y, YP and YHP = homogeneous solution matrix and particular
C                     solution vector to be orthonormalized.
C     IFLAG = 1 --  store YHP into Y and YP, test for
C                   reorthonormalization, orthonormalize if needed,
C                   save restart data.
C             2 --  store YHP into Y and YP, reorthonormalization,
C                   no restarts.
C                   (preset orthonormalization mode)
C             3 --  store YHP into Y and YP, reorthonormalization
C                   (when INHOMO=3 and X=XEND).
C **********************************************************************
C   OUTPUT
C *********
C     Y, YP = orthonormalized solutions.
C     NIV = number of independent vectors returned from DMGSBV.
C     IFLAG = 0 --  reorthonormalization was performed.
C            10 --  solution process must be restarted at the last
C                   orthonormalization point.
C            30 --  solutions are linearly dependent, problem must
C                   be restarted from the beginning.
C     W, P, IP = orthonormalization information.
C **********************************************************************
C
C***SEE ALSO  DBVSUP
C***ROUTINES CALLED  DDOT, DMGSBV, DSTOR1, DSTWAY
C***COMMON BLOCKS    DML15T, DML18J, DML8SZ
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DREORT
C
      DOUBLE PRECISION DDOT
      INTEGER ICOCO, IFLAG, IGOFX, IJK, INDPVT, INFO, INHOMO, INTEG,
     1     IP(*), ISTKOP, IVP, J, K, KK, KNSWOT, KOP, L, LOTJP, MFLAG,
     2     MNSWOT, MXNON, NCOMP, NCOMPD, NDISK, NEQ, NEQIVP, NFC,
     3     NFCC, NFCP, NIC, NIV, NOPG, NPS, NSWOT, NTAPE, NTP, NUMORT,
     4     NXPTS
      DOUBLE PRECISION AE, C, DND, DNDT, DX, P(*), PWCND, PX, RE, S(*),
     1     SRP, STOWA(*), TND, TOL, VNORM, W(*), WCND, X, XBEG, XEND,
     2     XOP, XOT, XSAV, Y(NCOMP,*), YHP(NCOMP,*), YP(*), YPNM
C
C     ******************************************************************
C
      COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFC
      COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
     1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
      COMMON /DML18J/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ,
     1                INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC,
     2                ICOCO
C
C **********************************************************************
C     BEGIN BLOCK PERMITTING ...EXITS TO 210
C        BEGIN BLOCK PERMITTING ...EXITS TO 10
C***FIRST EXECUTABLE STATEMENT  DREORT
            NFCP = NFC + 1
C
C           CHECK TO SEE IF ORTHONORMALIZATION TEST IS TO BE PERFORMED
C
C        ...EXIT
            IF (IFLAG .NE. 1) GO TO 10
            KNSWOT = KNSWOT + 1
C        ...EXIT
            IF (KNSWOT .GE. NSWOT) GO TO 10
C     ......EXIT
            IF ((XEND - X)*(X - XOT) .LT. 0.0D0) GO TO 210
   10    CONTINUE
         CALL DSTOR1(Y,YHP,YP,YHP(1,NFCP),1,0,0)
C
C        ***************************************************************
C
C        ORTHOGONALIZE THE HOMOGENEOUS SOLUTIONS Y
C        AND PARTICULAR SOLUTION YP.
C
         NIV = NFC
         CALL DMGSBV(NCOMP,NFC,Y,NCOMP,NIV,MFLAG,S,P,IP,INHOMO,YP,W,
     1               WCND)
C
C           ************************************************************
C
C        CHECK FOR LINEAR DEPENDENCE OF THE SOLUTIONS.
C
         IF (MFLAG .EQ. 0) GO TO 50
C           BEGIN BLOCK PERMITTING ...EXITS TO 40
               IF (IFLAG .EQ. 2) GO TO 30
                  IF (NSWOT .LE. 1 .AND. LOTJP .NE. 0) GO TO 20
C
C                    RETRIEVE DATA FOR A RESTART AT LAST
C                    ORTHONORMALIZATION POINT
C
                     CALL DSTWAY(Y,YP,YHP,1,STOWA)
                     LOTJP = 1
                     NSWOT = 1
                     KNSWOT = 0
                     MNSWOT = MNSWOT/2
                     TND = TND + 1.0D0
                     IFLAG = 10
C           .........EXIT
                     GO TO 40
   20             CONTINUE
   30          CONTINUE
               IFLAG = 30
   40       CONTINUE
         GO TO 200
   50    CONTINUE
C           BEGIN BLOCK PERMITTING ...EXITS TO 190
C              BEGIN BLOCK PERMITTING ...EXITS TO 110
C
C                 ******************************************************
C
C              ...EXIT
                  IF (IFLAG .NE. 1) GO TO 110
C
C                 TEST FOR ORTHONORMALIZATION
C
C              ...EXIT
                  IF (WCND .LT. 50.0D0*TOL) GO TO 110
                  DO 60 IJK = 1, NFCP
C              ......EXIT
                     IF (S(IJK) .GT. 1.0D20) GO TO 110
   60             CONTINUE
C
C                 USE LINEAR EXTRAPOLATION ON LOGARITHMIC VALUES OF THE
C                 NORM DECREMENTS TO DETERMINE NEXT ORTHONORMALIZATION
C                 CHECKPOINT.  OTHER CONTROLS ON THE NUMBER OF STEPS TO
C                 THE NEXT CHECKPOINT ARE ADDED FOR SAFETY PURPOSES.
C
                  NSWOT = KNSWOT
                  KNSWOT = 0
                  LOTJP = 0
                  WCND = LOG10(WCND)
                  IF (WCND .GT. TND + 3.0D0) NSWOT = 2*NSWOT
                  IF (WCND .LT. PWCND) GO TO 70
                     XOT = XEND
                     NSWOT = MIN(MNSWOT,NSWOT)
                     PWCND = WCND
                     PX = X
                  GO TO 100
   70             CONTINUE
                     DX = X - PX
                     DND = PWCND - WCND
                     IF (DND .GE. 4) NSWOT = NSWOT/2
                     DNDT = WCND - TND
                     IF (ABS(DX*DNDT) .LE. DND*ABS(XEND-X)) GO TO 80
                        XOT = XEND
                        NSWOT = MIN(MNSWOT,NSWOT)
                        PWCND = WCND
                        PX = X
                     GO TO 90
   80                CONTINUE
                        XOT = X + DX*DNDT/DND
                        NSWOT = MIN(MNSWOT,NSWOT)
                        PWCND = WCND
                        PX = X
   90                CONTINUE
  100             CONTINUE
C           ......EXIT
                  GO TO 190
  110          CONTINUE
C
C              *********************************************************
C
C              ORTHONORMALIZATION NECESSARY SO WE NORMALIZE THE
C              HOMOGENEOUS SOLUTION VECTORS AND CHANGE W ACCORDINGLY.
C
               NSWOT = 1
               KNSWOT = 0
               LOTJP = 1
               KK = 1
               L = 1
               DO 150 K = 1, NFCC
C                 BEGIN BLOCK PERMITTING ...EXITS TO 140
                     SRP = SQRT(P(KK))
                     IF (INHOMO .EQ. 1) W(K) = SRP*W(K)
                     VNORM = 1.0D0/SRP
                     P(KK) = VNORM
                     KK = KK + NFCC + 1 - K
                     IF (NFC .EQ. NFCC) GO TO 120
C                 ......EXIT
                        IF (L .NE. K/2) GO TO 140
  120                CONTINUE
                     DO 130 J = 1, NCOMP
                        Y(J,L) = Y(J,L)*VNORM
  130                CONTINUE
                     L = L + 1
  140             CONTINUE
  150          CONTINUE
C
               IF (INHOMO .NE. 1 .OR. NPS .EQ. 1) GO TO 180
C
C                 NORMALIZE THE PARTICULAR SOLUTION
C
                  YPNM = DDOT(NCOMP,YP,1,YP,1)
                  IF (YPNM .EQ. 0.0D0) YPNM = 1.0D0
                  YPNM = SQRT(YPNM)
                  S(NFCP) = YPNM
                  DO 160 J = 1, NCOMP
                     YP(J) = YP(J)/YPNM
  160             CONTINUE
                  DO 170 J = 1, NFCC
                     W(J) = C*W(J)
  170             CONTINUE
  180          CONTINUE
C
               IF (IFLAG .EQ. 1) CALL DSTWAY(Y,YP,YHP,0,STOWA)
               IFLAG = 0
  190       CONTINUE
  200    CONTINUE
  210 CONTINUE
      RETURN
      END
*DECK DRF
      DOUBLE PRECISION FUNCTION DRF (X, Y, Z, IER)
C***BEGIN PROLOGUE  DRF
C***PURPOSE  Compute the incomplete or complete elliptic integral of the
C            1st kind.  For X, Y, and Z non-negative and at most one of
C            them zero, RF(X,Y,Z) = Integral from zero to infinity of
C                                -1/2     -1/2     -1/2
C                      (1/2)(t+X)    (t+Y)    (t+Z)    dt.
C            If X, Y or Z is zero, the integral is complete.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      DOUBLE PRECISION (RF-S, DRF-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     DRF
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the first kind
C          Standard FORTRAN function routine
C          Double precision version
C          The routine calculates an approximation result to
C          DRF(X,Y,Z) = Integral from zero to infinity of
C
C                               -1/2     -1/2     -1/2
C                     (1/2)(t+X)    (t+Y)    (t+Z)    dt,
C
C          where X, Y, and Z are nonnegative and at most one of them
C          is zero.  If one of them  is zero, the integral is COMPLETE.
C          The duplication theorem is iterated until the variables are
C          nearly equal, and the function is then expanded in Taylor
C          series to fifth order.
C
C   2.     Calling sequence
C          DRF( X, Y, Z, IER )
C
C          Parameters On entry
C          Values assigned by the calling routine
C
C          X      - Double precision, nonnegative variable
C
C          Y      - Double precision, nonnegative variable
C
C          Z      - Double precision, nonnegative variable
C
C
C
C          On Return    (values assigned by the DRF routine)
C
C          DRF     - Double precision approximation to the integral
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine. It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C          X, Y, Z are unaltered.
C
C
C   3.    Error Messages
C
C
C         Value of IER assigned by the DRF routine
C
C                  Value assigned         Error Message Printed
C                  IER = 1                MIN(X,Y,Z) .LT. 0.0D0
C                      = 2                MIN(X+Y,X+Z,Y+Z) .LT. LOLIM
C                      = 3                MAX(X,Y,Z) .GT. UPLIM
C
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X, Y and Z
C
C          LOLIM  - Lower limit of valid arguments
C
C                   Not less than 5 * (machine minimum).
C
C          UPLIM  - Upper limit of valid arguments
C
C                   Not greater than (machine maximum) / 5.
C
C
C                     Acceptable values for:   LOLIM      UPLIM
C                     IBM 360/370 SERIES   :   3.0D-78     1.0D+75
C                     CDC 6000/7000 SERIES :   1.0D-292    1.0D+321
C                     UNIVAC 1100 SERIES   :   1.0D-307    1.0D+307
C                     CRAY                 :   2.3D-2466   1.09D+2465
C                     VAX 11 SERIES        :   1.5D-38     3.0D+37
C
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C
C          ERRTOL - Relative error due to truncation is less than
C                   ERRTOL ** 6 / (4 * (1-ERRTOL)  .
C
C
C
C        The accuracy of the computed approximation to the integral
C        can be controlled by choosing the value of ERRTOL.
C        Truncation of a Taylor series after terms of fifth order
C        introduces an error less than the amount shown in the
C        second column of the following table for each value of
C        ERRTOL in the first column.  In addition to the truncation
C        error there will be round-off error, but in practice the
C        total error from both sources is usually less than the
C        amount given in the table.
C
C
C
C
C
C          Sample choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0D-3    3.0D-19
C                           3.0D-3    2.0D-16
C                           1.0D-2    3.0D-13
C                           3.0D-2    2.0D-10
C                           1.0D-1    3.0D-7
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   DRF Special Comments
C
C
C
C          Check by addition theorem: DRF(X,X+Z,X+W) + DRF(Y,Y+Z,Y+W)
C          = DRF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W.
C
C
C          On Input:
C
C          X, Y, and Z are the variables in the integral DRF(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, Z are unaltered.
C
C
C
C          ********************************************************
C
C          WARNING: Changes in the program may improve speed at the
C                   expense of robustness.
C
C
C
C   Special double precision functions via DRF
C
C
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 1st kind
C
C                  -----------------------------------------
C
C
C
C                                             2         2   2
C                  F(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1)
C
C
C                                  2
C                  K(K) = DRF(0,1-K ,1)
C
C
C                         PI/2     2   2      -1/2
C                       = INT  (1-K SIN (PHI) )   D PHI
C                          0
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 1st kind
C
C                  -----------------------------------------
C
C
C                                          2 2    2
C                  EL1(X,KC) = X DRF(1,1+KC X ,1+X )
C
C
C                  Lemniscate constant A
C
C                  -----------------------------------------
C
C
C                       1      4 -1/2
C                  A = INT (1-S )    DS = DRF(0,1,2) = DRF(0,2,1)
C                       0
C
C
C
C    -------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC))
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DRF
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH
      DOUBLE PRECISION C1, C2, C3, E2, E3, LAMDA
      DOUBLE PRECISION MU, S, X, XN, XNDEV
      DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  DRF
C
      IF (FIRST) THEN
         ERRTOL = (4.0D0*D1MACH(3))**(1.0D0/6.0D0)
         LOLIM  = 5.0D0 * D1MACH(1)
         UPLIM  = D1MACH(2)/5.0D0
C
         C1 = 1.0D0/24.0D0
         C2 = 3.0D0/44.0D0
         C3 = 1.0D0/14.0D0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      DRF = 0.0D0
      IF (MIN(X,Y,Z).LT.0.0D0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         CALL XERMSG ('SLATEC', 'DRF',
     *      'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 //
     *      ' AND Z = ' // XERN5, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y,Z).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'DRF',
     *      'MAX(X,Y,Z).GT.UPLIM WHERE X = '  // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, 3, 1)
         RETURN
      ENDIF
C
      IF (MIN(X+Y,X+Z,Y+Z).LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'DRF',
     *      'MIN(X+Y,X+Z,Y+Z).LT.LOLIM WHERE X = ' // XERN3 //
     *      ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' //
     *      XERN6, 2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
C
   30 MU = (XN+YN+ZN)/3.0D0
      XNDEV = 2.0D0 - (MU+XN)/MU
      YNDEV = 2.0D0 - (MU+YN)/MU
      ZNDEV = 2.0D0 - (MU+ZN)/MU
      EPSLON = MAX(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT = SQRT(XN)
      YNROOT = SQRT(YN)
      ZNROOT = SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      XN = (XN+LAMDA)*0.250D0
      YN = (YN+LAMDA)*0.250D0
      ZN = (ZN+LAMDA)*0.250D0
      GO TO 30
C
   40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV
      E3 = XNDEV*YNDEV*ZNDEV
      S  = 1.0D0 + (C1*E2-0.10D0-C2*E3)*E2 + C3*E3
      DRF = S/SQRT(MU)
C
      RETURN
      END
*DECK DRJ
      DOUBLE PRECISION FUNCTION DRJ (X, Y, Z, P, IER)
C***BEGIN PROLOGUE  DRJ
C***PURPOSE  Compute the incomplete or complete (X or Y or Z is zero)
C            elliptic integral of the 3rd kind.  For X, Y, and Z non-
C            negative, at most one of them zero, and P positive,
C             RJ(X,Y,Z,P) = Integral from zero to infinity of
C                              -1/2     -1/2     -1/2     -1
C                    (3/2)(t+X)    (t+Y)    (t+Z)    (t+P)  dt.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      DOUBLE PRECISION (RJ-S, DRJ-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE THIRD KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     DRJ
C          Standard FORTRAN function routine
C          Double precision version
C          The routine calculates an approximation result to
C          DRJ(X,Y,Z,P) = Integral from zero to infinity of
C
C                                -1/2     -1/2     -1/2     -1
C                      (3/2)(t+X)    (t+Y)    (t+Z)    (t+P)  dt,
C
C          where X, Y, and Z are nonnegative, at most one of them is
C          zero, and P is positive.  If X or Y or Z is zero, the
C          integral is COMPLETE.  The duplication theorem is iterated
C          until the variables are nearly equal, and the function is
C          then expanded in Taylor series to fifth order.
C
C
C   2.     Calling Sequence
C          DRJ( X, Y, Z, P, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Double precision, nonnegative variable
C
C          Y      - Double precision, nonnegative variable
C
C          Z      - Double precision, nonnegative variable
C
C          P      - Double precision, positive variable
C
C
C          On  Return    (values assigned by the DRJ routine)
C
C          DRJ     - Double precision approximation to the integral
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine. It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C
C          X, Y, Z, P are unaltered.
C
C
C   3.    Error Messages
C
C         Value of IER assigned by the DRJ routine
C
C              Value assigned         Error Message printed
C              IER = 1                MIN(X,Y,Z) .LT. 0.0D0
C                  = 2                MIN(X+Y,X+Z,Y+Z,P) .LT. LOLIM
C                  = 3                MAX(X,Y,Z,P) .GT. UPLIM
C
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C
C          LOLIM and UPLIM determine the valid range of X, Y, Z, and P
C
C          LOLIM is not less than the cube root of the value
C          of LOLIM used in the routine for DRC.
C
C          UPLIM is not greater than 0.3 times the cube root of
C          the value of UPLIM used in the routine for DRC.
C
C
C                     Acceptable values for:   LOLIM      UPLIM
C                     IBM 360/370 SERIES   :   2.0D-26     3.0D+24
C                     CDC 6000/7000 SERIES :   5.0D-98     3.0D+106
C                     UNIVAC 1100 SERIES   :   5.0D-103    6.0D+101
C                     CRAY                 :   1.32D-822   1.4D+821
C                     VAX 11 SERIES        :   2.5D-13     9.0D+11
C
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 the value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C
C
C          Relative error due to truncation of the series for DRJ
C          is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C
C
C
C        The accuracy of the computed approximation to the integral
C        can be controlled by choosing the value of ERRTOL.
C        Truncation of a Taylor series after terms of fifth order
C        introduces an error less than the amount shown in the
C        second column of the following table for each value of
C        ERRTOL in the first column.  In addition to the truncation
C        error there will be round-off error, but in practice the
C        total error from both sources is usually less than the
C        amount given in the table.
C
C
C
C          Sample choices:  ERRTOL   Relative truncation
C                                    error less than
C                           1.0D-3    4.0D-18
C                           3.0D-3    3.0D-15
C                           1.0D-2    4.0D-12
C                           3.0D-2    3.0D-9
C                           1.0D-1    4.0D-6
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   DRJ Special Comments
C
C
C     Check by addition theorem: DRJ(X,X+Z,X+W,X+P)
C     + DRJ(Y,Y+Z,Y+W,Y+P) + (A-B) * DRJ(A,B,B,A) + 3.0D0 / SQRT(A)
C     = DRJ(0,Z,W,P), where X,Y,Z,W,P are positive and X * Y
C     = Z * W,  A = P * P * (X+Y+Z+W),  B = P * (P+X) * (P+Y),
C     and B - A = P * (P-Z) * (P-W).  The sum of the third and
C     fourth terms on the left side is 3.0D0 * DRC(A,B).
C
C
C          On Input:
C
C     X, Y, Z, and P are the variables in the integral DRJ(X,Y,Z,P).
C
C
C          On Output:
C
C
C          X, Y, Z, P are unaltered.
C
C          ********************************************************
C
C          WARNING: Changes in the program may improve speed at the
C                   expense of robustness.
C
C    -------------------------------------------------------------------
C
C
C   Special double precision functions via DRJ and DRF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 3rd kind
C                  -----------------------------------------
C
C
C                          PHI         2         -1
C             P(PHI,K,N) = INT (1+N SIN (THETA) )   *
C                           0
C
C
C                                  2    2         -1/2
C                             *(1-K  SIN (THETA) )     D THETA
C
C
C                                           2          2   2
C                        = SIN (PHI) DRF(COS (PHI), 1-K SIN (PHI),1)
C
C                                   3             2         2   2
C                         -(N/3) SIN (PHI) DRJ(COS (PHI),1-K SIN (PHI),
C
C                                  2
C                         1,1+N SIN (PHI))
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 3rd kind
C                  -----------------------------------------
C
C
C                                            2 2    2
C                  EL3(X,KC,P) = X DRF(1,1+KC X ,1+X ) +
C
C                                            3           2 2    2     2
C                               +(1/3)(1-P) X  DRJ(1,1+KC X ,1+X ,1+PX )
C
C
C                                           2
C                  CEL(KC,P,A,B) = A RF(0,KC ,1) +
C
C
C                                                      2
C                                 +(1/3)(B-PA) DRJ(0,KC ,1,P)
C
C
C                  Heuman's LAMBDA function
C                  -----------------------------------------
C
C
C                                2                      2      2    1/2
C                  L(A,B,P) =(COS (A)SIN(B)COS(B)/(1-COS (A)SIN (B))   )
C
C                                            2         2       2
C                            *(SIN(P) DRF(COS (P),1-SIN (A) SIN (P),1)
C
C                                 2       3            2       2
C                            +(SIN (A) SIN (P)/(3(1-COS (A) SIN (B))))
C
C                                    2         2       2
C                            *DRJ(COS (P),1-SIN (A) SIN (P),1,1-
C
C                                2       2          2       2
C                            -SIN (A) SIN (P)/(1-COS (A) SIN (B))))
C
C
C
C                  (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) =
C
C                   2                         2       2    -1/2
C              = COS (A)  SIN(B) COS(B) (1-COS (A) SIN (B))
C
C                           2                  2       2
C                 *DRF(0,COS (A),1) + (1/3) SIN (A) COS (A)
C
C                                      2       2    -3/2
C                 *SIN(B) COS(B) (1-COS (A) SIN (B))
C
C                           2         2       2          2       2
C                 *DRJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B)))
C
C
C                  Jacobi ZETA function
C                  -----------------------------------------
C
C                        2                     2   2    1/2
C             Z(B,K) = (K/3) SIN(B) COS(B) (1-K SIN (B))
C
C
C                                  2      2   2                 2
C                        *DRJ(0,1-K ,1,1-K SIN (B)) / DRF (0,1-K ,1)
C
C
C  ---------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  D1MACH, DRC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC)).
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DRJ
      INTEGER IER
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6, XERN7
      DOUBLE PRECISION ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3
      DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH
      DOUBLE PRECISION LAMDA, MU, P, PN, PNDEV
      DOUBLE PRECISION POWER4, DRC, SIGMA, S1, S2, S3, X, XN, XNDEV
      DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,C4,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  DRJ
      IF (FIRST) THEN
         ERRTOL = (D1MACH(3)/3.0D0)**(1.0D0/6.0D0)
         LOLIM  = (5.0D0 * D1MACH(1))**(1.0D0/3.0D0)
         UPLIM  = 0.30D0*( D1MACH(2) / 5.0D0)**(1.0D0/3.0D0)
C
         C1 = 3.0D0/14.0D0
         C2 = 1.0D0/3.0D0
         C3 = 3.0D0/22.0D0
         C4 = 3.0D0/26.0D0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      DRJ = 0.0D0
      IF (MIN(X,Y,Z).LT.0.0D0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         CALL XERMSG ('SLATEC', 'DRJ',
     *      'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 //
     *      ' AND Z = ' // XERN5, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y,Z,P).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') P
         WRITE (XERN7, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'DRJ',
     *      'MAX(X,Y,Z,P).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' P = ' // XERN6 //
     *      ' AND UPLIM = ' // XERN7, 3, 1)
         RETURN
      ENDIF
C
      IF (MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') P
         WRITE (XERN7, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'RJ',
     *      'MIN(X+Y,X+Z,Y+Z,P).LT.LOLIM WHERE X = ' // XERN3 //
     *      ' Y = ' // XERN4 // ' Z = '  // XERN5 // ' P = ' // XERN6 //
     *      ' AND LOLIM = ', 2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
      PN = P
      SIGMA = 0.0D0
      POWER4 = 1.0D0
C
   30 MU = (XN+YN+ZN+PN+PN)*0.20D0
      XNDEV = (MU-XN)/MU
      YNDEV = (MU-YN)/MU
      ZNDEV = (MU-ZN)/MU
      PNDEV = (MU-PN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV), ABS(PNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT =  SQRT(XN)
      YNROOT =  SQRT(YN)
      ZNROOT =  SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      ALFA = PN*(XNROOT+YNROOT+ZNROOT) + XNROOT*YNROOT*ZNROOT
      ALFA = ALFA*ALFA
      BETA = PN*(PN+LAMDA)*(PN+LAMDA)
      SIGMA = SIGMA + POWER4*DRC(ALFA,BETA,IER)
      POWER4 = POWER4*0.250D0
      XN = (XN+LAMDA)*0.250D0
      YN = (YN+LAMDA)*0.250D0
      ZN = (ZN+LAMDA)*0.250D0
      PN = (PN+LAMDA)*0.250D0
      GO TO 30
C
   40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV
      EB = XNDEV*YNDEV*ZNDEV
      EC = PNDEV*PNDEV
      E2 = EA - 3.0D0*EC
      E3 = EB + 2.0D0*PNDEV*(EA-EC)
      S1 = 1.0D0 + E2*(-C1+0.750D0*C3*E2-1.50D0*C4*E3)
      S2 = EB*(0.50D0*C2+PNDEV*(-C3-C3+PNDEV*C4))
      S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC
      DRJ = 3.0D0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU))
      RETURN
      END
*DECK DRKFAB
      SUBROUTINE DRKFAB (NCOMP, XPTS, NXPTS, NFC, IFLAG, Z, MXNON, P,
     +   NTP, IP, YHP, NIV, U, V, W, S, STOWA, G, WORK, IWORK, NFCC)
C***BEGIN PROLOGUE  DRKFAB
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (RKFAB-S, DRKFAB-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C
C     Subroutine DRKFAB integrates the initial value equations using
C     the variable-step Runge-Kutta-Fehlberg integration scheme or
C     the variable-order Adams method and orthonormalization
C     determined by a linear dependence test.
C
C **********************************************************************
C
C***SEE ALSO  DBVSUP
C***ROUTINES CALLED  DBVDER, DDEABM, DDERKF, DREORT, DSTOR1
C***COMMON BLOCKS    DML15T, DML17B, DML18J, DML8SZ
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DRKFAB
C
      INTEGER ICOCO, IDID, IFLAG, IGOFX, INDPVT, INFO, INHOMO, INTEG,
     1     IPAR, ISTKOP, IVP, J, JFLAG, JON,
     2     K1, K10, K11, K2, K3, K4, K5, K6, K7, K8, K9, KKKINT,
     3     KKKZPW, KNSWOT, KOD, KOP, KOPP, L1, L2, LLLINT, LOTJP,
     4     MNSWOT, MXNON, MXNOND, NCOMP, NCOMPD, NDISK, NEEDIW, NEEDW,
     5     NEQ, NEQIVP, NFC, NFCC, NFCCD, NFCD, NFCP1, NIC, NIV, NON,
     6     NOPG, NPS, NSWOT, NTAPE, NTP, NTPD, NUMORT, NXPTS, NXPTSD,
     7     IP(NFCC,*), IWORK(*)
      DOUBLE PRECISION AE, C, G(*), P(NTP,*), PWCND, PX, RE,
     1     S(*), STOWA(*), TND, TOL, U(NCOMP,NFC,*),
     2     V(NCOMP,*), W(NFCC,*), WORK(*), X, XBEG, XEND, XOP,
     3     XOT, XPTS(*), XSAV, XXOP, YHP(NCOMP,*), Z(*)
C
C     ******************************************************************
C
      COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD
      COMMON /DML15T/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
     1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
      COMMON /DML18J/ AE,RE,TOL,NXPTSD,NIC,NOPG,MXNOND,NDISK,NTAPE,NEQ,
     1                INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD,
     2                ICOCO
      COMMON /DML17B/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9,
     1                K10,K11,L1,L2,KKKINT,LLLINT
C
      EXTERNAL DBVDER
C
C      *****************************************************************
C       INITIALIZATION OF COUNTERS AND VARIABLES.
C
C     BEGIN BLOCK PERMITTING ...EXITS TO 220
C        BEGIN BLOCK PERMITTING ...EXITS TO 10
C***FIRST EXECUTABLE STATEMENT  DRKFAB
            KOD = 1
            NON = 1
            X = XBEG
            JON = 1
            INFO(1) = 0
            INFO(2) = 0
            INFO(3) = 1
            INFO(4) = 1
            WORK(1) = XEND
C        ...EXIT
            IF (NOPG .EQ. 0) GO TO 10
            INFO(3) = 0
            IF (X .EQ. Z(1)) JON = 2
   10    CONTINUE
         NFCP1 = NFC + 1
C
C        ***************************************************************
C        *****BEGINNING OF INTEGRATION LOOP AT OUTPUT
C        POINTS.******************
C        ***************************************************************
C
         DO 210 KOPP = 2, NXPTS
            KOP = KOPP
            XOP = XPTS(KOP)
            IF (NDISK .EQ. 0) KOD = KOP
C
   20       CONTINUE
C
C              STEP BY STEP INTEGRATION LOOP BETWEEN OUTPUT POINTS.
C
C              BEGIN BLOCK PERMITTING ...EXITS TO 190
C                 BEGIN BLOCK PERMITTING ...EXITS TO 30
                     XXOP = XOP
C                 ...EXIT
                     IF (NOPG .EQ. 0) GO TO 30
                     IF (XEND .GT. XBEG .AND. XOP .GT. Z(JON))
     1                  XXOP = Z(JON)
                     IF (XEND .LT. XBEG .AND. XOP .LT. Z(JON))
     1                  XXOP = Z(JON)
   30             CONTINUE
C
C                 ******************************************************
   40             CONTINUE
C                    BEGIN BLOCK PERMITTING ...EXITS TO 170
                        GO TO (50,60), INTEG
C                       DDERKF INTEGRATOR
C
   50                   CONTINUE
                           CALL DDERKF(DBVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,
     1                                 IDID,WORK,KKKINT,IWORK,LLLINT,G,
     2                                 IPAR)
                        GO TO 70
C                       DDEABM INTEGRATOR
C
   60                   CONTINUE
                           CALL DDEABM(DBVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,
     1                                 IDID,WORK,KKKINT,IWORK,LLLINT,G,
     2                                 IPAR)
   70                   CONTINUE
                        IF (IDID .GE. 1) GO TO 80
                           INFO(1) = 1
C                    ......EXIT
                           IF (IDID .EQ. -1) GO TO 170
                           IFLAG = 20 - IDID
C     .....................EXIT
                           GO TO 220
   80                   CONTINUE
C
C                       ************************************************
C                           GRAM-SCHMIDT ORTHOGONALIZATION TEST FOR
C                           ORTHONORMALIZATION (TEMPORARILY USING U AND
C                           V IN THE TEST)
C
                        IF (NOPG .EQ. 0) GO TO 100
                           IF (XXOP .EQ. Z(JON)) GO TO 90
C
C                             ******************************************
C                                 CONTINUE INTEGRATION IF WE ARE NOT AT
C                                 AN OUTPUT POINT.
C
C           ..................EXIT
                              IF (IDID .NE. 1) GO TO 200
C                    .........EXIT
                              GO TO 170
   90                      CONTINUE
                           JFLAG = 2
                        GO TO 110
  100                   CONTINUE
                           JFLAG = 1
                           IF (INHOMO .EQ. 3 .AND. X .EQ. XEND)
     1                        JFLAG = 3
  110                   CONTINUE
C
                        IF (NDISK .EQ. 0) NON = NUMORT + 1
                        CALL DREORT(NCOMP,U(1,1,KOD),V(1,KOD),YHP,NIV,
     1                              W(1,NON),S,P(1,NON),IP(1,NON),STOWA,
     2                              JFLAG)
C
                        IF (JFLAG .NE. 30) GO TO 120
                           IFLAG = 30
C     .....................EXIT
                           GO TO 220
  120                   CONTINUE
C
                        IF (JFLAG .NE. 10) GO TO 130
                           XOP = XPTS(KOP)
                           IF (NDISK .EQ. 0) KOD = KOP
C              ............EXIT
                           GO TO 190
  130                   CONTINUE
C
                        IF (JFLAG .EQ. 0) GO TO 140
C
C                          *********************************************
C                              CONTINUE INTEGRATION IF WE ARE NOT AT AN
C                              OUTPUT POINT.
C
C           ...............EXIT
                           IF (IDID .NE. 1) GO TO 200
C                    ......EXIT
                           GO TO 170
  140                   CONTINUE
C
C                       ************************************************
C                           STORE ORTHONORMALIZED VECTORS INTO SOLUTION
C                           VECTORS.
C
                        IF (NUMORT .LT. MXNON) GO TO 150
                        IF (X .EQ. XEND) GO TO 150
                           IFLAG = 13
C     .....................EXIT
                           GO TO 220
  150                   CONTINUE
C
                        NUMORT = NUMORT + 1
                        CALL DSTOR1(YHP,U(1,1,KOD),YHP(1,NFCP1),
     1                              V(1,KOD),1,NDISK,NTAPE)
C
C                       ************************************************
C                           STORE ORTHONORMALIZATION INFORMATION,
C                           INITIALIZE INTEGRATION FLAG, AND CONTINUE
C                           INTEGRATION TO THE NEXT ORTHONORMALIZATION
C                           POINT OR OUTPUT POINT.
C
                        Z(NUMORT) = X
                        IF (INHOMO .EQ. 1 .AND. NPS .EQ. 0)
     1                     C = S(NFCP1)*C
                        IF (NDISK .EQ. 0) GO TO 160
                           IF (INHOMO .EQ. 1)
     1                        WRITE (NTAPE) (W(J,1), J = 1, NFCC)
                           WRITE (NTAPE)
     1                           (IP(J,1), J = 1, NFCC),
     2                           (P(J,1), J = 1, NTP)
  160                   CONTINUE
                        INFO(1) = 0
                        JON = JON + 1
C                 ......EXIT
                        IF (NOPG .EQ. 1 .AND. X .NE. XOP) GO TO 180
C
C                       ************************************************
C                           CONTINUE INTEGRATION IF WE ARE NOT AT AN
C                           OUTPUT POINT.
C
C           ............EXIT
                        IF (IDID .NE. 1) GO TO 200
  170                CONTINUE
                  GO TO 40
  180             CONTINUE
  190          CONTINUE
            GO TO 20
  200       CONTINUE
C
C           STORAGE OF HOMOGENEOUS SOLUTIONS IN U AND THE PARTICULAR
C           SOLUTION IN V AT THE OUTPUT POINTS.
C
            CALL DSTOR1(U(1,1,KOD),YHP,V(1,KOD),YHP(1,NFCP1),0,NDISK,
     1                  NTAPE)
  210    CONTINUE
C        ***************************************************************
C        ***************************************************************
C
         IFLAG = 0
  220 CONTINUE
      RETURN
      END
*DECK DRKFS
      SUBROUTINE DRKFS (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, H,
     +   TOLFAC, YP, F1, F2, F3, F4, F5, YS, TOLD, DTSIGN, U26, RER,
     +   INIT, KSTEPS, KOP, IQUIT, STIFF, NONSTF, NTSTEP, NSTIFS, RPAR,
     +   IPAR)
C***BEGIN PROLOGUE  DRKFS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DDERKF
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (DERKFS-S, DRKFS-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C     Fehlberg Fourth-Fifth Order Runge-Kutta Method
C **********************************************************************
C
C     DRKFS integrates a system of first order ordinary differential
C     equations as described in the comments for DDERKF .
C
C     The arrays YP,F1,F2,F3,F4,F5,and YS  (of length at least NEQ)
C     appear in the call list for variable dimensioning purposes.
C
C     The variables H,TOLFAC,TOLD,DTSIGN,U26,RER,INIT,KSTEPS,KOP,IQUIT,
C     STIFF,NONSTF,NTSTEP, and NSTIFS are used internally by the code
C     and appear in the call list to eliminate local retention of
C     variables between calls. Accordingly, these variables and the
C     array YP should not be altered.
C     Items of possible interest are
C         H  - An appropriate step size to be used for the next step
C         TOLFAC - Factor of change in the tolerances
C         YP - Derivative of solution vector at T
C         KSTEPS - Counter on the number of steps attempted
C
C **********************************************************************
C
C***SEE ALSO  DDERKF
C***ROUTINES CALLED  D1MACH, DFEHL, DHSTRT, DHVNRM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891024  Changed references from DVNORM to DHVNRM.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls, change GOTOs to
C           IF-THEN-ELSEs.  (RWC)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DRKFS
C
      INTEGER IDID, INFO, INIT, IPAR, IQUIT, K, KOP, KSTEPS, KTOL,
     1      MXKOP, MXSTEP, NATOLP, NEQ, NRTOLP, NSTIFS, NTSTEP
      DOUBLE PRECISION A, ATOL, BIG, D1MACH,
     1      DT, DTSIGN, DHVNRM, DY, EE, EEOET, ES, ESTIFF,
     2      ESTTOL, ET, F1, F2, F3, F4, F5, H, HMIN, REMIN, RER, RPAR,
     3      RTOL, S, T, TOL, TOLD, TOLFAC, TOUT, U, U26, UTE, Y, YAVG,
     4      YP, YS
      LOGICAL HFAILD,OUTPUT,STIFF,NONSTF
      CHARACTER*8 XERN1
      CHARACTER*16 XERN3, XERN4
C
      DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*),
     1          YS(*),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*)
C
      EXTERNAL DF
C
C     ..................................................................
C
C       A FIFTH ORDER METHOD WILL GENERALLY NOT BE CAPABLE OF DELIVERING
C       ACCURACIES NEAR LIMITING PRECISION ON COMPUTERS WITH LONG
C       WORDLENGTHS. TO PROTECT AGAINST LIMITING PRECISION DIFFICULTIES
C       ARISING FROM UNREASONABLE ACCURACY REQUESTS, AN APPROPRIATE
C       TOLERANCE THRESHOLD REMIN IS ASSIGNED FOR THIS METHOD. THIS
C       VALUE SHOULD NOT BE CHANGED ACROSS DIFFERENT MACHINES.
C
      SAVE REMIN, MXSTEP, MXKOP
      DATA REMIN /1.0D-12/
C
C     ..................................................................
C
C       THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE
C       NUMBER OF  STEPS ATTEMPTED. WHEN THIS EXCEEDS  MXSTEP, THE
C       COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE
C       EXCESSIVE WORK.
C
      DATA MXSTEP /500/
C
C     ..................................................................
C
C       INEFFICIENCY CAUSED BY TOO FREQUENT OUTPUT IS MONITORED BY
C       COUNTING THE NUMBER OF STEP SIZES WHICH ARE SEVERELY SHORTENED
C       DUE SOLELY TO THE CHOICE OF OUTPUT POINTS. WHEN THE NUMBER OF
C       ABUSES EXCEED MXKOP, THE COUNTER IS RESET TO ZERO AND THE USER
C       IS INFORMED ABOUT POSSIBLE MISUSE OF THE CODE.
C
      DATA MXKOP /100/
C
C     ..................................................................
C
C***FIRST EXECUTABLE STATEMENT  DRKFS
      IF (INFO(1) .EQ. 0) THEN
C
C ON THE FIRST CALL , PERFORM INITIALIZATION --
C        DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY  U  BY CALLING THE
C        FUNCTION ROUTINE  D1MACH. THE USER MUST MAKE SURE THAT THE
C        VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED.
C
         U = D1MACH(4)
C                       -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS
         U26 = 26.0D0*U
         RER = 2.0D0*U + REMIN
C                       -- SET TERMINATION FLAG
         IQUIT = 0
C                       -- SET INITIALIZATION INDICATOR
         INIT = 0
C                       -- SET COUNTER FOR IMPACT OF OUTPUT POINTS
         KOP = 0
C                       -- SET COUNTER FOR ATTEMPTED STEPS
         KSTEPS = 0
C                       -- SET INDICATORS FOR STIFFNESS DETECTION
         STIFF = .FALSE.
         NONSTF = .FALSE.
C                       -- SET STEP COUNTERS FOR STIFFNESS DETECTION
         NTSTEP = 0
         NSTIFS = 0
C                       -- RESET INFO(1) FOR SUBSEQUENT CALLS
         INFO(1) = 1
      ENDIF
C
C.......................................................................
C
C        CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY
C
      IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN
         WRITE (XERN1, '(I8)') INFO(1)
         CALL XERMSG ('SLATEC', 'DRKFS',
     *      'IN DDERKF, INFO(1) MUST BE SET TO 0 ' //
     *      'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' //
     *      'FOLLOWING AN INTERRUPTED TASK.  YOU ARE ATTEMPTING TO ' //
     *      'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE CODE ' //
     *      'WITH  INFO(1) = ' // XERN1, 3, 1)
         IDID = -33
      ENDIF
C
      IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN
         WRITE (XERN1, '(I8)') INFO(2)
         CALL XERMSG ('SLATEC', 'DRKFS',
     *      'IN DDERKF, INFO(2) MUST BE 0 OR 1 ' //
     *      'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' //
     *      'RESPECTIVELY.  YOU HAVE CALLED THE CODE WITH INFO(2) = ' //
     *      XERN1, 4, 1)
         IDID = -33
      ENDIF
C
      IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN
         WRITE (XERN1, '(I8)') INFO(3)
         CALL XERMSG ('SLATEC', 'DRKFS',
     *      'IN DDERKF, INFO(3) MUST BE 0 OR 1 ' //
     *      'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' //
     *      'INTEGRATION, RESPECTIVELY.  YOU HAVE CALLED THE CODE ' //
     *      'WITH  INFO(3) = ' // XERN1, 5, 1)
         IDID = -33
      ENDIF
C
      IF (NEQ .LT. 1) THEN
         WRITE (XERN1, '(I8)') NEQ
         CALL XERMSG ('SLATEC', 'DRKFS',
     *      'IN DDERKF, THE NUMBER OF EQUATIONS ' //
     *      'NEQ MUST BE A POSITIVE INTEGER.  YOU HAVE CALLED THE ' //
     *      'CODE WITH NEQ = ' // XERN1, 6, 1)
         IDID = -33
      ENDIF
C
      NRTOLP = 0
      NATOLP = 0
      DO 10 K=1,NEQ
         IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN
            WRITE (XERN1, '(I8)') K
            WRITE (XERN3, '(1PE15.6)') RTOL(K)
            CALL XERMSG ('SLATEC', 'DRKFS',
     *         'IN DDERKF, THE RELATIVE ERROR ' //
     *         'TOLERANCES RTOL MUST BE NON-NEGATIVE.  YOU HAVE ' //
     *         'CALLED THE CODE WITH  RTOL(' // XERN1 // ') = ' //
     *         XERN3 // '.  IN THE CASE OF VECTOR ERROR TOLERANCES, ' //
     *         'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1)
            IDID = -33
            NRTOLP = 1
         ENDIF
C
         IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN
            WRITE (XERN1, '(I8)') K
            WRITE (XERN3, '(1PE15.6)') ATOL(K)
            CALL XERMSG ('SLATEC', 'DRKFS',
     *         'IN DDERKF, THE ABSOLUTE ERROR ' //
     *         'TOLERANCES ATOL MUST BE NON-NEGATIVE.  YOU HAVE ' //
     *         'CALLED THE CODE WITH  ATOL(' // XERN1 // ') = ' //
     *         XERN3 // '.  IN THE CASE OF VECTOR ERROR TOLERANCES, ' //
     *         'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1)
            IDID = -33
            NATOLP = 1
         ENDIF
C
         IF (INFO(2) .EQ. 0) GO TO 20
         IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 20
   10 CONTINUE
C
C
C     CHECK SOME CONTINUATION POSSIBILITIES
C
   20 IF (INIT .NE. 0) THEN
         IF (T .EQ. TOUT) THEN
            WRITE (XERN3, '(1PE15.6)') T
            CALL XERMSG ('SLATEC', 'DRKFS',
     *         'IN DDERKF, YOU HAVE CALLED THE ' //
     *         'CODE WITH  T = TOUT = ' // XERN3 // '$$THIS IS NOT ' //
     *         'ALLOWED ON CONTINUATION CALLS.', 9, 1)
            IDID=-33
         ENDIF
C
         IF (T .NE. TOLD) THEN
            WRITE (XERN3, '(1PE15.6)') TOLD
            WRITE (XERN4, '(1PE15.6)') T
            CALL XERMSG ('SLATEC', 'DRKFS',
     *         'IN DDERKF, YOU HAVE CHANGED THE ' //
     *         'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 //
     *         '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1)
            IDID=-33
         ENDIF
C
         IF (INIT .NE. 1) THEN
            IF (DTSIGN*(TOUT-T) .LT. 0.D0) THEN
               WRITE (XERN3, '(1PE15.6)') TOUT
               CALL XERMSG ('SLATEC', 'DRKFS',
     *            'IN DDERKF, BY CALLING THE CODE WITH TOUT = ' //
     *            XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' //
     *            'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' //
     *            'WITHOUT RESTARTING.', 11, 1)
               IDID=-33
            ENDIF
         ENDIF
      ENDIF
C
C     INVALID INPUT DETECTED
C
      IF (IDID .EQ. (-33)) THEN
         IF (IQUIT .NE. (-33)) THEN
            IQUIT = -33
            GOTO 540
         ELSE
            CALL XERMSG ('SLATEC', 'DRKFS',
     *         'IN DDERKF, INVALID INPUT WAS ' //
     *         'DETECTED ON SUCCESSIVE ENTRIES.  IT IS IMPOSSIBLE ' //
     *         'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' //
     *         'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2)
            RETURN
         ENDIF
      ENDIF
C
C           ............................................................
C
C                RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND
C                INTERPRETED AS ASKING FOR THE MOST ACCURATE SOLUTION
C                POSSIBLE. IN THIS CASE, THE RELATIVE ERROR TOLERANCE
C                RTOL IS RESET TO THE SMALLEST VALUE RER WHICH IS LIKELY
C                TO BE REASONABLE FOR THIS METHOD AND MACHINE.
C
            DO 190 K = 1, NEQ
               IF (RTOL(K) + ATOL(K) .GT. 0.0D0) GO TO 180
                  RTOL(K) = RER
                  IDID = -2
  180          CONTINUE
C           ...EXIT
               IF (INFO(2) .EQ. 0) GO TO 200
  190       CONTINUE
  200       CONTINUE
C
            IF (IDID .NE. (-2)) GO TO 210
C
C              RTOL=ATOL=0 ON INPUT, SO RTOL WAS CHANGED TO A
C                                       SMALL POSITIVE VALUE
               TOLFAC = 1.0D0
            GO TO 530
  210       CONTINUE
C
C                       BRANCH ON STATUS OF INITIALIZATION INDICATOR
C                              INIT=0 MEANS INITIAL DERIVATIVES AND
C                              STARTING STEP SIZE
C                                     NOT YET COMPUTED
C                              INIT=1 MEANS STARTING STEP SIZE NOT YET
C                              COMPUTED INIT=2 MEANS NO FURTHER
C                              INITIALIZATION REQUIRED
C
                        IF (INIT .EQ. 0) GO TO 220
C                    ......EXIT
                           IF (INIT .EQ. 1) GO TO 240
C                 .........EXIT
                           GO TO 260
  220                   CONTINUE
C
C                       ................................................
C
C                            MORE INITIALIZATION --
C                                                -- EVALUATE INITIAL
C                                                DERIVATIVES
C
                        INIT = 1
                        A = T
                        CALL DF(A,Y,YP,RPAR,IPAR)
                        IF (T .NE. TOUT) GO TO 230
C
C                          INTERVAL MODE
                           IDID = 2
                           T = TOUT
                           TOLD = T
C     .....................EXIT
                           GO TO 560
  230                   CONTINUE
  240                CONTINUE
C
C                    -- SET SIGN OF INTEGRATION DIRECTION  AND
C                    -- ESTIMATE STARTING STEP SIZE
C
                     INIT = 2
                     DTSIGN = SIGN(1.0D0,TOUT-T)
                     U = D1MACH(4)
                     BIG = SQRT(D1MACH(2))
                     UTE = U**0.375D0
                     DY = UTE*DHVNRM(Y,NEQ)
                     IF (DY .EQ. 0.0D0) DY = UTE
                     KTOL = 1
                     DO 250 K = 1, NEQ
                        IF (INFO(2) .EQ. 1) KTOL = K
                        TOL = RTOL(KTOL)*ABS(Y(K)) + ATOL(KTOL)
                        IF (TOL .EQ. 0.0D0) TOL = DY*RTOL(KTOL)
                        F1(K) = TOL
  250                CONTINUE
C
                     CALL DHSTRT(DF,NEQ,T,TOUT,Y,YP,F1,4,U,BIG,F2,F3,F4,
     1                           F5,RPAR,IPAR,H)
  260             CONTINUE
C
C                 ......................................................
C
C                      SET STEP SIZE FOR INTEGRATION IN THE DIRECTION
C                      FROM T TO TOUT AND SET OUTPUT POINT INDICATOR
C
                  DT = TOUT - T
                  H = SIGN(H,DT)
                  OUTPUT = .FALSE.
C
C                 TEST TO SEE IF DDERKF IS BEING SEVERELY IMPACTED BY
C                 TOO MANY OUTPUT POINTS
C
                  IF (ABS(H) .GE. 2.0D0*ABS(DT)) KOP = KOP + 1
                  IF (KOP .LE. MXKOP) GO TO 270
C
C                    UNNECESSARY FREQUENCY OF OUTPUT IS RESTRICTING
C                                              THE STEP SIZE CHOICE
                     IDID = -5
                     KOP = 0
                  GO TO 510
  270             CONTINUE
C
                     IF (ABS(DT) .GT. U26*ABS(T)) GO TO 290
C
C                       IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND
C                       RETURN
C
                        DO 280 K = 1, NEQ
                           Y(K) = Y(K) + DT*YP(K)
  280                   CONTINUE
                        A = TOUT
                        CALL DF(A,Y,YP,RPAR,IPAR)
                        KSTEPS = KSTEPS + 1
                     GO TO 500
  290                CONTINUE
C                       BEGIN BLOCK PERMITTING ...EXITS TO 490
C
C                          *********************************************
C                          *********************************************
C                               STEP BY STEP INTEGRATION
C
  300                      CONTINUE
C                             BEGIN BLOCK PERMITTING ...EXITS TO 480
                                 HFAILD = .FALSE.
C
C                                TO PROTECT AGAINST IMPOSSIBLE ACCURACY
C                                REQUESTS, COMPUTE A TOLERANCE FACTOR
C                                BASED ON THE REQUESTED ERROR TOLERANCE
C                                AND A LEVEL OF ACCURACY ACHIEVABLE AT
C                                LIMITING PRECISION
C
                                 TOLFAC = 0.0D0
                                 KTOL = 1
                                 DO 330 K = 1, NEQ
                                    IF (INFO(2) .EQ. 1) KTOL = K
                                    ET = RTOL(KTOL)*ABS(Y(K))
     1                                   + ATOL(KTOL)
                                    IF (ET .GT. 0.0D0) GO TO 310
                                       TOLFAC = MAX(TOLFAC,
     1                                                RER/RTOL(KTOL))
                                    GO TO 320
  310                               CONTINUE
                                       TOLFAC = MAX(TOLFAC,
     1                                                ABS(Y(K))
     2                                                *(RER/ET))
  320                               CONTINUE
  330                            CONTINUE
                                 IF (TOLFAC .LE. 1.0D0) GO TO 340
C
C                          REQUESTED ERROR UNATTAINABLE DUE TO LIMITED
C                                                  PRECISION AVAILABLE
                                    TOLFAC = 2.0D0*TOLFAC
                                    IDID = -2
C              .....................EXIT
                                    GO TO 520
  340                            CONTINUE
C
C                                SET SMALLEST ALLOWABLE STEP SIZE
C
                                 HMIN = U26*ABS(T)
C
C                                ADJUST STEP SIZE IF NECESSARY TO HIT
C                                THE OUTPUT POINT -- LOOK AHEAD TWO
C                                STEPS TO AVOID DRASTIC CHANGES IN THE
C                                STEP SIZE AND THUS LESSEN THE IMPACT OF
C                                OUTPUT POINTS ON THE CODE.  STRETCH THE
C                                STEP SIZE BY, AT MOST, AN AMOUNT EQUAL
C                                TO THE SAFETY FACTOR OF 9/10.
C
                                 DT = TOUT - T
                                 IF (ABS(DT) .GE. 2.0D0*ABS(H))
     1                              GO TO 370
                                    IF (ABS(DT) .GT. ABS(H)/0.9D0)
     1                                 GO TO 350
C
C                                      THE NEXT STEP, IF SUCCESSFUL,
C                                      WILL COMPLETE THE INTEGRATION TO
C                                      THE OUTPUT POINT
C
                                       OUTPUT = .TRUE.
                                       H = DT
                                    GO TO 360
  350                               CONTINUE
C
                                       H = 0.5D0*DT
  360                               CONTINUE
  370                            CONTINUE
C
C
C                                ***************************************
C                                     CORE INTEGRATOR FOR TAKING A
C                                     SINGLE STEP
C                                ***************************************
C                                     TO AVOID PROBLEMS WITH ZERO
C                                     CROSSINGS, RELATIVE ERROR IS
C                                     MEASURED USING THE AVERAGE OF THE
C                                     MAGNITUDES OF THE SOLUTION AT THE
C                                     BEGINNING AND END OF A STEP.
C                                     THE ERROR ESTIMATE FORMULA HAS
C                                     BEEN GROUPED TO CONTROL LOSS OF
C                                     SIGNIFICANCE.
C                                     LOCAL ERROR ESTIMATES FOR A FIRST
C                                     ORDER METHOD USING THE SAME
C                                     STEP SIZE AS THE FEHLBERG METHOD
C                                     ARE CALCULATED AS PART OF THE
C                                     TEST FOR STIFFNESS.
C                                     TO DISTINGUISH THE VARIOUS
C                                     ARGUMENTS, H IS NOT PERMITTED
C                                     TO BECOME SMALLER THAN 26 UNITS OF
C                                     ROUNDOFF IN T.  PRACTICAL LIMITS
C                                     ON THE CHANGE IN THE STEP SIZE ARE
C                                     ENFORCED TO SMOOTH THE STEP SIZE
C                                     SELECTION PROCESS AND TO AVOID
C                                     EXCESSIVE CHATTERING ON PROBLEMS
C                                     HAVING DISCONTINUITIES.  TO
C                                     PREVENT UNNECESSARY FAILURES, THE
C                                     CODE USES 9/10 THE STEP SIZE
C                                     IT ESTIMATES WILL SUCCEED.
C                                     AFTER A STEP FAILURE, THE STEP
C                                     SIZE IS NOT ALLOWED TO INCREASE
C                                     FOR THE NEXT ATTEMPTED STEP. THIS
C                                     MAKES THE CODE MORE EFFICIENT ON
C                                     PROBLEMS HAVING DISCONTINUITIES
C                                     AND MORE EFFECTIVE IN GENERAL
C                                     SINCE LOCAL EXTRAPOLATION IS BEING
C                                     USED AND EXTRA CAUTION SEEMS
C                                     WARRANTED.
C                                .......................................
C
C                                     MONITOR NUMBER OF STEPS ATTEMPTED
C
  380                            CONTINUE
                                    IF (KSTEPS .LE. MXSTEP) GO TO 390
C
C                                      A SIGNIFICANT AMOUNT OF WORK HAS
C                                      BEEN EXPENDED
                                       IDID = -1
                                       KSTEPS = 0
C              ........................EXIT
                                       IF (.NOT.STIFF) GO TO 520
C
C                                      PROBLEM APPEARS TO BE STIFF
                                       IDID = -4
                                       STIFF = .FALSE.
                                       NONSTF = .FALSE.
                                       NTSTEP = 0
                                       NSTIFS = 0
C              ........................EXIT
                                       GO TO 520
  390                               CONTINUE
C
C                                   ADVANCE AN APPROXIMATE SOLUTION OVER
C                                   ONE STEP OF LENGTH H
C
                                    CALL DFEHL(DF,NEQ,T,Y,H,YP,F1,F2,F3,
     1                                         F4,F5,YS,RPAR,IPAR)
                                    KSTEPS = KSTEPS + 1
C
C                                   ....................................
C
C                                        COMPUTE AND TEST ALLOWABLE
C                                        TOLERANCES VERSUS LOCAL ERROR
C                                        ESTIMATES.  NOTE THAT RELATIVE
C                                        ERROR IS MEASURED WITH RESPECT
C                                        TO THE AVERAGE OF THE
C                                        MAGNITUDES OF THE SOLUTION AT
C                                        THE BEGINNING AND END OF THE
C                                        STEP.  LOCAL ERROR ESTIMATES
C                                        FOR A SPECIAL FIRST ORDER
C                                        METHOD ARE CALCULATED ONLY WHEN
C                                        THE STIFFNESS DETECTION IS
C                                        TURNED ON.
C
                                    EEOET = 0.0D0
                                    ESTIFF = 0.0D0
                                    KTOL = 1
                                    DO 420 K = 1, NEQ
                                       YAVG = 0.5D0
     1                                        *(ABS(Y(K))
     2                                          + ABS(YS(K)))
                                       IF (INFO(2) .EQ. 1) KTOL = K
                                       ET = RTOL(KTOL)*YAVG + ATOL(KTOL)
                                       IF (ET .GT. 0.0D0) GO TO 400
C
C           PURE RELATIVE ERROR INAPPROPRIATE WHEN SOLUTION
C                                                  VANISHES
                                          IDID = -3
C              ...........................EXIT
                                          GO TO 520
  400                                  CONTINUE
C
                                       EE = ABS((-2090.0D0*YP(K)
     1                                            +(21970.0D0*F3(K)
     2                                              -15048.0D0*F4(K)))
     3                                           +(22528.0D0*F2(K)
     4                                             -27360.0D0*F5(K)))
                                       IF (STIFF .OR. NONSTF) GO TO 410
                                          ES = ABS(H
     1                                              *(0.055455D0*YP(K)
     2                                                -0.035493D0*F1(K)
     3                                                -0.036571D0*F2(K)
     4                                                +0.023107D0*F3(K)
     5                                                -0.009515D0*F4(K)
     6                                                +0.003017D0*F5(K))
     7                                                )
                                          ESTIFF = MAX(ESTIFF,ES/ET)
  410                                  CONTINUE
                                       EEOET = MAX(EEOET,EE/ET)
  420                               CONTINUE
C
                                    ESTTOL = ABS(H)*EEOET/752400.0D0
C
C                                ...EXIT
                                    IF (ESTTOL .LE. 1.0D0) GO TO 440
C
C                                   ....................................
C
C                                        UNSUCCESSFUL STEP
C
                                    IF (ABS(H) .GT. HMIN) GO TO 430
C
C                             REQUESTED ERROR UNATTAINABLE AT SMALLEST
C                                                  ALLOWABLE STEP SIZE
                                       TOLFAC = 1.69D0*ESTTOL
                                       IDID = -2
C              ........................EXIT
                                       GO TO 520
  430                               CONTINUE
C
C                                   REDUCE THE STEP SIZE , TRY AGAIN
C                                   THE DECREASE IS LIMITED TO A FACTOR
C                                   OF 1/10
C
                                    HFAILD = .TRUE.
                                    OUTPUT = .FALSE.
                                    S = 0.1D0
                                    IF (ESTTOL .LT. 59049.0D0)
     1                                 S = 0.9D0/ESTTOL**0.2D0
                                    H = SIGN(MAX(S*ABS(H),HMIN),H)
                                 GO TO 380
  440                            CONTINUE
C
C                                .......................................
C
C                                SUCCESSFUL STEP
C                                                  STORE SOLUTION AT T+H
C                                                  AND EVALUATE
C                                                  DERIVATIVES THERE
C
                                 T = T + H
                                 DO 450 K = 1, NEQ
                                    Y(K) = YS(K)
  450                            CONTINUE
                                 A = T
                                 CALL DF(A,Y,YP,RPAR,IPAR)
C
C                                CHOOSE NEXT STEP SIZE
C                                THE INCREASE IS LIMITED TO A FACTOR OF
C                                5 IF STEP FAILURE HAS JUST OCCURRED,
C                                NEXT
C                                   STEP SIZE IS NOT ALLOWED TO INCREASE
C
                                 S = 5.0D0
                                 IF (ESTTOL .GT. 1.889568D-4)
     1                              S = 0.9D0/ESTTOL**0.2D0
                                 IF (HFAILD) S = MIN(S,1.0D0)
                                 H = SIGN(MAX(S*ABS(H),HMIN),H)
C
C                                .......................................
C
C                                     CHECK FOR STIFFNESS (IF NOT
C                                     ALREADY DETECTED)
C
C                                     IN A SEQUENCE OF 50 SUCCESSFUL
C                                     STEPS BY THE FEHLBERG METHOD, 25
C                                     SUCCESSFUL STEPS BY THE FIRST
C                                     ORDER METHOD INDICATES STIFFNESS
C                                     AND TURNS THE TEST OFF. IF 26
C                                     FAILURES BY THE FIRST ORDER METHOD
C                                     OCCUR, THE TEST IS TURNED OFF
C                                     UNTIL THIS SEQUENCE OF 50 STEPS BY
C                                     THE FEHLBERG METHOD IS COMPLETED.
C
C                             ...EXIT
                                 IF (STIFF) GO TO 480
                                 NTSTEP = MOD(NTSTEP+1,50)
                                 IF (NTSTEP .EQ. 1) NONSTF = .FALSE.
C                             ...EXIT
                                 IF (NONSTF) GO TO 480
                                 IF (ESTIFF .GT. 1.0D0) GO TO 460
C
C                                   SUCCESSFUL STEP WITH FIRST ORDER
C                                   METHOD
                                    NSTIFS = NSTIFS + 1
C                                   TURN TEST OFF AFTER 25 INDICATIONS
C                                   OF STIFFNESS
                                    IF (NSTIFS .EQ. 25) STIFF = .TRUE.
                                 GO TO 470
  460                            CONTINUE
C
C                                UNSUCCESSFUL STEP WITH FIRST ORDER
C                                METHOD
                                 IF (NTSTEP - NSTIFS .LE. 25) GO TO 470
C               TURN STIFFNESS DETECTION OFF FOR THIS BLOCK OF
C                                                  FIFTY STEPS
                                    NONSTF = .TRUE.
C                                   RESET STIFF STEP COUNTER
                                    NSTIFS = 0
  470                            CONTINUE
  480                         CONTINUE
C
C                             ******************************************
C                                  END OF CORE INTEGRATOR
C                             ******************************************
C
C
C                                  SHOULD WE TAKE ANOTHER STEP
C
C                       ......EXIT
                              IF (OUTPUT) GO TO 490
                           IF (INFO(3) .EQ. 0) GO TO 300
C
C                          *********************************************
C                          *********************************************
C
C                               INTEGRATION SUCCESSFULLY COMPLETED
C
C                                           ONE-STEP MODE
                           IDID = 1
                           TOLD = T
C     .....................EXIT
                           GO TO 560
  490                   CONTINUE
  500                CONTINUE
C
C                    INTERVAL MODE
                     IDID = 2
                     T = TOUT
                     TOLD = T
C     ...............EXIT
                     GO TO 560
  510             CONTINUE
  520          CONTINUE
  530       CONTINUE
  540    CONTINUE
C
C        INTEGRATION TASK INTERRUPTED
C
         INFO(1) = -1
         TOLD = T
C     ...EXIT
         IF (IDID .NE. (-2)) GO TO 560
C
C        THE ERROR TOLERANCES ARE INCREASED TO VALUES
C                WHICH ARE APPROPRIATE FOR CONTINUING
         RTOL(1) = TOLFAC*RTOL(1)
         ATOL(1) = TOLFAC*ATOL(1)
C     ...EXIT
         IF (INFO(2) .EQ. 0) GO TO 560
         DO 550 K = 2, NEQ
            RTOL(K) = TOLFAC*RTOL(K)
            ATOL(K) = TOLFAC*ATOL(K)
  550    CONTINUE
  560 CONTINUE
      RETURN
      END
*DECK DRLCAL
      SUBROUTINE DRLCAL (N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD,
     +   R0NRM)
C***BEGIN PROLOGUE  DRLCAL
C***SUBSIDIARY
C***PURPOSE  Internal routine for DGMRES.
C***LIBRARY   SLATEC (SLAP)
C***CATEGORY  D2A4, D2B4
C***TYPE      DOUBLE PRECISION (SRLCAL-S, DRLCAL-D)
C***KEYWORDS  GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION,
C             NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE
C***AUTHOR  Brown, Peter, (LLNL), pnbrown@llnl.gov
C           Hindmarsh, Alan, (LLNL), alanh@llnl.gov
C           Seager, Mark K., (LLNL), seager@llnl.gov
C             Lawrence Livermore National Laboratory
C             PO Box 808, L-60
C             Livermore, CA 94550 (510) 423-3141
C***DESCRIPTION
C         This routine calculates the scaled residual RL from the
C         V(I)'s.
C *Usage:
C      INTEGER N, KMP, LL, MAXL
C      DOUBLE PRECISION V(N,LL), Q(2*MAXL), RL(N), SNORMW, PROD, R0NORM
C
C      CALL DRLCAL(N, KMP, LL, MAXL, V, Q, RL, SNORMW, PROD, R0NRM)
C
C *Arguments:
C N      :IN       Integer
C         The order of the matrix A, and the lengths
C         of the vectors SR, SZ, R0 and Z.
C KMP    :IN       Integer
C         The number of previous V vectors the new vector VNEW
C         must be made orthogonal to. (KMP .le. MAXL)
C LL     :IN       Integer
C         The current dimension of the Krylov subspace.
C MAXL   :IN       Integer
C         The maximum dimension of the Krylov subspace.
C V      :IN       Double Precision V(N,LL)
C         The N x LL array containing the orthogonal vectors
C         V(*,1) to V(*,LL).
C Q      :IN       Double Precision Q(2*MAXL)
C         A double precision array of length 2*MAXL containing the
C         components of the Givens rotations used in the QR
C         decomposition of HES.  It is loaded in DHEQR and used in
C         DHELS.
C RL     :OUT      Double Precision RL(N)
C         The residual vector RL.  This is either SB*(B-A*XL) if
C         not preconditioning or preconditioning on the right,
C         or SB*(M-inverse)*(B-A*XL) if preconditioning on the
C         left.
C SNORMW :IN       Double Precision
C         Scale factor.
C PROD   :IN       Double Precision
C         The product s1*s2*...*sl = the product of the sines of the
C         Givens rotations used in the QR factorization of
C         the Hessenberg matrix HES.
C R0NRM  :IN       Double Precision
C         The scaled norm of initial residual R0.
C
C***SEE ALSO  DGMRES
C***ROUTINES CALLED  DCOPY, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   890404  DATE WRITTEN
C   890404  Previous REVISION DATE
C   890915  Made changes requested at July 1989 CML Meeting.  (MKS)
C   890922  Numerous changes to prologue to make closer to SLATEC
C           standard.  (FNF)
C   890929  Numerous changes to reduce SP/DP differences.  (FNF)
C   910411  Prologue converted to Version 4.0 format.  (BAB)
C   910506  Made subsidiary to DGMRES.  (FNF)
C   920511  Added complete declaration section.  (WRB)
C***END PROLOGUE  DRLCAL
C         The following is for optimized compilation on LLNL/LTSS Crays.
CLLL. OPTIMIZE
C     .. Scalar Arguments ..
      DOUBLE PRECISION PROD, R0NRM, SNORMW
      INTEGER KMP, LL, MAXL, N
C     .. Array Arguments ..
      DOUBLE PRECISION Q(*), RL(N), V(N,*)
C     .. Local Scalars ..
      DOUBLE PRECISION C, S, TEM
      INTEGER I, I2, IP1, K, LLM1, LLP1
C     .. External Subroutines ..
      EXTERNAL DCOPY, DSCAL
C***FIRST EXECUTABLE STATEMENT  DRLCAL
      IF (KMP .EQ. MAXL) THEN
C
C         calculate RL.  Start by copying V(*,1) into RL.
C
         CALL DCOPY(N, V(1,1), 1, RL, 1)
         LLM1 = LL - 1
         DO 20 I = 1,LLM1
            IP1 = I + 1
            I2 = I*2
            S = Q(I2)
            C = Q(I2-1)
            DO 10 K = 1,N
               RL(K) = S*RL(K) + C*V(K,IP1)
 10         CONTINUE
 20      CONTINUE
         S = Q(2*LL)
         C = Q(2*LL-1)/SNORMW
         LLP1 = LL + 1
         DO 30 K = 1,N
            RL(K) = S*RL(K) + C*V(K,LLP1)
 30      CONTINUE
      ENDIF
C
C         When KMP < MAXL, RL vector already partially calculated.
C         Scale RL by R0NRM*PROD to obtain the residual RL.
C
      TEM = R0NRM*PROD
      CALL DSCAL(N, TEM, RL, 1)
      RETURN
C------------- LAST LINE OF DRLCAL FOLLOWS ----------------------------
      END
*DECK DRSCO
      SUBROUTINE DRSCO (RSAV, ISAV)
C***BEGIN PROLOGUE  DRSCO
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DDEBDF
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (RSCO-S, DRSCO-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   DRSCO transfers data from arrays to a common block within the
C   integrator package DDEBDF.
C
C***SEE ALSO  DDEBDF
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    DDEBD1
C***REVISION HISTORY  (YYMMDD)
C   820301  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DRSCO
C-----------------------------------------------------------------------
C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON
C BLOCK DDEBD1  , WHICH IS USED INTERNALLY IN THE DDEBDF
C PACKAGE.  THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS
C OF SUBROUTINE DSVCO OR THE EQUIVALENT.
C-----------------------------------------------------------------------
C
      INTEGER I, ILS, ISAV, LENILS, LENRLS
      DOUBLE PRECISION RLS, RSAV
      DIMENSION RSAV(*),ISAV(*)
      SAVE LENRLS, LENILS
      COMMON /DDEBD1/ RLS(218),ILS(33)
      DATA LENRLS /218/, LENILS /33/
C
C***FIRST EXECUTABLE STATEMENT  DRSCO
      DO 10 I = 1, LENRLS
         RLS(I) = RSAV(I)
   10 CONTINUE
      DO 20 I = 1, LENILS
         ILS(I) = ISAV(I)
   20 CONTINUE
      RETURN
C     ----------------------- END OF SUBROUTINE DRSCO
C     -----------------------
      END
