*DECK R1MPYQ
      SUBROUTINE R1MPYQ (M, N, A, LDA, V, W)
C***BEGIN PROLOGUE  R1MPYQ
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SNSQ and SNSQE
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (R1MPYQ-S, D1MPYQ-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an M by N matrix A, this subroutine computes A*Q where
C     Q is the product of 2*(N - 1) transformations
C
C           GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C     and GV(I), GW(I) are Givens rotations in the (I,N) plane which
C     eliminate elements in the I-th and N-th planes, respectively.
C     Q itself is not given, rather the information to recover the
C     GV, GW rotations is supplied.
C
C     The subroutine statement is
C
C       SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
C
C     where
C
C       M is a positive integer input variable set to the number
C         of rows of A.
C
C       N is a positive integer input variable set to the number
C         of columns of A.
C
C       A is an M by N ARRAY. On input A must contain the matrix
C         to be postmultiplied by the orthogonal matrix Q
C         described above. On output A*Q has replaced A.
C
C       LDA is a positive integer input variable not less than M
C         which specifies the leading dimension of the array A.
C
C       V is an input array of length N. V(I) must contain the
C         information necessary to recover the Givens rotation GV(I)
C         described above.
C
C       W is an input array of length N. W(I) must contain the
C         information necessary to recover the Givens rotation GW(I)
C         described above.
C
C***SEE ALSO  SNSQ, SNSQE
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  R1MPYQ
      INTEGER M,N,LDA
      REAL A(LDA,*),V(*),W(*)
      INTEGER I,J,NMJ,NM1
      REAL COS,ONE,SIN,TEMP
      SAVE ONE
      DATA ONE /1.0E0/
C***FIRST EXECUTABLE STATEMENT  R1MPYQ
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 50
      DO 20 NMJ = 1, NM1
         J = N - NMJ
         IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J)
         IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(V(J)) .LE. ONE) SIN = V(J)
         IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 10 I = 1, M
            TEMP = COS*A(I,J) - SIN*A(I,N)
            A(I,N) = SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   10       CONTINUE
   20    CONTINUE
C
C     APPLY THE SECOND SET OF GIVENS ROTATIONS TO A.
C
      DO 40 J = 1, NM1
         IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J)
         IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(W(J)) .LE. ONE) SIN = W(J)
         IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 30 I = 1, M
            TEMP = COS*A(I,J) + SIN*A(I,N)
            A(I,N) = -SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   30       CONTINUE
   40    CONTINUE
   50 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE R1MPYQ.
C
      END
*DECK R1UPDT
      SUBROUTINE R1UPDT (M, N, S, LS, U, V, W, SING)
C***BEGIN PROLOGUE  R1UPDT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SNSQ and SNSQE
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (R1UPDT-S, D1UPDT-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an M by N lower trapezoidal matrix S, an M-vector U,
C     and an N-vector V, the problem is to determine an
C     orthogonal matrix Q such that
C
C                   T
C           (S + U*V )*Q
C
C     is again lower trapezoidal.
C
C     This subroutine determines Q as the product of 2*(N - 1)
C     transformations
C
C           GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C     where GV(I), GW(I) are Givens rotations in the (I,N) plane
C     which eliminate elements in the I-th and N-th planes,
C     respectively. Q Itself is not accumulated, rather the
C     information to recover the GV, GW rotations is returned.
C
C     The subroutine statement is
C
C       SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
C
C     where
C
C       M is a positive integer input variable set to the number
C         of rows of S.
C
C       N is a positive integer input variable set to the number
C         of columns of S. N must not exceed M.
C
C       S is an array of length LS. On input S must contain the lower
C         trapezoidal matrix S stored by columns. On output S contains
C         the lower trapezoidal matrix produced as described above.
C
C       LS is a positive integer input variable not less than
C         (N*(2*M-N+1))/2.
C
C       U is an input array of length M which must contain the
C         vector U.
C
C       V is an array of length N. On input V must contain the vector
C         V. On output V(I) contains the information necessary to
C         recover the Givens rotation GV(I) described above.
C
C       W is an output array of length M. W(I) contains information
C         necessary to recover the Givens rotation GW(I) described
C         above.
C
C       SING is a logical output variable. SING is set .TRUE. if any
C         of the diagonal elements of the output S are zero. Otherwise
C         SING is set .FALSE.
C
C***SEE ALSO  SNSQ, SNSQE
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  R1UPDT
      INTEGER M,N,LS
      LOGICAL SING
      REAL S(*),U(*),V(*),W(*)
      INTEGER I,J,JJ,L,NMJ,NM1
      REAL COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,ZERO
      REAL R1MACH
      SAVE ONE, P5, P25, ZERO
      DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/
C***FIRST EXECUTABLE STATEMENT  R1UPDT
      GIANT = R1MACH(2)
C
C     INITIALIZE THE DIAGONAL ELEMENT POINTER.
C
      JJ = (N*(2*M - N + 1))/2 - (M - N)
C
C     MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W.
C
      L = JJ
      DO 10 I = N, M
         W(I) = S(L)
         L = L + 1
   10    CONTINUE
C
C     ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR
C     IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W.
C
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 NMJ = 1, NM1
         J = N - NMJ
         JJ = JJ - (M - J + 1)
         W(J) = ZERO
         IF (V(J) .EQ. ZERO) GO TO 50
C
C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
C        J-TH ELEMENT OF V.
C
         IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20
            COTAN = V(N)/V(J)
            SIN = P5/SQRT(P25+P25*COTAN**2)
            COS = SIN*COTAN
            TAU = ONE
            IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
            GO TO 30
   20    CONTINUE
            TAN = V(J)/V(N)
            COS = P5/SQRT(P25+P25*TAN**2)
            SIN = COS*TAN
            TAU = SIN
   30    CONTINUE
C
C        APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION
C        NECESSARY TO RECOVER THE GIVENS ROTATION.
C
         V(N) = SIN*V(J) + COS*V(N)
         V(J) = TAU
C
C        APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W.
C
         L = JJ
         DO 40 I = J, M
            TEMP = COS*S(L) - SIN*W(I)
            W(I) = SIN*S(L) + COS*W(I)
            S(L) = TEMP
            L = L + 1
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     ADD THE SPIKE FROM THE RANK 1 UPDATE TO W.
C
      DO 80 I = 1, M
         W(I) = W(I) + V(N)*U(I)
   80    CONTINUE
C
C     ELIMINATE THE SPIKE.
C
      SING = .FALSE.
      IF (NM1 .LT. 1) GO TO 140
      DO 130 J = 1, NM1
         IF (W(J) .EQ. ZERO) GO TO 120
C
C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
C        J-TH ELEMENT OF THE SPIKE.
C
         IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90
            COTAN = S(JJ)/W(J)
            SIN = P5/SQRT(P25+P25*COTAN**2)
            COS = SIN*COTAN
            TAU = ONE
            IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
            GO TO 100
   90    CONTINUE
            TAN = W(J)/S(JJ)
            COS = P5/SQRT(P25+P25*TAN**2)
            SIN = COS*TAN
            TAU = SIN
  100    CONTINUE
C
C        APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W.
C
         L = JJ
         DO 110 I = J, M
            TEMP = COS*S(L) + SIN*W(I)
            W(I) = -SIN*S(L) + COS*W(I)
            S(L) = TEMP
            L = L + 1
  110       CONTINUE
C
C        STORE THE INFORMATION NECESSARY TO RECOVER THE
C        GIVENS ROTATION.
C
         W(J) = TAU
  120    CONTINUE
C
C        TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S.
C
         IF (S(JJ) .EQ. ZERO) SING = .TRUE.
         JJ = JJ + (M - J + 1)
  130    CONTINUE
  140 CONTINUE
C
C     MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S.
C
      L = JJ
      DO 150 I = N, M
         S(L) = W(I)
         L = L + 1
  150    CONTINUE
      IF (S(JJ) .EQ. ZERO) SING = .TRUE.
      RETURN
C
C     LAST CARD OF SUBROUTINE R1UPDT.
C
      END
*DECK R9AIMP
      SUBROUTINE R9AIMP (X, AMPL, THETA)
C***BEGIN PROLOGUE  R9AIMP
C***SUBSIDIARY
C***PURPOSE  Evaluate the Airy modulus and phase.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (R9AIMP-S, D9AIMP-D)
C***KEYWORDS  AIRY FUNCTION, FNLIB, MODULUS, PHASE, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate the Airy modulus and phase for X .LE. -1.0
C
C Series for AM21       on the interval -1.25000D-01 to  0.
C                                        with weighted error   2.89E-17
C                                         log weighted error  16.54
C                               significant figures required  14.15
C                                    decimal places required  17.34
C
C Series for ATH1       on the interval -1.25000D-01 to  0.
C                                        with weighted error   2.53E-17
C                                         log weighted error  16.60
C                               significant figures required  15.15
C                                    decimal places required  17.38
C
C Series for AM22       on the interval -1.00000D+00 to -1.25000D-01
C                                        with weighted error   2.99E-17
C                                         log weighted error  16.52
C                               significant figures required  14.57
C                                    decimal places required  17.28
C
C Series for ATH2       on the interval -1.00000D+00 to -1.25000D-01
C                                        with weighted error   2.57E-17
C                                         log weighted error  16.59
C                               significant figures required  15.07
C                                    decimal places required  17.34
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890206  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9AIMP
      DIMENSION AM21CS(40), ATH1CS(36), AM22CS(33), ATH2CS(32)
      LOGICAL FIRST
      SAVE AM21CS, ATH1CS, AM22CS, ATH2CS, PI4, NAM21,
     1 NATH1, NAM22, NATH2, XSML, FIRST
      DATA AM21CS( 1) /    .0065809191 761485E0 /
      DATA AM21CS( 2) /    .0023675984 685722E0 /
      DATA AM21CS( 3) /    .0001324741 670371E0 /
      DATA AM21CS( 4) /    .0000157600 904043E0 /
      DATA AM21CS( 5) /    .0000027529 702663E0 /
      DATA AM21CS( 6) /    .0000006102 679017E0 /
      DATA AM21CS( 7) /    .0000001595 088468E0 /
      DATA AM21CS( 8) /    .0000000471 033947E0 /
      DATA AM21CS( 9) /    .0000000152 933871E0 /
      DATA AM21CS(10) /    .0000000053 590722E0 /
      DATA AM21CS(11) /    .0000000020 000910E0 /
      DATA AM21CS(12) /    .0000000007 872292E0 /
      DATA AM21CS(13) /    .0000000003 243103E0 /
      DATA AM21CS(14) /    .0000000001 390106E0 /
      DATA AM21CS(15) /    .0000000000 617011E0 /
      DATA AM21CS(16) /    .0000000000 282491E0 /
      DATA AM21CS(17) /    .0000000000 132979E0 /
      DATA AM21CS(18) /    .0000000000 064188E0 /
      DATA AM21CS(19) /    .0000000000 031697E0 /
      DATA AM21CS(20) /    .0000000000 015981E0 /
      DATA AM21CS(21) /    .0000000000 008213E0 /
      DATA AM21CS(22) /    .0000000000 004296E0 /
      DATA AM21CS(23) /    .0000000000 002284E0 /
      DATA AM21CS(24) /    .0000000000 001232E0 /
      DATA AM21CS(25) /    .0000000000 000675E0 /
      DATA AM21CS(26) /    .0000000000 000374E0 /
      DATA AM21CS(27) /    .0000000000 000210E0 /
      DATA AM21CS(28) /    .0000000000 000119E0 /
      DATA AM21CS(29) /    .0000000000 000068E0 /
      DATA AM21CS(30) /    .0000000000 000039E0 /
      DATA AM21CS(31) /    .0000000000 000023E0 /
      DATA AM21CS(32) /    .0000000000 000013E0 /
      DATA AM21CS(33) /    .0000000000 000008E0 /
      DATA AM21CS(34) /    .0000000000 000005E0 /
      DATA AM21CS(35) /    .0000000000 000003E0 /
      DATA AM21CS(36) /    .0000000000 000001E0 /
      DATA AM21CS(37) /    .0000000000 000001E0 /
      DATA AM21CS(38) /    .0000000000 000000E0 /
      DATA AM21CS(39) /    .0000000000 000000E0 /
      DATA AM21CS(40) /    .0000000000 000000E0 /
      DATA ATH1CS( 1) /   -.0712583781 5669365E0 /
      DATA ATH1CS( 2) /   -.0059047197 9831451E0 /
      DATA ATH1CS( 3) /   -.0001211454 4069499E0 /
      DATA ATH1CS( 4) /   -.0000098860 8542270E0 /
      DATA ATH1CS( 5) /   -.0000013808 4097352E0 /
      DATA ATH1CS( 6) /   -.0000002614 2640172E0 /
      DATA ATH1CS( 7) /   -.0000000605 0432589E0 /
      DATA ATH1CS( 8) /   -.0000000161 8436223E0 /
      DATA ATH1CS( 9) /   -.0000000048 3464911E0 /
      DATA ATH1CS(10) /   -.0000000015 7655272E0 /
      DATA ATH1CS(11) /   -.0000000005 5231518E0 /
      DATA ATH1CS(12) /   -.0000000002 0545441E0 /
      DATA ATH1CS(13) /   -.0000000000 8043412E0 /
      DATA ATH1CS(14) /   -.0000000000 3291252E0 /
      DATA ATH1CS(15) /   -.0000000000 1399875E0 /
      DATA ATH1CS(16) /   -.0000000000 0616151E0 /
      DATA ATH1CS(17) /   -.0000000000 0279614E0 /
      DATA ATH1CS(18) /   -.0000000000 0130428E0 /
      DATA ATH1CS(19) /   -.0000000000 0062373E0 /
      DATA ATH1CS(20) /   -.0000000000 0030512E0 /
      DATA ATH1CS(21) /   -.0000000000 0015239E0 /
      DATA ATH1CS(22) /   -.0000000000 0007758E0 /
      DATA ATH1CS(23) /   -.0000000000 0004020E0 /
      DATA ATH1CS(24) /   -.0000000000 0002117E0 /
      DATA ATH1CS(25) /   -.0000000000 0001132E0 /
      DATA ATH1CS(26) /   -.0000000000 0000614E0 /
      DATA ATH1CS(27) /   -.0000000000 0000337E0 /
      DATA ATH1CS(28) /   -.0000000000 0000188E0 /
      DATA ATH1CS(29) /   -.0000000000 0000105E0 /
      DATA ATH1CS(30) /   -.0000000000 0000060E0 /
      DATA ATH1CS(31) /   -.0000000000 0000034E0 /
      DATA ATH1CS(32) /   -.0000000000 0000020E0 /
      DATA ATH1CS(33) /   -.0000000000 0000011E0 /
      DATA ATH1CS(34) /   -.0000000000 0000007E0 /
      DATA ATH1CS(35) /   -.0000000000 0000004E0 /
      DATA ATH1CS(36) /   -.0000000000 0000002E0 /
      DATA AM22CS( 1) /   -.0156284448 0625341E0 /
      DATA AM22CS( 2) /    .0077833644 5239681E0 /
      DATA AM22CS( 3) /    .0008670577 7047718E0 /
      DATA AM22CS( 4) /    .0001569662 7315611E0 /
      DATA AM22CS( 5) /    .0000356396 2571432E0 /
      DATA AM22CS( 6) /    .0000092459 8335425E0 /
      DATA AM22CS( 7) /    .0000026211 0161850E0 /
      DATA AM22CS( 8) /    .0000007918 8221651E0 /
      DATA AM22CS( 9) /    .0000002510 4152792E0 /
      DATA AM22CS(10) /    .0000000826 5223206E0 /
      DATA AM22CS(11) /    .0000000280 5711662E0 /
      DATA AM22CS(12) /    .0000000097 6821090E0 /
      DATA AM22CS(13) /    .0000000034 7407923E0 /
      DATA AM22CS(14) /    .0000000012 5828132E0 /
      DATA AM22CS(15) /    .0000000004 6298826E0 /
      DATA AM22CS(16) /    .0000000001 7272825E0 /
      DATA AM22CS(17) /    .0000000000 6523192E0 /
      DATA AM22CS(18) /    .0000000000 2490471E0 /
      DATA AM22CS(19) /    .0000000000 0960156E0 /
      DATA AM22CS(20) /    .0000000000 0373448E0 /
      DATA AM22CS(21) /    .0000000000 0146417E0 /
      DATA AM22CS(22) /    .0000000000 0057826E0 /
      DATA AM22CS(23) /    .0000000000 0022991E0 /
      DATA AM22CS(24) /    .0000000000 0009197E0 /
      DATA AM22CS(25) /    .0000000000 0003700E0 /
      DATA AM22CS(26) /    .0000000000 0001496E0 /
      DATA AM22CS(27) /    .0000000000 0000608E0 /
      DATA AM22CS(28) /    .0000000000 0000248E0 /
      DATA AM22CS(29) /    .0000000000 0000101E0 /
      DATA AM22CS(30) /    .0000000000 0000041E0 /
      DATA AM22CS(31) /    .0000000000 0000017E0 /
      DATA AM22CS(32) /    .0000000000 0000007E0 /
      DATA AM22CS(33) /    .0000000000 0000002E0 /
      DATA ATH2CS( 1) /    .0044052734 5871877E0 /
      DATA ATH2CS( 2) /   -.0304291945 2318455E0 /
      DATA ATH2CS( 3) /   -.0013856532 8377179E0 /
      DATA ATH2CS( 4) /   -.0001804443 9089549E0 /
      DATA ATH2CS( 5) /   -.0000338084 7108327E0 /
      DATA ATH2CS( 6) /   -.0000076781 8353522E0 /
      DATA ATH2CS( 7) /   -.0000019678 3944371E0 /
      DATA ATH2CS( 8) /   -.0000005483 7271158E0 /
      DATA ATH2CS( 9) /   -.0000001625 4615505E0 /
      DATA ATH2CS(10) /   -.0000000505 3049981E0 /
      DATA ATH2CS(11) /   -.0000000163 1580701E0 /
      DATA ATH2CS(12) /   -.0000000054 3420411E0 /
      DATA ATH2CS(13) /   -.0000000018 5739855E0 /
      DATA ATH2CS(14) /   -.0000000006 4895120E0 /
      DATA ATH2CS(15) /   -.0000000002 3105948E0 /
      DATA ATH2CS(16) /   -.0000000000 8363282E0 /
      DATA ATH2CS(17) /   -.0000000000 3071196E0 /
      DATA ATH2CS(18) /   -.0000000000 1142367E0 /
      DATA ATH2CS(19) /   -.0000000000 0429811E0 /
      DATA ATH2CS(20) /   -.0000000000 0163389E0 /
      DATA ATH2CS(21) /   -.0000000000 0062693E0 /
      DATA ATH2CS(22) /   -.0000000000 0024260E0 /
      DATA ATH2CS(23) /   -.0000000000 0009461E0 /
      DATA ATH2CS(24) /   -.0000000000 0003716E0 /
      DATA ATH2CS(25) /   -.0000000000 0001469E0 /
      DATA ATH2CS(26) /   -.0000000000 0000584E0 /
      DATA ATH2CS(27) /   -.0000000000 0000233E0 /
      DATA ATH2CS(28) /   -.0000000000 0000093E0 /
      DATA ATH2CS(29) /   -.0000000000 0000037E0 /
      DATA ATH2CS(30) /   -.0000000000 0000015E0 /
      DATA ATH2CS(31) /   -.0000000000 0000006E0 /
      DATA ATH2CS(32) /   -.0000000000 0000002E0 /
      DATA PI4 / 0.7853981633 9744831 E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9AIMP
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NAM21 = INITS (AM21CS, 40, ETA)
         NATH1 = INITS (ATH1CS, 36, ETA)
         NAM22 = INITS (AM22CS, 33, ETA)
         NATH2 = INITS (ATH2CS, 32, ETA)
C
         XSML = -1.0/R1MACH(3)**0.3333
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-2.0)) GO TO 20
      Z = 1.0
      IF (X.GT.XSML) Z = 16.0/X**3 + 1.0
      AMPL = 0.3125 + CSEVL(Z, AM21CS, NAM21)
      THETA = -0.625 + CSEVL (Z, ATH1CS, NATH1)
      GO TO 30
C
 20   IF (X .GT. (-1.0)) CALL XERMSG ('SLATEC', 'R9AIMP',
     +   'X MUST BE LE -1.0', 1, 2)
C
      Z = (16.0/X**3 + 9.0)/7.0
      AMPL = 0.3125 + CSEVL (Z, AM22CS, NAM22)
      THETA = -0.625 + CSEVL (Z, ATH2CS, NATH2)
C
 30   SQRTX = SQRT(-X)
      AMPL = SQRT (AMPL/SQRTX)
      THETA = PI4 - X*SQRTX * THETA
C
      RETURN
      END
*DECK R9ATN1
      FUNCTION R9ATN1 (X)
C***BEGIN PROLOGUE  R9ATN1
C***SUBSIDIARY
C***PURPOSE  Evaluate ATAN(X) from first order relative accuracy so that
C            ATAN(X) = X + X**3*R9ATN1(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      SINGLE PRECISION (R9ATN1-S, D9ATN1-D)
C***KEYWORDS  ARC TANGENT, ELEMENTARY FUNCTIONS, FIRST ORDER, FNLIB,
C             TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate  ATAN(X)  from first order, that is, evaluate
C (ATAN(X)-X)/X**3  with relative error accuracy so that
C        ATAN(X) = X + X**3*R9ATN1(X).
C
C Series for ATN1       on the interval  0.          to  1.00000D+00
C                                        with weighted error   2.21E-17
C                                         log weighted error  16.66
C                               significant figures required  15.44
C                                    decimal places required  17.32
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   780401  DATE WRITTEN
C   890206  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9ATN1
      DIMENSION ATN1CS(21)
      LOGICAL FIRST
      SAVE ATN1CS, NTATN1, XSML, XBIG, XMAX, FIRST
      DATA ATN1CS( 1) /   -.0328399753 5355202E0 /
      DATA ATN1CS( 2) /    .0583343234 3172412E0 /
      DATA ATN1CS( 3) /   -.0074003696 9671964E0 /
      DATA ATN1CS( 4) /    .0010097841 9933728E0 /
      DATA ATN1CS( 5) /   -.0001439787 1635652E0 /
      DATA ATN1CS( 6) /    .0000211451 2648992E0 /
      DATA ATN1CS( 7) /   -.0000031723 2107425E0 /
      DATA ATN1CS( 8) /    .0000004836 6203654E0 /
      DATA ATN1CS( 9) /   -.0000000746 7746546E0 /
      DATA ATN1CS(10) /    .0000000116 4800896E0 /
      DATA ATN1CS(11) /   -.0000000018 3208837E0 /
      DATA ATN1CS(12) /    .0000000002 9019082E0 /
      DATA ATN1CS(13) /   -.0000000000 4623885E0 /
      DATA ATN1CS(14) /    .0000000000 0740552E0 /
      DATA ATN1CS(15) /   -.0000000000 0119135E0 /
      DATA ATN1CS(16) /    .0000000000 0019240E0 /
      DATA ATN1CS(17) /   -.0000000000 0003118E0 /
      DATA ATN1CS(18) /    .0000000000 0000506E0 /
      DATA ATN1CS(19) /   -.0000000000 0000082E0 /
      DATA ATN1CS(20) /    .0000000000 0000013E0 /
      DATA ATN1CS(21) /   -.0000000000 0000002E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9ATN1
      IF (FIRST) THEN
         EPS = R1MACH(3)
         NTATN1 = INITS (ATN1CS, 21, 0.1*EPS)
C
         XSML = SQRT (0.1*EPS)
         XBIG = 1.571/SQRT(EPS)
         XMAX = 1.571/EPS
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.1.0) GO TO 20
C
      IF (Y.LE.XSML) R9ATN1 = -1.0/3.0
      IF (Y.LE.XSML) RETURN
C
      R9ATN1 = -0.25 + CSEVL (2.0*Y*Y-1., ATN1CS, NTATN1)
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'R9ATN1',
     +   'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 2, 2)
      IF (Y .GT. XBIG) CALL XERMSG ('SLATEC', 'R9ATN1',
     +   'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 1, 1)
C
      R9ATN1 = (ATAN(X) - X) / X**3
      RETURN
C
      END
*DECK R9CHU
      FUNCTION R9CHU (A, B, Z)
C***BEGIN PROLOGUE  R9CHU
C***SUBSIDIARY
C***PURPOSE  Evaluate for large Z  Z**A * U(A,B,Z) where U is the
C            logarithmic confluent hypergeometric function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C11
C***TYPE      SINGLE PRECISION (R9CHU-S, D9CHU-D)
C***KEYWORDS  FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate for large Z  Z**A * U(A,B,Z)  where U is the logarithmic
C confluent hypergeometric function.  A rational approximation due to Y.
C L. Luke is used.  When U is not in the asymptotic region, i.e., when A
C or B is large compared with Z, considerable significance loss occurs.
C A warning is provided when the computed result is less than half
C precision.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890206  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9CHU
      DIMENSION AA(4), BB(4)
      LOGICAL FIRST
      SAVE EPS, SQEPS, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9CHU
      IF (FIRST) THEN
         EPS = 4.0*R1MACH(4)
         SQEPS = SQRT (R1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      BP = 1.0 + A - B
      AB = A*BP
      CT2 = 2.0*(Z-AB)
      SAB = A + BP
C
      BB(1) = 1.0
      AA(1) = 1.0
C
      CT3 = SAB + 1.0 + AB
      BB(2) = 1.0 + 2.0*Z/CT3
      AA(2) = 1.0 + CT2/CT3
C
      ANBN = CT3 + SAB + 3.0
      CT1 = 1.0 + 2.0*Z/ANBN
      BB(3) = 1.0 + 6.0*CT1*Z/CT3
      AA(3) = 1.0 + 6.0*AB/ANBN + 3.0*CT1*CT2/CT3
C
      DO 30 I=4,300
        X2I1 = 2*I - 3
        CT1 = X2I1/(X2I1-2.0)
        ANBN = ANBN + X2I1 + SAB
        CT2 = (X2I1 - 1.0) / ANBN
        C2 = X2I1*CT2 - 1.0
        D1Z = X2I1*2.0*Z/ANBN
C
        CT3 = SAB*CT2
        G1 = D1Z + CT1*(C2+CT3)
        G2 = D1Z - C2
        G3 = CT1*(1.0 - CT3 - 2.0*CT2)
C
        BB(4) = G1*BB(3) + G2*BB(2) + G3*BB(1)
        AA(4) = G1*AA(3) + G2*AA(2) + G3*AA(1)
        IF (ABS(AA(4)*BB(1)-AA(1)*BB(4)).LT.EPS*ABS(BB(4)*BB(1)))
     1    GO TO 40
C
C IF OVERFLOWS OR UNDERFLOWS PROVE TO BE A PROBLEM, THE STATEMENTS
C BELOW COULD BE ALTERED TO INCORPORATE A DYNAMICALLY ADJUSTED SCALE
C FACTOR.
C
        DO 20 J=1,3
          BB(J) = BB(J+1)
          AA(J) = AA(J+1)
 20     CONTINUE
 30   CONTINUE
      CALL XERMSG ('SLATEC', 'R9CHU', 'NO CONVERGENCE IN 300 TERMS', 1,
     +   2)
C
 40   R9CHU = AA(4)/BB(4)
C
      IF (R9CHU .LT. SQEPS .OR. R9CHU .GT. 1.0/SQEPS) CALL XERMSG
     +   ('SLATEC', 'R9CHU', 'ANSWER LESS THAN HALF PRECISION', 2, 1)
C
      RETURN
      END
*DECK R9GMIC
      FUNCTION R9GMIC (A, X, ALX)
C***BEGIN PROLOGUE  R9GMIC
C***SUBSIDIARY
C***PURPOSE  Compute the complementary incomplete Gamma function for A
C            near a negative integer and for small X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9GMIC-S, D9GMIC-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the complementary incomplete gamma function for A near
C a negative integer and for small X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNGAM, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9GMIC
      SAVE EULER, EPS, BOT
      DATA EULER / .5772156649 015329 E0 /
      DATA EPS, BOT / 2*0.0 /
C***FIRST EXECUTABLE STATEMENT  R9GMIC
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
      IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1))
C
      IF (A .GT. 0.0) CALL XERMSG ('SLATEC', 'R9GMIC',
     +   'A MUST BE NEAR A NEGATIVE INTEGER', 2, 2)
      IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'R9GMIC',
     +   'X MUST BE GT ZERO', 3, 2)
C
      MA = A - 0.5
      FM = -MA
      M = -MA
C
      TE = 1.0
      T = 1.0
      S = T
      DO 20 K=1,200
        FKP1 = K + 1
        TE = -X*TE/(FM+FKP1)
        T = TE/FKP1
        S = S + T
        IF (ABS(T).LT.EPS*S) GO TO 30
 20   CONTINUE
      CALL XERMSG ('SLATEC', 'R9GMIC',
     +   'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 4, 2)
C
 30   R9GMIC = -ALX - EULER + X*S/(FM+1.0)
      IF (M.EQ.0) RETURN
C
      IF (M.EQ.1) R9GMIC = -R9GMIC - 1.0 + 1.0/X
      IF (M.EQ.1) RETURN
C
      TE = FM
      T = 1.0
      S = T
      MM1 = M - 1
      DO 40 K=1,MM1
        FK = K
        TE = -X*TE/FK
        T = TE/(FM-FK)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 50
 40   CONTINUE
C
 50   DO 60 K=1,M
        R9GMIC = R9GMIC + 1.0/K
 60   CONTINUE
C
      SGNG = 1.0
      IF (MOD(M,2).EQ.1) SGNG = -1.0
      ALNG = LOG(R9GMIC) - ALNGAM(FM+1.0)
C
      R9GMIC = 0.0
      IF (ALNG.GT.BOT) R9GMIC = SGNG*EXP(ALNG)
      IF (S.NE.0.0) R9GMIC = R9GMIC + SIGN (EXP(-FM*ALX+LOG(ABS(S)/FM))
     1  , S)
C
      IF (R9GMIC .EQ. 0.0 .AND. S .EQ. 0.0) CALL XERMSG ('SLATEC',
     +   'R9GMIC', 'RESULT UNDERFLOWS', 1, 1)
      RETURN
C
      END
*DECK R9GMIT
      FUNCTION R9GMIT (A, X, ALGAP1, SGNGAM, ALX)
C***BEGIN PROLOGUE  R9GMIT
C***SUBSIDIARY
C***PURPOSE  Compute Tricomi's incomplete Gamma function for small
C            arguments.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9GMIT-S, D9GMIT-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X,
C             SPECIAL FUNCTIONS, TRICOMI
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute Tricomi's incomplete gamma function for small X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNGAM, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9GMIT
      SAVE EPS, BOT
      DATA EPS, BOT / 2*0.0 /
C***FIRST EXECUTABLE STATEMENT  R9GMIT
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
      IF (BOT.EQ.0.0) BOT = LOG(R1MACH(1))
C
      IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'R9GMIT',
     +   'X SHOULD BE GT 0', 1, 2)
C
      MA = A + 0.5
      IF (A.LT.0.0) MA = A - 0.5
      AEPS = A - MA
C
      AE = A
      IF (A.LT.(-0.5)) AE = AEPS
C
      T = 1.0
      TE = AE
      S = T
      DO 20 K=1,200
        FK = K
        TE = -X*TE/FK
        T = TE/(AE+FK)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 30
 20   CONTINUE
      CALL XERMSG ('SLATEC', 'R9GMIT',
     +   'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2)
C
 30   IF (A.GE.(-0.5)) ALGS = -ALGAP1 + LOG(S)
      IF (A.GE.(-0.5)) GO TO 60
C
      ALGS = -ALNGAM(1.0+AEPS) + LOG(S)
      S = 1.0
      M = -MA - 1
      IF (M.EQ.0) GO TO 50
      T = 1.0
      DO 40 K=1,M
        T = X*T/(AEPS-M-1+K)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 50
 40   CONTINUE
C
 50   R9GMIT = 0.0
      ALGS = -MA*LOG(X) + ALGS
      IF (S.EQ.0.0 .OR. AEPS.EQ.0.0) GO TO 60
C
      SGNG2 = SGNGAM*SIGN(1.0,S)
      ALG2 = -X - ALGAP1 + LOG(ABS(S))
C
      IF (ALG2.GT.BOT) R9GMIT = SGNG2*EXP(ALG2)
      IF (ALGS.GT.BOT) R9GMIT = R9GMIT + EXP(ALGS)
      RETURN
C
 60   R9GMIT = EXP(ALGS)
      RETURN
C
      END
*DECK R9KNUS
      SUBROUTINE R9KNUS (XNU, X, BKNU, BKNU1, ISWTCH)
C***BEGIN PROLOGUE  R9KNUS
C***SUBSIDIARY
C***PURPOSE  Compute Bessel functions EXP(X)*K-SUB-XNU(X) and EXP(X)*
C            K-SUB-XNU+1(X) for 0.0 .LE. XNU .LT. 1.0.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B3
C***TYPE      SINGLE PRECISION (R9KNUS-S, D9KNUS-D)
C***KEYWORDS  BESSEL FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute Bessel functions EXP(X) * K-sub-XNU (X)  and
C EXP(X) * K-sub-XNU+1 (X) for 0.0 .LE. XNU .LT. 1.0 .
C
C Series for C0K        on the interval  0.          to  2.50000D-01
C                                        with weighted error   1.60E-17
C                                         log weighted error  16.79
C                               significant figures required  15.99
C                                    decimal places required  17.40
C
C Series for ZNU1       on the interval -7.00000D-01 to  0.
C                                        with weighted error   1.43E-17
C                                         log weighted error  16.85
C                               significant figures required  16.08
C                                    decimal places required  17.38
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, GAMMA, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C   900727  Added EXTERNAL statement.  (WRB)
C   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  R9KNUS
      DIMENSION ALPHA(15), BETA(15), A(15), C0KCS(16), ZNU1CS(12)
      LOGICAL FIRST
      EXTERNAL GAMMA
      SAVE C0KCS, ZNU1CS, EULER, SQPI2, ALN2, NTC0K, NTZNU1,
     1 XNUSML, XSML, ALNSML, ALNBIG, ALNEPS, FIRST
      DATA C0KCS( 1) /    .0601830572 42626108E0 /
      DATA C0KCS( 2) /   -.1536487143 3017286E0 /
      DATA C0KCS( 3) /   -.0117511760 08210492E0 /
      DATA C0KCS( 4) /   -.0008524878 88919795E0 /
      DATA C0KCS( 5) /   -.0000613298 38767496E0 /
      DATA C0KCS( 6) /   -.0000044052 28124551E0 /
      DATA C0KCS( 7) /   -.0000003163 12467283E0 /
      DATA C0KCS( 8) /   -.0000000227 10719382E0 /
      DATA C0KCS( 9) /   -.0000000016 30564460E0 /
      DATA C0KCS(10) /   -.0000000001 17069392E0 /
      DATA C0KCS(11) /   -.0000000000 08405206E0 /
      DATA C0KCS(12) /   -.0000000000 00603466E0 /
      DATA C0KCS(13) /   -.0000000000 00043326E0 /
      DATA C0KCS(14) /   -.0000000000 00003110E0 /
      DATA C0KCS(15) /   -.0000000000 00000223E0 /
      DATA C0KCS(16) /   -.0000000000 00000016E0 /
      DATA ZNU1CS( 1) /    .2033067569 9419173E0 /
      DATA ZNU1CS( 2) /    .1400779334 1321977E0 /
      DATA ZNU1CS( 3) /    .0079167969 61001613E0 /
      DATA ZNU1CS( 4) /    .0003398011 82532104E0 /
      DATA ZNU1CS( 5) /    .0000117419 75688989E0 /
      DATA ZNU1CS( 6) /    .0000003393 57570612E0 /
      DATA ZNU1CS( 7) /    .0000000084 25941769E0 /
      DATA ZNU1CS( 8) /    .0000000001 83336677E0 /
      DATA ZNU1CS( 9) /    .0000000000 03549698E0 /
      DATA ZNU1CS(10) /    .0000000000 00061903E0 /
      DATA ZNU1CS(11) /    .0000000000 00000981E0 /
      DATA ZNU1CS(12) /    .0000000000 00000014E0 /
      DATA EULER / 0.5772156649 0153286E0 /
      DATA SQPI2 / 1.253314137 3155003E0 /
      DATA ALN2 / 0.693147180 55994531E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9KNUS
      IF (FIRST) THEN
         NTC0K = INITS (C0KCS, 16, 0.1*R1MACH(3))
         NTZNU1 = INITS (ZNU1CS, 12, 0.1*R1MACH(3))
C
         XNUSML = SQRT (R1MACH(3)/8.0)
         XSML = 0.1*R1MACH(3)
         ALNSML = LOG (R1MACH(1))
         ALNBIG = LOG (R1MACH(2))
         ALNEPS = LOG (0.1*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (XNU .LT. 0. .OR. XNU .GE. 1.0) CALL XERMSG ('SLATEC',
     +   'R9KNUS', 'XNU MUST BE GE 0 AND LT 1', 1, 2)
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'R9KNUS', 'X MUST BE GT 0',
     +   2, 2)
C
      ISWTCH = 0
      IF (X.GT.2.0) GO TO 50
C
C X IS SMALL.  COMPUTE K-SUB-XNU (X) AND THE DERIVATIVE OF K-SUB-XNU (X)
C THEN FIND K-SUB-XNU+1 (X).  XNU IS REDUCED TO THE INTERVAL (-.5,+.5)
C THEN TO (0., .5), BECAUSE K OF NEGATIVE ORDER (-NU) = K OF POSITIVE
C ORDER (+NU).
C
      V = XNU
      IF (XNU.GT.0.5) V = 1.0 - XNU
C
C CAREFULLY FIND (X/2)**XNU AND Z**XNU WHERE Z = X*X/4.
      ALNZ = 2.0 * (LOG(X) - ALN2)
C
      IF (X.GT.XNU) GO TO 20
      IF (-0.5*XNU*ALNZ-ALN2-LOG(XNU) .GT. ALNBIG) CALL XERMSG
     +   ('SLATEC', 'R9KNUS', 'X SO SMALL BESSEL K-SUB-XNU OVERFLOWS',
     +   3, 2)
C
 20   VLNZ = V*ALNZ
      X2TOV = EXP (0.5*VLNZ)
      ZTOV = 0.0
      IF (VLNZ.GT.ALNSML) ZTOV = X2TOV**2
C
      A0 = 0.5*GAMMA(1.0+V)
      B0 = 0.5*GAMMA(1.0-V)
      C0 = -EULER
      IF (ZTOV.GT.0.5 .AND. V.GT.XNUSML) C0 = -0.75 +
     1  CSEVL ((8.0*V)*V-1., C0KCS, NTC0K)
C
      IF (ZTOV.LE.0.5) ALPHA(1) = (A0-ZTOV*B0)/V
      IF (ZTOV.GT.0.5) ALPHA(1) = C0 - ALNZ*(0.75 +
     1  CSEVL (VLNZ/0.35+1.0, ZNU1CS, NTZNU1))*B0
      BETA(1) = -0.5*(A0+ZTOV*B0)
C
      Z = 0.0
      IF (X.GT.XSML) Z = 0.25*X*X
      NTERMS = MAX (2.0, 11.0+(8.*ALNZ-25.19-ALNEPS)/(4.28-ALNZ))
      DO 30 I=2,NTERMS
        XI = I - 1
        A0 = A0/(XI*(XI-V))
        B0 = B0/(XI*(XI+V))
        ALPHA(I) = (ALPHA(I-1)+2.0*XI*A0)/(XI*(XI+V))
        BETA(I) = (XI-0.5*V)*ALPHA(I) - ZTOV*B0
 30   CONTINUE
C
      BKNU = ALPHA(NTERMS)
      BKNUD = BETA(NTERMS)
      DO 40 II=2,NTERMS
        I = NTERMS + 1 - II
        BKNU = ALPHA(I) + BKNU*Z
        BKNUD = BETA(I) + BKNUD*Z
 40   CONTINUE
C
      EXPX = EXP(X)
      BKNU = EXPX*BKNU/X2TOV
C
      IF (-0.5*(XNU+1.)*ALNZ-2.0*ALN2.GT.ALNBIG) ISWTCH = 1
      IF (ISWTCH.EQ.1) RETURN
      BKNUD = EXPX*BKNUD*2.0/(X2TOV*X)
C
      IF (XNU.LE.0.5) BKNU1 = V*BKNU/X - BKNUD
      IF (XNU.LE.0.5) RETURN
C
      BKNU0 = BKNU
      BKNU = -V*BKNU/X - BKNUD
      BKNU1 = 2.0*XNU*BKNU/X + BKNU0
      RETURN
C
C X IS LARGE.  FIND K-SUB-XNU (X) AND K-SUB-XNU+1 (X) WITH Y. L. LUKE-S
C RATIONAL EXPANSION.
C
 50   SQRTX = SQRT(X)
      IF (X.GT.1.0/XSML) GO TO 90
      AN = -1.56 + 4.0/X
      BN = -0.29 - 0.22/X
      NTERMS = MIN (15, MAX1 (3.0, AN+BN*ALNEPS))
C
      DO 80 INU=1,2
        XMU = 0.
        IF (INU.EQ.1 .AND. XNU.GT.XNUSML) XMU = (4.0*XNU)*XNU
        IF (INU.EQ.2) XMU = 4.0*(ABS(XNU)+1.)**2
C
        A(1) = 1.0 - XMU
        A(2) = 9.0 - XMU
        A(3) = 25.0 - XMU
        IF (A(2).EQ.0.) RESULT = SQPI2*(16.*X+XMU+7.)/(16.*X*SQRTX)
        IF (A(2).EQ.0.) GO TO 70
C
        ALPHA(1) = 1.0
        ALPHA(2) = (16.*X+A(2))/A(2)
        ALPHA(3) = ((768.*X+48.*A(3))*X + A(2)*A(3))/(A(2)*A(3))
C
        BETA(1) = 1.0
        BETA(2) = (16.*X+(XMU+7.))/A(2)
        BETA(3) = ((768.*X+48.*(XMU+23.))*X + ((XMU+62.)*XMU+129.))
     1    / (A(2)*A(3))
C
        IF (NTERMS.LT.4) GO TO 65
        DO 60 I=4,NTERMS
          N = I - 1
          X2N = 2*N - 1
C
          A(I) = (X2N+2.)**2 - XMU
          QQ = 16.*X2N/A(I)
          P1 = -X2N*(12*N*N-20*N-A(1))/((X2N-2.)*A(I)) - QQ*X
          P2 = (12*N*N-28*N+8-A(1))/A(I) - QQ*X
          P3 = -X2N*A(I-3)/((X2N-2.)*A(I))
C
          ALPHA(I) = -P1*ALPHA(I-1) - P2*ALPHA(I-2) - P3*ALPHA(I-3)
          BETA(I) = -P1*BETA(I-1) - P2*BETA(I-2) - P3*BETA(I-3)
 60     CONTINUE
C
 65     RESULT = SQPI2*BETA(NTERMS)/(SQRTX*ALPHA(NTERMS))
C
 70     IF (INU.EQ.1) BKNU = RESULT
        IF (INU.EQ.2) BKNU1 = RESULT
 80   CONTINUE
      RETURN
C
 90   BKNU = SQPI2/SQRTX
      BKNU1 = BKNU
      RETURN
C
      END
*DECK R9LGIC
      FUNCTION R9LGIC (A, X, ALX)
C***BEGIN PROLOGUE  R9LGIC
C***SUBSIDIARY
C***PURPOSE  Compute the log complementary incomplete Gamma function
C            for large X and for A .LE. X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9LGIC-S, D9LGIC-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, LARGE X,
C             LOGARITHM, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the log complementary incomplete gamma function for large X
C and for A .LE. X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9LGIC
      SAVE EPS
      DATA EPS / 0.0 /
C***FIRST EXECUTABLE STATEMENT  R9LGIC
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
C
      XPA = X + 1.0 - A
      XMA = X - 1.0 - A
C
      R = 0.0
      P = 1.0
      S = P
      DO 10 K=1,200
        FK = K
        T = FK*(A-FK)*(1.0+R)
        R = -T/((XMA+2.0*FK)*(XPA+2.0*FK)+T)
        P = R*P
        S = S + P
        IF (ABS(P).LT.EPS*S) GO TO 20
 10   CONTINUE
      CALL XERMSG ('SLATEC', 'R9LGIC',
     +   'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 1, 2)
C
 20   R9LGIC = A*ALX - X + LOG(S/XPA)
C
      RETURN
      END
*DECK R9LGIT
      FUNCTION R9LGIT (A, X, ALGAP1)
C***BEGIN PROLOGUE  R9LGIT
C***SUBSIDIARY
C***PURPOSE  Compute the logarithm of Tricomi's incomplete Gamma
C            function with Perron's continued fraction for large X and
C            A .GE. X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9LGIT-S, D9LGIT-D)
C***KEYWORDS  FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM,
C             PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the log of Tricomi's incomplete gamma function with Perron's
C continued fraction for large X and for A .GE. X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9LGIT
      SAVE EPS, SQEPS
      DATA EPS, SQEPS / 2*0.0 /
C***FIRST EXECUTABLE STATEMENT  R9LGIT
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
      IF (SQEPS.EQ.0.0) SQEPS = SQRT(R1MACH(4))
C
      IF (X .LE. 0.0 .OR. A .LT. X) CALL XERMSG ('SLATEC', 'R9LGIT',
     +   'X SHOULD BE GT 0.0 AND LE A', 2, 2)
C
      AX = A + X
      A1X = AX + 1.0
      R = 0.0
      P = 1.0
      S = P
      DO 20 K=1,200
        FK = K
        T = (A+FK)*X*(1.0+R)
        R = T/((AX+FK)*(A1X+FK)-T)
        P = R*P
        S = S + P
        IF (ABS(P).LT.EPS*S) GO TO 30
 20   CONTINUE
      CALL XERMSG ('SLATEC', 'R9LGIT',
     +   'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2)
C
 30   HSTAR = 1.0 - X*S/A1X
      IF (HSTAR .LT. SQEPS) CALL XERMSG ('SLATEC', 'R9LGIT',
     +   'RESULT LESS THAN HALF PRECISION', 1, 1)
C
      R9LGIT = -X - ALGAP1 - LOG(HSTAR)
C
      RETURN
      END
*DECK R9LGMC
      FUNCTION R9LGMC (X)
C***BEGIN PROLOGUE  R9LGMC
C***SUBSIDIARY
C***PURPOSE  Compute the log Gamma correction factor so that
C            LOG(GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X
C            + R9LGMC(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
C             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the log gamma correction factor for X .GE. 10.0 so that
C  LOG (GAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + R9LGMC(X)
C
C Series for ALGM       on the interval  0.          to  1.00000D-02
C                                        with weighted error   3.40E-16
C                                         log weighted error  15.47
C                               significant figures required  14.39
C                                    decimal places required  15.86
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9LGMC
      DIMENSION ALGMCS(6)
      LOGICAL FIRST
      SAVE ALGMCS, NALGM, XBIG, XMAX, FIRST
      DATA ALGMCS( 1) /    .1666389480 45186E0 /
      DATA ALGMCS( 2) /   -.0000138494 817606E0 /
      DATA ALGMCS( 3) /    .0000000098 108256E0 /
      DATA ALGMCS( 4) /   -.0000000000 180912E0 /
      DATA ALGMCS( 5) /    .0000000000 000622E0 /
      DATA ALGMCS( 6) /   -.0000000000 000003E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9LGMC
      IF (FIRST) THEN
         NALGM = INITS (ALGMCS, 6, R1MACH(3))
         XBIG = 1.0/SQRT(R1MACH(3))
         XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.0*R1MACH(1))) )
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 10.0) CALL XERMSG ('SLATEC', 'R9LGMC',
     +   'X MUST BE GE 10', 1, 2)
      IF (X.GE.XMAX) GO TO 20
C
      R9LGMC = 1.0/(12.0*X)
      IF (X.LT.XBIG) R9LGMC = CSEVL (2.0*(10./X)**2-1., ALGMCS, NALGM)/X
      RETURN
C
 20   R9LGMC = 0.0
      CALL XERMSG ('SLATEC', 'R9LGMC', 'X SO BIG R9LGMC UNDERFLOWS', 2,
     +   1)
      RETURN
C
      END
*DECK R9LN2R
      FUNCTION R9LN2R (X)
C***BEGIN PROLOGUE  R9LN2R
C***SUBSIDIARY
C***PURPOSE  Evaluate LOG(1+X) from second order relative accuracy so
C            that LOG(1+X) = X - X**2/2 + X**3*R9LN2R(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      SINGLE PRECISION (R9LN2R-S, D9LN2R-D, C9LN2R-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate  LOG(1+X)  from 2-nd order with relative error accuracy so
C that    LOG(1+X) = X - X**2/2 + X**3*R9LN2R(X)
C
C Series for LN21       on the interval -6.25000D-01 to  0.
C                                        with weighted error   2.49E-17
C                                         log weighted error  16.60
C                               significant figures required  15.87
C                                    decimal places required  17.31
C
C Series for LN22       on the interval  0.          to  8.12500D-01
C                                        with weighted error   1.42E-17
C                                         log weighted error  16.85
C                               significant figures required  15.95
C                                    decimal places required  17.50
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   780401  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9LN2R
      REAL LN21CS(26), LN22CS(20)
      LOGICAL FIRST
      SAVE LN21CS, LN22CS, NTLN21, NTLN22, XMIN, XBIG, XMAX, FIRST
      DATA LN21CS( 1) /    .1811196251 3478810E0 /
      DATA LN21CS( 2) /   -.1562712319 2872463E0 /
      DATA LN21CS( 3) /    .0286763053 61557275E0 /
      DATA LN21CS( 4) /   -.0055586996 55948139E0 /
      DATA LN21CS( 5) /    .0011178976 65229983E0 /
      DATA LN21CS( 6) /   -.0002308050 89823279E0 /
      DATA LN21CS( 7) /    .0000485988 53341100E0 /
      DATA LN21CS( 8) /   -.0000103901 27388903E0 /
      DATA LN21CS( 9) /    .0000022484 56370739E0 /
      DATA LN21CS(10) /   -.0000004914 05927392E0 /
      DATA LN21CS(11) /    .0000001082 82565070E0 /
      DATA LN21CS(12) /   -.0000000240 25872763E0 /
      DATA LN21CS(13) /    .0000000053 62460047E0 /
      DATA LN21CS(14) /   -.0000000012 02995136E0 /
      DATA LN21CS(15) /    .0000000002 71078892E0 /
      DATA LN21CS(16) /   -.0000000000 61323562E0 /
      DATA LN21CS(17) /    .0000000000 13920858E0 /
      DATA LN21CS(18) /   -.0000000000 03169930E0 /
      DATA LN21CS(19) /    .0000000000 00723837E0 /
      DATA LN21CS(20) /   -.0000000000 00165700E0 /
      DATA LN21CS(21) /    .0000000000 00038018E0 /
      DATA LN21CS(22) /   -.0000000000 00008741E0 /
      DATA LN21CS(23) /    .0000000000 00002013E0 /
      DATA LN21CS(24) /   -.0000000000 00000464E0 /
      DATA LN21CS(25) /    .0000000000 00000107E0 /
      DATA LN21CS(26) /   -.0000000000 00000024E0 /
      DATA LN22CS( 1) /   -.2224253253 5020461E0 /
      DATA LN22CS( 2) /   -.0610471001 08078624E0 /
      DATA LN22CS( 3) /    .0074272350 09750394E0 /
      DATA LN22CS( 4) /   -.0009335018 26163697E0 /
      DATA LN22CS( 5) /    .0001200499 07687260E0 /
      DATA LN22CS( 6) /   -.0000157047 22952820E0 /
      DATA LN22CS( 7) /    .0000020818 74781051E0 /
      DATA LN22CS( 8) /   -.0000002789 19557764E0 /
      DATA LN22CS( 9) /    .0000000376 93558237E0 /
      DATA LN22CS(10) /   -.0000000051 30902896E0 /
      DATA LN22CS(11) /    .0000000007 02714117E0 /
      DATA LN22CS(12) /   -.0000000000 96748595E0 /
      DATA LN22CS(13) /    .0000000000 13381046E0 /
      DATA LN22CS(14) /   -.0000000000 01858102E0 /
      DATA LN22CS(15) /    .0000000000 00258929E0 /
      DATA LN22CS(16) /   -.0000000000 00036195E0 /
      DATA LN22CS(17) /    .0000000000 00005074E0 /
      DATA LN22CS(18) /   -.0000000000 00000713E0 /
      DATA LN22CS(19) /    .0000000000 00000100E0 /
      DATA LN22CS(20) /   -.0000000000 00000014E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9LN2R
      IF (FIRST) THEN
         EPS = R1MACH(3)
         NTLN21 = INITS (LN21CS, 26, 0.1*EPS)
         NTLN22 = INITS (LN22CS, 20, 0.1*EPS)
C
         XMIN = -1.0 + SQRT(R1MACH(4))
         SQEPS = SQRT(EPS)
         TXMAX = 6.0/SQEPS
         XMAX = TXMAX - (EPS*TXMAX**2 - 2.0*LOG(TXMAX)) /
     1                                              (2.0*EPS*TXMAX)
         TXBIG = 4.0/SQRT(SQEPS)
         XBIG = TXBIG - (SQEPS*TXBIG**2 - 2.0*LOG(TXBIG)) /
     1                                                (2.*SQEPS*TXBIG)
      ENDIF
      FIRST = .FALSE.
C
      IF (X.LT.(-0.625) .OR. X.GT.0.8125) GO TO 20
C
      IF (X.LT.0.0) R9LN2R = 0.375 + CSEVL (16.*X/5.+1.0, LN21CS,
     1  NTLN21)
      IF (X.GE.0.0) R9LN2R = 0.375 + CSEVL (32.*X/13.-1.0, LN22CS,
     1  NTLN22)
      RETURN
C
 20   IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'R9LN2R',
     +   'ANSWER LT HALF PRECISION BECAUSE X IS TOO NEAR -1', 1, 1)
      IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'R9LN2R',
     +   'NO PRECISION IN ANSWER BECAUSE X IS TOO BIG', 3, 2)
      IF (X .GT. XBIG) CALL XERMSG ('SLATEC', 'R9LN2R',
     +   'ANSWER LT HALF PRECISION BECAUSE X IS TOO BIG', 2, 1)
C
      R9LN2R = (LOG(1.0+X) - X*(1.0-0.5*X) ) / X**3
      RETURN
C
      END
*DECK R9PAK
      FUNCTION R9PAK (Y, N)
C***BEGIN PROLOGUE  R9PAK
C***PURPOSE  Pack a base 2 exponent into a floating point number.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  A6B
C***TYPE      SINGLE PRECISION (R9PAK-S, D9PAK-D)
C***KEYWORDS  FNLIB, PACK
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Pack a base 2 exponent into floating point number Y.  This
C routine is almost the inverse of R9UPAK.  It is not exactly
C the inverse, because ABS(X) need not be between 0.5 and
C 1.0.  If both R9PAK and 2.0**N were known to be in range, we
C could compute
C       R9PAK = Y * 2.0**N .
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  I1MACH, R1MACH, R9UPAK, 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   901009  Routine used I1MACH(7) where it should use I1MACH(10),
C           Corrected (RWC)
C***END PROLOGUE  R9PAK
      LOGICAL FIRST
      SAVE NMIN, NMAX, A1N210, FIRST
      DATA A1N210 / 3.321928094 887362 E0/
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  R9PAK
      IF (FIRST) THEN
         A1N2B = 1.0
         IF (I1MACH(10).NE.2) A1N2B = R1MACH(5)*A1N210
         NMIN = A1N2B*I1MACH(12)
         NMAX = A1N2B*I1MACH(13)
      ENDIF
      FIRST = .FALSE.
C
      CALL R9UPAK(Y,R9PAK,NY)
C
      NSUM = N + NY
      IF (NSUM.LT.NMIN) GO TO 40
      IF (NSUM .GT. NMAX) CALL XERMSG ('SLATEC', 'R9PAK',
     +   'PACKED NUMBER OVERFLOWS', 2, 2)
C
      IF (NSUM.EQ.0) RETURN
      IF (NSUM.GT.0) GO TO 30
C
 20   R9PAK = 0.5*R9PAK
      NSUM = NSUM + 1
      IF(NSUM.NE.0) GO TO 20
      RETURN
C
30    R9PAK = 2.0*R9PAK
      NSUM = NSUM - 1
      IF(NSUM.NE.0) GO TO 30
      RETURN
C
40    CALL XERMSG ('SLATEC', 'R9PAK', 'PACKED NUMBER UNDERFLOWS', 1, 1)
      R9PAK = 0.0
      RETURN
C
      END
*DECK R9UPAK
      SUBROUTINE R9UPAK (X, Y, N)
C***BEGIN PROLOGUE  R9UPAK
C***PURPOSE  Unpack a floating point number X so that X = Y*2**N.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  A6B
C***TYPE      SINGLE PRECISION (R9UPAK-S, D9UPAK-D)
C***KEYWORDS  FNLIB, UNPACK
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   Unpack a floating point number X so that X = Y*2.0**N, where
C   0.5 .LE. ABS(Y) .LT. 1.0.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   780701  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  R9UPAK
C***FIRST EXECUTABLE STATEMENT  R9UPAK
      ABSX = ABS(X)
      N = 0
      IF (X.EQ.0.0E0) GO TO 30
C
   10 IF (ABSX.GE.0.5E0) GO TO 20
      N = N-1
      ABSX = ABSX*2.0E0
      GO TO 10
C
   20 IF (ABSX.LT.1.0E0) GO TO 30
      N = N+1
      ABSX = ABSX*0.5E0
      GO TO 20
C
   30 Y = SIGN(ABSX,X)
      RETURN
C
      END
*DECK RADB2
      SUBROUTINE RADB2 (IDO, L1, CC, CH, WA1)
C***BEGIN PROLOGUE  RADB2
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            length two.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADB2-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   881128  Modified by Dick Valent to meet prologue standards.
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADB2
      DIMENSION CC(IDO,2,*), CH(IDO,L1,2), WA1(*)
C***FIRST EXECUTABLE STATEMENT  RADB2
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 108
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=3,IDO,2
            IC = IDP2-I
            CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
            TR2 = CC(I-1,1,K)-CC(IC-1,2,K)
            CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)
            TI2 = CC(I,1,K)+CC(IC,2,K)
            CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
            CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2
  103    CONTINUE
  104 CONTINUE
      GO TO 111
  108 DO 110 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 109 K=1,L1
            CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
            TR2 = CC(I-1,1,K)-CC(IC-1,2,K)
            CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)
            TI2 = CC(I,1,K)+CC(IC,2,K)
            CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
            CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2
  109    CONTINUE
  110 CONTINUE
  111 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K)
         CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K))
  106 CONTINUE
  107 RETURN
      END
*DECK RADB3
      SUBROUTINE RADB3 (IDO, L1, CC, CH, WA1, WA2)
C***BEGIN PROLOGUE  RADB3
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            length three.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADB3-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing definition of variable TAUI by using
C               FORTRAN intrinsic function SQRT instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADB3
      DIMENSION CC(IDO,3,*), CH(IDO,L1,3), WA1(*), WA2(*)
C***FIRST EXECUTABLE STATEMENT  RADB3
      TAUR = -.5
      TAUI = .5*SQRT(3.)
      DO 101 K=1,L1
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         CI3 = TAUI*(CC(1,3,K)+CC(1,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
CDIR$ IVDEP
         DO 102 I=3,IDO,2
            IC = IDP2-I
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,3,K)-CC(IC,2,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
            CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 105 K=1,L1
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,3,K)-CC(IC,2,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
            CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
*DECK RADB4
      SUBROUTINE RADB4 (IDO, L1, CC, CH, WA1, WA2, WA3)
C***BEGIN PROLOGUE  RADB4
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            length four.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADB4-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing definition of variable SQRT2 by using
C               FORTRAN intrinsic function SQRT instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADB4
      DIMENSION CC(IDO,4,*), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*)
C***FIRST EXECUTABLE STATEMENT  RADB4
      SQRT2 = SQRT(2.)
      DO 101 K=1,L1
         TR1 = CC(1,1,K)-CC(IDO,4,K)
         TR2 = CC(1,1,K)+CC(IDO,4,K)
         TR3 = CC(IDO,2,K)+CC(IDO,2,K)
         TR4 = CC(1,3,K)+CC(1,3,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,2) = TR1-TR4
         CH(1,K,3) = TR2-TR3
         CH(1,K,4) = TR1+TR4
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 108
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=3,IDO,2
            IC = IDP2-I
            TI1 = CC(I,1,K)+CC(IC,4,K)
            TI2 = CC(I,1,K)-CC(IC,4,K)
            TI3 = CC(I,3,K)-CC(IC,2,K)
            TR4 = CC(I,3,K)+CC(IC,2,K)
            TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
            TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
            TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1-TR4
            CR4 = TR1+TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
            CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
            CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
            CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
            CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
            CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
  103    CONTINUE
  104 CONTINUE
      GO TO 111
  108 DO 110 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 109 K=1,L1
            TI1 = CC(I,1,K)+CC(IC,4,K)
            TI2 = CC(I,1,K)-CC(IC,4,K)
            TI3 = CC(I,3,K)-CC(IC,2,K)
            TR4 = CC(I,3,K)+CC(IC,2,K)
            TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
            TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
            TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1-TR4
            CR4 = TR1+TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
            CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
            CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
            CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
            CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
            CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
  109    CONTINUE
  110 CONTINUE
  111 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         TI1 = CC(1,2,K)+CC(1,4,K)
         TI2 = CC(1,4,K)-CC(1,2,K)
         TR1 = CC(IDO,1,K)-CC(IDO,3,K)
         TR2 = CC(IDO,1,K)+CC(IDO,3,K)
         CH(IDO,K,1) = TR2+TR2
         CH(IDO,K,2) = SQRT2*(TR1-TI1)
         CH(IDO,K,3) = TI2+TI2
         CH(IDO,K,4) = -SQRT2*(TR1+TI1)
  106 CONTINUE
  107 RETURN
      END
*DECK RADB5
      SUBROUTINE RADB5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4)
C***BEGIN PROLOGUE  RADB5
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            length five.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADB5-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing definition of variables PI, TI11, TI12,
C               TR11, TR12 by using FORTRAN intrinsic functions ATAN
C               and SIN instead of DATA statements.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADB5
      DIMENSION CC(IDO,5,*), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*),
     +          WA4(*)
C***FIRST EXECUTABLE STATEMENT  RADB5
      PI = 4.*ATAN(1.)
      TR11 = SIN(.1*PI)
      TI11 = SIN(.4*PI)
      TR12 = -SIN(.3*PI)
      TI12 = SIN(.2*PI)
      DO 101 K=1,L1
         TI5 = CC(1,3,K)+CC(1,3,K)
         TI4 = CC(1,5,K)+CC(1,5,K)
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)
         TR3 = CC(IDO,4,K)+CC(IDO,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI5 = TI11*TI5+TI12*TI4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(1,K,5) = CR2+CI5
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
CDIR$ IVDEP
         DO 102 I=3,IDO,2
            IC = IDP2-I
            TI5 = CC(I,3,K)+CC(IC,2,K)
            TI2 = CC(I,3,K)-CC(IC,2,K)
            TI4 = CC(I,5,K)+CC(IC,4,K)
            TI3 = CC(I,5,K)-CC(IC,4,K)
            TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
            TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
            CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
            CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
            CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
            CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 105 K=1,L1
            TI5 = CC(I,3,K)+CC(IC,2,K)
            TI2 = CC(I,3,K)-CC(IC,2,K)
            TI4 = CC(I,5,K)+CC(IC,4,K)
            TI3 = CC(I,5,K)-CC(IC,4,K)
            TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
            TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
            CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
            CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
            CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
            CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
*DECK RADBG
      SUBROUTINE RADBG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA)
C***BEGIN PROLOGUE  RADBG
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            arbitrary length.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADBG-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing references to intrinsic function FLOAT
C               to REAL, and
C           (c) changing definition of variable TPI by using
C               FORTRAN intrinsic function ATAN instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADBG
      DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*),
     +          C2(IDL1,*), CH2(IDL1,*), WA(*)
C***FIRST EXECUTABLE STATEMENT  RADBG
      TPI = 8.*ATAN(1.)
      ARG = TPI/IP
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IF (IDO .LT. L1) GO TO 103
      DO 102 K=1,L1
         DO 101 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  101    CONTINUE
  102 CONTINUE
      GO TO 106
  103 DO 105 I=1,IDO
         DO 104 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
  106 DO 108 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 107 K=1,L1
            CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K)
            CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K)
  107    CONTINUE
  108 CONTINUE
      IF (IDO .EQ. 1) GO TO 116
      IF (NBD .LT. L1) GO TO 112
      DO 111 J=2,IPPH
         JC = IPP2-J
         DO 110 K=1,L1
CDIR$ IVDEP
            DO 109 I=3,IDO,2
               IC = IDP2-I
               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      GO TO 116
  112 DO 115 J=2,IPPH
         JC = IPP2-J
CDIR$ IVDEP
         DO 114 I=3,IDO,2
            IC = IDP2-I
            DO 113 K=1,L1
               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  113       CONTINUE
  114    CONTINUE
  115 CONTINUE
  116 AR1 = 1.
      AI1 = 0.
      DO 120 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 117 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2)
            C2(IK,LC) = AI1*CH2(IK,IP)
  117    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 119 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 118 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC)
  118       CONTINUE
  119    CONTINUE
  120 CONTINUE
      DO 122 J=2,IPPH
         DO 121 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  121    CONTINUE
  122 CONTINUE
      DO 124 J=2,IPPH
         JC = IPP2-J
         DO 123 K=1,L1
            CH(1,K,J) = C1(1,K,J)-C1(1,K,JC)
            CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC)
  123    CONTINUE
  124 CONTINUE
      IF (IDO .EQ. 1) GO TO 132
      IF (NBD .LT. L1) GO TO 128
      DO 127 J=2,IPPH
         JC = IPP2-J
         DO 126 K=1,L1
CDIR$ IVDEP
            DO 125 I=3,IDO,2
               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      GO TO 132
  128 DO 131 J=2,IPPH
         JC = IPP2-J
         DO 130 I=3,IDO,2
            DO 129 K=1,L1
               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
  129       CONTINUE
  130    CONTINUE
  131 CONTINUE
  132 CONTINUE
      IF (IDO .EQ. 1) RETURN
      DO 133 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  133 CONTINUE
      DO 135 J=2,IP
         DO 134 K=1,L1
            C1(1,K,J) = CH(1,K,J)
  134    CONTINUE
  135 CONTINUE
      IF (NBD .GT. L1) GO TO 139
      IS = -IDO
      DO 138 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 137 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 136 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  136       CONTINUE
  137    CONTINUE
  138 CONTINUE
      GO TO 143
  139 IS = -IDO
      DO 142 J=2,IP
         IS = IS+IDO
         DO 141 K=1,L1
            IDIJ = IS
CDIR$ IVDEP
            DO 140 I=3,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  140       CONTINUE
  141    CONTINUE
  142 CONTINUE
  143 RETURN
      END
*DECK RADF2
      SUBROUTINE RADF2 (IDO, L1, CC, CH, WA1)
C***BEGIN PROLOGUE  RADF2
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            length two.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADF2-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   881128  Modified by Dick Valent to meet prologue standards.
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADF2
      DIMENSION CH(IDO,2,*), CC(IDO,L1,2), WA1(*)
C***FIRST EXECUTABLE STATEMENT  RADF2
      DO 101 K=1,L1
         CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 108
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=3,IDO,2
            IC = IDP2-I
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CH(I,1,K) = CC(I,K,1)+TI2
            CH(IC,2,K) = TI2-CC(I,K,1)
            CH(I-1,1,K) = CC(I-1,K,1)+TR2
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  103    CONTINUE
  104 CONTINUE
      GO TO 111
  108 DO 110 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 109 K=1,L1
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CH(I,1,K) = CC(I,K,1)+TI2
            CH(IC,2,K) = TI2-CC(I,K,1)
            CH(I-1,1,K) = CC(I-1,K,1)+TR2
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  109    CONTINUE
  110 CONTINUE
  111 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         CH(1,2,K) = -CC(IDO,K,2)
         CH(IDO,1,K) = CC(IDO,K,1)
  106 CONTINUE
  107 RETURN
      END
*DECK RADF3
      SUBROUTINE RADF3 (IDO, L1, CC, CH, WA1, WA2)
C***BEGIN PROLOGUE  RADF3
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            length three.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADF3-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing definition of variable TAUI by using
C               FORTRAN intrinsic function SQRT instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADF3
      DIMENSION CH(IDO,3,*), CC(IDO,L1,3), WA1(*), WA2(*)
C***FIRST EXECUTABLE STATEMENT  RADF3
      TAUR = -.5
      TAUI = .5*SQRT(3.)
      DO 101 K=1,L1
         CR2 = CC(1,K,2)+CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2
         CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
         CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
CDIR$ IVDEP
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR2 = DR2+DR3
            CI2 = DI2+DI3
            CH(I-1,1,K) = CC(I-1,K,1)+CR2
            CH(I,1,K) = CC(I,K,1)+CI2
            TR2 = CC(I-1,K,1)+TAUR*CR2
            TI2 = CC(I,K,1)+TAUR*CI2
            TR3 = TAUI*(DI2-DI3)
            TI3 = TAUI*(DR3-DR2)
            CH(I-1,3,K) = TR2+TR3
            CH(IC-1,2,K) = TR2-TR3
            CH(I,3,K) = TI2+TI3
            CH(IC,2,K) = TI3-TI2
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 105 K=1,L1
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR2 = DR2+DR3
            CI2 = DI2+DI3
            CH(I-1,1,K) = CC(I-1,K,1)+CR2
            CH(I,1,K) = CC(I,K,1)+CI2
            TR2 = CC(I-1,K,1)+TAUR*CR2
            TI2 = CC(I,K,1)+TAUR*CI2
            TR3 = TAUI*(DI2-DI3)
            TI3 = TAUI*(DR3-DR2)
            CH(I-1,3,K) = TR2+TR3
            CH(IC-1,2,K) = TR2-TR3
            CH(I,3,K) = TI2+TI3
            CH(IC,2,K) = TI3-TI2
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
*DECK RADF4
      SUBROUTINE RADF4 (IDO, L1, CC, CH, WA1, WA2, WA3)
C***BEGIN PROLOGUE  RADF4
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            length four.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADF4-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*).
C           (b) changing definition of variable HSQT2 by using
C               FORTRAN intrinsic function SQRT instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADF4
      DIMENSION CC(IDO,L1,4), CH(IDO,4,*), WA1(*), WA2(*), WA3(*)
C***FIRST EXECUTABLE STATEMENT  RADF4
      HSQT2 = .5*SQRT(2.)
      DO 101 K=1,L1
         TR1 = CC(1,K,2)+CC(1,K,4)
         TR2 = CC(1,K,1)+CC(1,K,3)
         CH(1,1,K) = TR1+TR2
         CH(IDO,4,K) = TR2-TR1
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
         CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 111
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=3,IDO,2
            IC = IDP2-I
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  103    CONTINUE
  104 CONTINUE
      GO TO 110
  111 DO 109 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 108 K=1,L1
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  108    CONTINUE
  109 CONTINUE
  110 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
         TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
         CH(IDO,1,K) = TR1+CC(IDO,K,1)
         CH(IDO,3,K) = CC(IDO,K,1)-TR1
         CH(1,2,K) = TI1-CC(IDO,K,3)
         CH(1,4,K) = TI1+CC(IDO,K,3)
  106 CONTINUE
  107 RETURN
      END
*DECK RADF5
      SUBROUTINE RADF5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4)
C***BEGIN PROLOGUE  RADF5
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            length five.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADF5-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing definition of variables PI, TI11, TI12,
C               TR11, TR12 by using FORTRAN intrinsic functions ATAN
C               and SIN instead of DATA statements.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADF5
      DIMENSION CC(IDO,L1,5), CH(IDO,5,*), WA1(*), WA2(*), WA3(*),
     +          WA4(*)
C***FIRST EXECUTABLE STATEMENT  RADF5
      PI = 4.*ATAN(1.)
      TR11 = SIN(.1*PI)
      TI11 = SIN(.4*PI)
      TR12 = -SIN(.3*PI)
      TI12 = SIN(.2*PI)
      DO 101 K=1,L1
         CR2 = CC(1,K,5)+CC(1,K,2)
         CI5 = CC(1,K,5)-CC(1,K,2)
         CR3 = CC(1,K,4)+CC(1,K,3)
         CI4 = CC(1,K,4)-CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2+CR3
         CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
         CH(1,3,K) = TI11*CI5+TI12*CI4
         CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
         CH(1,5,K) = TI12*CI5-TI11*CI4
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
CDIR$ IVDEP
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
            CR2 = DR2+DR5
            CI5 = DR5-DR2
            CR5 = DI2-DI5
            CI2 = DI2+DI5
            CR3 = DR3+DR4
            CI4 = DR4-DR3
            CR4 = DI3-DI4
            CI3 = DI3+DI4
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
            CH(I,1,K) = CC(I,K,1)+CI2+CI3
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
            TR5 = TI11*CR5+TI12*CR4
            TI5 = TI11*CI5+TI12*CI4
            TR4 = TI12*CR5-TI11*CR4
            TI4 = TI12*CI5-TI11*CI4
            CH(I-1,3,K) = TR2+TR5
            CH(IC-1,2,K) = TR2-TR5
            CH(I,3,K) = TI2+TI5
            CH(IC,2,K) = TI5-TI2
            CH(I-1,5,K) = TR3+TR4
            CH(IC-1,4,K) = TR3-TR4
            CH(I,5,K) = TI3+TI4
            CH(IC,4,K) = TI4-TI3
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 105 K=1,L1
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
            CR2 = DR2+DR5
            CI5 = DR5-DR2
            CR5 = DI2-DI5
            CI2 = DI2+DI5
            CR3 = DR3+DR4
            CI4 = DR4-DR3
            CR4 = DI3-DI4
            CI3 = DI3+DI4
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
            CH(I,1,K) = CC(I,K,1)+CI2+CI3
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
            TR5 = TI11*CR5+TI12*CR4
            TI5 = TI11*CI5+TI12*CI4
            TR4 = TI12*CR5-TI11*CR4
            TI4 = TI12*CI5-TI11*CI4
            CH(I-1,3,K) = TR2+TR5
            CH(IC-1,2,K) = TR2-TR5
            CH(I,3,K) = TI2+TI5
            CH(IC,2,K) = TI5-TI2
            CH(I-1,5,K) = TR3+TR4
            CH(IC-1,4,K) = TR3-TR4
            CH(I,5,K) = TI3+TI4
            CH(IC,4,K) = TI4-TI3
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
*DECK RADFG
      SUBROUTINE RADFG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA)
C***BEGIN PROLOGUE  RADFG
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            arbitrary length.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADFG-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing references to intrinsic function FLOAT
C               to REAL, and
C           (c) changing definition of variable TPI by using
C               FORTRAN intrinsic function ATAN instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADFG
      DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*),
     +          C2(IDL1,*), CH2(IDL1,*), WA(*)
C***FIRST EXECUTABLE STATEMENT  RADFG
      TPI = 8.*ATAN(1.)
      ARG = TPI/IP
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IPPH = (IP+1)/2
      IPP2 = IP+2
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IF (IDO .EQ. 1) GO TO 119
      DO 101 IK=1,IDL1
         CH2(IK,1) = C2(IK,1)
  101 CONTINUE
      DO 103 J=2,IP
         DO 102 K=1,L1
            CH(1,K,J) = C1(1,K,J)
  102    CONTINUE
  103 CONTINUE
      IF (NBD .GT. L1) GO TO 107
      IS = -IDO
      DO 106 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 105 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 104 K=1,L1
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  104       CONTINUE
  105    CONTINUE
  106 CONTINUE
      GO TO 111
  107 IS = -IDO
      DO 110 J=2,IP
         IS = IS+IDO
         DO 109 K=1,L1
            IDIJ = IS
CDIR$ IVDEP
            DO 108 I=3,IDO,2
               IDIJ = IDIJ+2
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  108       CONTINUE
  109    CONTINUE
  110 CONTINUE
  111 IF (NBD .LT. L1) GO TO 115
      DO 114 J=2,IPPH
         JC = IPP2-J
         DO 113 K=1,L1
CDIR$ IVDEP
            DO 112 I=3,IDO,2
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  112       CONTINUE
  113    CONTINUE
  114 CONTINUE
      GO TO 121
  115 DO 118 J=2,IPPH
         JC = IPP2-J
         DO 117 I=3,IDO,2
            DO 116 K=1,L1
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  116       CONTINUE
  117    CONTINUE
  118 CONTINUE
      GO TO 121
  119 DO 120 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  120 CONTINUE
  121 DO 123 J=2,IPPH
         JC = IPP2-J
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
            C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
  122    CONTINUE
  123 CONTINUE
C
      AR1 = 1.
      AI1 = 0.
      DO 127 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 124 IK=1,IDL1
            CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
            CH2(IK,LC) = AI1*C2(IK,IP)
  124    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 126 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 125 IK=1,IDL1
               CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
               CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      DO 129 J=2,IPPH
         DO 128 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+C2(IK,J)
  128    CONTINUE
  129 CONTINUE
C
      IF (IDO .LT. L1) GO TO 132
      DO 131 K=1,L1
         DO 130 I=1,IDO
            CC(I,1,K) = CH(I,K,1)
  130    CONTINUE
  131 CONTINUE
      GO TO 135
  132 DO 134 I=1,IDO
         DO 133 K=1,L1
            CC(I,1,K) = CH(I,K,1)
  133    CONTINUE
  134 CONTINUE
  135 DO 137 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 136 K=1,L1
            CC(IDO,J2-2,K) = CH(1,K,J)
            CC(1,J2-1,K) = CH(1,K,JC)
  136    CONTINUE
  137 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IF (NBD .LT. L1) GO TO 141
      DO 140 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 139 K=1,L1
CDIR$ IVDEP
            DO 138 I=3,IDO,2
               IC = IDP2-I
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  138       CONTINUE
  139    CONTINUE
  140 CONTINUE
      RETURN
  141 DO 144 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 143 I=3,IDO,2
            IC = IDP2-I
            DO 142 K=1,L1
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  142       CONTINUE
  143    CONTINUE
  144 CONTINUE
      RETURN
      END
#ifdef GAG_USE_UNDERSCORE
C Symbol RAND (and RGAUSS and RUNIF using it) conflicts with the C
C standard symbol 'rand' when compiling with the -assume nounderscore
C option (used at PdBI).
*DECK RAND
      FUNCTION RAND (R)
C***BEGIN PROLOGUE  RAND
C***PURPOSE  Generate a uniformly distributed random number.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  L6A21
C***TYPE      SINGLE PRECISION (RAND-S)
C***KEYWORDS  FNLIB, RANDOM NUMBER, SPECIAL FUNCTIONS, UNIFORM
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C      This pseudo-random number generator is portable among a wide
C variety of computers.  RAND(R) undoubtedly is not as good as many
C readily available installation dependent versions, and so this
C routine is not recommended for widespread usage.  Its redeeming
C feature is that the exact same random numbers (to within final round-
C off error) can be generated from machine to machine.  Thus, programs
C that make use of random numbers can be easily transported to and
C checked in a new environment.
C
C      The random numbers are generated by the linear congruential
C method described, e.g., by Knuth in Seminumerical Methods (p.9),
C Addison-Wesley, 1969.  Given the I-th number of a pseudo-random
C sequence, the I+1 -st number is generated from
C             X(I+1) = (A*X(I) + C) MOD M,
C where here M = 2**22 = 4194304, C = 1731 and several suitable values
C of the multiplier A are discussed below.  Both the multiplier A and
C random number X are represented in double precision as two 11-bit
C words.  The constants are chosen so that the period is the maximum
C possible, 4194304.
C
C      In order that the same numbers be generated from machine to
C machine, it is necessary that 23-bit integers be reducible modulo
C 2**11 exactly, that 23-bit integers be added exactly, and that 11-bit
C integers be multiplied exactly.  Furthermore, if the restart option
C is used (where R is between 0 and 1), then the product R*2**22 =
C R*4194304 must be correct to the nearest integer.
C
C      The first four random numbers should be .0004127026,
C .6750836372, .1614754200, and .9086198807.  The tenth random number
C is .5527787209, and the hundredth is .3600893021 .  The thousandth
C number should be .2176990509 .
C
C      In order to generate several effectively independent sequences
C with the same generator, it is necessary to know the random number
C for several widely spaced calls.  The I-th random number times 2**22,
C where I=K*P/8 and P is the period of the sequence (P = 2**22), is
C still of the form L*P/8.  In particular we find the I-th random
C number multiplied by 2**22 is given by
C I   =  0  1*P/8  2*P/8  3*P/8  4*P/8  5*P/8  6*P/8  7*P/8  8*P/8
C RAND=  0  5*P/8  2*P/8  7*P/8  4*P/8  1*P/8  6*P/8  3*P/8  0
C Thus the 4*P/8 = 2097152 random number is 2097152/2**22.
C
C      Several multipliers have been subjected to the spectral test
C (see Knuth, p. 82).  Four suitable multipliers roughly in order of
C goodness according to the spectral test are
C    3146757 = 1536*2048 + 1029 = 2**21 + 2**20 + 2**10 + 5
C    2098181 = 1024*2048 + 1029 = 2**21 + 2**10 + 5
C    3146245 = 1536*2048 +  517 = 2**21 + 2**20 + 2**9 + 5
C    2776669 = 1355*2048 + 1629 = 5**9 + 7**7 + 1
C
C      In the table below LOG10(NU(I)) gives roughly the number of
C random decimal digits in the random numbers considered I at a time.
C C is the primary measure of goodness.  In both cases bigger is better.
C
C                   LOG10 NU(I)              C(I)
C       A       I=2  I=3  I=4  I=5    I=2  I=3  I=4  I=5
C
C    3146757    3.3  2.0  1.6  1.3    3.1  1.3  4.6  2.6
C    2098181    3.3  2.0  1.6  1.2    3.2  1.3  4.6  1.7
C    3146245    3.3  2.2  1.5  1.1    3.2  4.2  1.1  0.4
C    2776669    3.3  2.1  1.6  1.3    2.5  2.0  1.9  2.6
C   Best
C    Possible   3.3  2.3  1.7  1.4    3.6  5.9  9.7  14.9
C
C             Input Argument --
C R      If R=0., the next random number of the sequence is generated.
C        If R .LT. 0., the last generated number will be returned for
C          possible use in a restart procedure.
C        If R .GT. 0., the sequence of random numbers will start with
C          the seed R mod 1.  This seed is also returned as the value of
C          RAND provided the arithmetic is done exactly.
C
C             Output Value --
C RAND   a pseudo-random number between 0. and 1.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  RAND
      SAVE IA1, IA0, IA1MA0, IC, IX1, IX0
      DATA IA1, IA0, IA1MA0 /1536, 1029, 507/
      DATA IC /1731/
      DATA IX1, IX0 /0, 0/
C***FIRST EXECUTABLE STATEMENT  RAND
      IF (R.LT.0.) GO TO 10
      IF (R.GT.0.) GO TO 20
C
C           A*X = 2**22*IA1*IX1 + 2**11*(IA1*IX1 + (IA1-IA0)*(IX0-IX1)
C                   + IA0*IX0) + IA0*IX0
C
      IY0 = IA0*IX0
      IY1 = IA1*IX1 + IA1MA0*(IX0-IX1) + IY0
      IY0 = IY0 + IC
      IX0 = MOD (IY0, 2048)
      IY1 = IY1 + (IY0-IX0)/2048
      IX1 = MOD (IY1, 2048)
C
 10   RAND = IX1*2048 + IX0
      RAND = RAND / 4194304.
      RETURN
C
 20   IX1 = MOD(R,1.)*4194304. + 0.5
      IX0 = MOD (IX1, 2048)
      IX1 = (IX1-IX0)/2048
      GO TO 10
C
      END
#endif
*DECK RATQR
      SUBROUTINE RATQR (N, EPS1, D, E, E2, M, W, IND, BD, TYPE, IDEF,
     +   IERR)
C***BEGIN PROLOGUE  RATQR
C***PURPOSE  Compute the largest or smallest eigenvalues of a symmetric
C            tridiagonal matrix using the rational QR method with Newton
C            correction.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5, D4C2A
C***TYPE      SINGLE PRECISION (RATQR-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure RATQR,
C     NUM. MATH. 11, 264-272(1968) by REINSCH and BAUER.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 257-265(1971).
C
C     This subroutine finds the algebraically smallest or largest
C     eigenvalues of a SYMMETRIC TRIDIAGONAL matrix by the
C     rational QR method with Newton corrections.
C
C     On Input
C
C        N is the order of the matrix.  N is an INTEGER variable.
C
C        EPS1 is a theoretical absolute error tolerance for the
C          computed eigenvalues.  If the input EPS1 is non-positive, or
C          indeed smaller than its default value, it is reset at each
C          iteration to the respective default value, namely, the
C          product of the relative machine precision and the magnitude
C          of the current eigenvalue iterate.  The theoretical absolute
C          error in the K-th eigenvalue is usually not greater than
C          K times EPS1.  EPS1 is a REAL variable.
C
C        D contains the diagonal elements of the symmetric tridiagonal
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the symmetric
C          tridiagonal matrix in its last N-1 positions.  E(1) is
C          arbitrary.  E is a one-dimensional REAL array, dimensioned
C          E(N).
C
C        E2 contains the squares of the corresponding elements of E in
C          its last N-1 positions.  E2(1) is arbitrary.  E2 is a one-
C          dimensional REAL array, dimensioned E2(N).
C
C        M is the number of eigenvalues to be found.  M is an INTEGER
C          variable.
C
C        IDEF should be set to 1 if the input matrix is known to be
C          positive definite, to -1 if the input matrix is known to
C          be negative definite, and to 0 otherwise.  IDEF is an
C          INTEGER variable.
C
C        TYPE should be set to .TRUE. if the smallest eigenvalues are
C          to be found, and to .FALSE. if the largest eigenvalues are
C          to be found.  TYPE is a LOGICAL variable.
C
C     On Output
C
C        EPS1 is unaltered unless it has been reset to its
C          (last) default value.
C
C        D and E are unaltered (unless W overwrites D).
C
C        Elements of E2, corresponding to elements of E regarded as
C          negligible, have been replaced by zero causing the matrix
C          to split into a direct sum of submatrices.  E2(1) is set
C          to 0.0e0 if the smallest eigenvalues have been found, and
C          to 2.0e0 if the largest eigenvalues have been found.  E2
C          is otherwise unaltered (unless overwritten by BD).
C
C        W contains the M algebraically smallest eigenvalues in
C          ascending order, or the M largest eigenvalues in descending
C          order.  If an error exit is made because of an incorrect
C          specification of IDEF, no eigenvalues are found.  If the
C          Newton iterates for a particular eigenvalue are not monotone,
C          the best estimate obtained is returned and IERR is set.
C          W is a one-dimensional REAL array, dimensioned W(N).  W need
C          not be distinct from D.
C
C        IND contains in its first M positions the submatrix indices
C          associated with the corresponding eigenvalues in W --
C          1 for eigenvalues belonging to the first submatrix from
C          the top, 2 for those belonging to the second submatrix, etc.
C          IND is an one-dimensional INTEGER array, dimensioned IND(N).
C
C        BD contains refined bounds for the theoretical errors of the
C          corresponding eigenvalues in W.  These bounds are usually
C          within the tolerance specified by EPS1.  BD is a one-
C          dimensional REAL array, dimensioned BD(N).  BD need not be
C          distinct from E2.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          6*N+1      if  IDEF  is set to 1 and  TYPE  to .TRUE.
C                     when the matrix is NOT positive definite, or
C                     if  IDEF  is set to -1 and  TYPE  to .FALSE.
C                     when the matrix is NOT negative definite,
C                     no eigenvalues are computed, or
C                     M is greater than N,
C          5*N+K      if successive iterates to the K-th eigenvalue
C                     are NOT monotone increasing, where K refers
C                     to the last such occurrence.
C
C     Note that subroutine TRIDIB is generally faster and more
C     accurate than RATQR if the eigenvalues are clustered.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RATQR
C
      INTEGER I,J,K,M,N,II,JJ,K1,IDEF,IERR,JDEF
      REAL D(*),E(*),E2(*),W(*),BD(*)
      REAL F,P,Q,R,S,EP,QP,ERR,TOT,EPS1,DELTA,MACHEP
      INTEGER IND(*)
      LOGICAL FIRST, TYPE
C
      SAVE FIRST, MACHEP
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  RATQR
      IF (FIRST) THEN
         MACHEP = R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IERR = 0
      JDEF = IDEF
C     .......... COPY D ARRAY INTO W ..........
      DO 20 I = 1, N
   20 W(I) = D(I)
C
      IF (TYPE) GO TO 40
      J = 1
      GO TO 400
   40 ERR = 0.0E0
      S = 0.0E0
C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DEFINE
C                INITIAL SHIFT FROM LOWER GERSCHGORIN BOUND.
C                COPY E2 ARRAY INTO BD ..........
      TOT = W(1)
      Q = 0.0E0
      J = 0
C
      DO 100 I = 1, N
         P = Q
         IF (I .EQ. 1) GO TO 60
         IF (P .GT. MACHEP * (ABS(D(I)) + ABS(D(I-1)))) GO TO 80
   60    E2(I) = 0.0E0
   80    BD(I) = E2(I)
C     .......... COUNT ALSO IF ELEMENT OF E2 HAS UNDERFLOWED ..........
         IF (E2(I) .EQ. 0.0E0) J = J + 1
         IND(I) = J
         Q = 0.0E0
         IF (I .NE. N) Q = ABS(E(I+1))
         TOT = MIN(W(I)-P-Q,TOT)
  100 CONTINUE
C
      IF (JDEF .EQ. 1 .AND. TOT .LT. 0.0E0) GO TO 140
C
      DO 110 I = 1, N
  110 W(I) = W(I) - TOT
C
      GO TO 160
  140 TOT = 0.0E0
C
  160 DO 360 K = 1, M
C     .......... NEXT QR TRANSFORMATION ..........
  180    TOT = TOT + S
         DELTA = W(N) - S
         I = N
         F = ABS(MACHEP*TOT)
         IF (EPS1 .LT. F) EPS1 = F
         IF (DELTA .GT. EPS1) GO TO 190
         IF (DELTA .LT. (-EPS1)) GO TO 1000
         GO TO 300
C     .......... REPLACE SMALL SUB-DIAGONAL SQUARES BY ZERO
C                TO REDUCE THE INCIDENCE OF UNDERFLOWS ..........
  190    IF (K .EQ. N) GO TO 210
         K1 = K + 1
         DO 200 J = K1, N
            IF (BD(J) .LE. (MACHEP*(W(J)+W(J-1))) ** 2) BD(J) = 0.0E0
  200    CONTINUE
C
  210    F = BD(N) / DELTA
         QP = DELTA + F
         P = 1.0E0
         IF (K .EQ. N) GO TO 260
         K1 = N - K
C     .......... FOR I=N-1 STEP -1 UNTIL K DO -- ..........
         DO 240 II = 1, K1
            I = N - II
            Q = W(I) - S - F
            R = Q / QP
            P = P * R + 1.0E0
            EP = F * R
            W(I+1) = QP + EP
            DELTA = Q - EP
            IF (DELTA .GT. EPS1) GO TO 220
            IF (DELTA .LT. (-EPS1)) GO TO 1000
            GO TO 300
  220       F = BD(I) / Q
            QP = DELTA + F
            BD(I+1) = QP * EP
  240    CONTINUE
C
  260    W(K) = QP
         S = QP / P
         IF (TOT + S .GT. TOT) GO TO 180
C     .......... SET ERROR -- IRREGULAR END OF ITERATION.
C                DEFLATE MINIMUM DIAGONAL ELEMENT ..........
         IERR = 5 * N + K
         S = 0.0E0
         DELTA = QP
C
         DO 280 J = K, N
            IF (W(J) .GT. DELTA) GO TO 280
            I = J
            DELTA = W(J)
  280    CONTINUE
C     .......... CONVERGENCE ..........
  300    IF (I .LT. N) BD(I+1) = BD(I) * F / QP
         II = IND(I)
         IF (I .EQ. K) GO TO 340
         K1 = I - K
C     .......... FOR J=I-1 STEP -1 UNTIL K DO -- ..........
         DO 320 JJ = 1, K1
            J = I - JJ
            W(J+1) = W(J) - S
            BD(J+1) = BD(J)
            IND(J+1) = IND(J)
  320    CONTINUE
C
  340    W(K) = TOT
         ERR = ERR + ABS(DELTA)
         BD(K) = ERR
         IND(K) = II
  360 CONTINUE
C
      IF (TYPE) GO TO 1001
      F = BD(1)
      E2(1) = 2.0E0
      BD(1) = F
      J = 2
C     .......... NEGATE ELEMENTS OF W FOR LARGEST VALUES ..........
  400 DO 500 I = 1, N
  500 W(I) = -W(I)
C
      JDEF = -JDEF
      GO TO (40,1001), J
C     .......... SET ERROR -- IDEF SPECIFIED INCORRECTLY ..........
 1000 IERR = 6 * N + 1
 1001 RETURN
      END
*DECK RC
      REAL FUNCTION RC (X, Y, IER)
C***BEGIN PROLOGUE  RC
C***PURPOSE  Calculate an approximation to
C             RC(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      SINGLE 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.     RC
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation to
C           RC(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 RC.
C
C
C   2.     Calling Sequence
C          RC( X, Y, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, positive variable
C
C
C
C          On Return  (values assigned by the RC routine)
C
C          RC     - Single 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
C   3.    Error Messages
C
C         Value of IER assigned by the RC routine
C
C                  Value Assigned         Error Message Printed
C                  IER = 1                X.LT.0.0E0.OR.Y.LE.0.0E0
C                      = 2                X+Y.LT.LOLIM
C                      = 3                MAX(X,Y) .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 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.0E-78     1.0E+75
C                     CDC 6000/7000 SERIES :   1.0E-292    1.0E+321
C                     UNIVAC 1100 SERIES   :   1.0E-37     1.0E+37
C                     CRAY                 :   2.3E-2466   1.09E+2465
C                     VAX 11 SERIES        :   1.5E-38     3.0E+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.0E-3    2.0E-17
C                           3.0E-3    2.0E-14
C                           1.0E-2    2.0E-11
C                           3.0E-2    2.0E-8
C                           1.0E-1    2.0E-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   RC Special Comments
C
C
C
C
C                  Check: RC(X,X+Z) + RC(Y,Y+Z) = RC(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 RC(X,Y).
C
C          On Output:
C
C          X and Y are unaltered.
C
C
C
C                    RC(0,1/4)=RC(1/16,1/8)=PI=3.14159...
C
C                    RC(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 RC
C
C
C
C                  LN X                X .GT. 0
C
C                                            2
C                  LN(X) = (X-1) RC(((1+X)/2)  , X )
C
C
C   --------------------------------------------------------------------
C
C                  ARCSIN X            -1 .LE. X .LE. 1
C
C                                      2
C                  ARCSIN X = X RC (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 ) RC(X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCTAN X            -INF .LT. X .LT. +INF
C
C                                       2
C                  ARCTAN X = X RC(1,1+X  )
C
C   --------------------------------------------------------------------
C
C                  ARCCOT X            0 .LE. X .LT. INF
C
C                                 2   2
C                  ARCCOT X = RC(X  ,X +1 )
C
C   --------------------------------------------------------------------
C
C                  ARCSINH X           -INF .LT. X .LT. +INF
C
C                                      2
C                  ARCSINH X = X RC(1+X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCCOSH X           X .GE. 1
C
C                                    2        2
C                  ARCCOSH X = SQRT(X -1) RC(X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCTANH X           -1 .LT. X .LT. 1
C
C                                        2
C                  ARCTANH X = X RC(1,1-X  )
C
C   --------------------------------------------------------------------
C
C                  ARCCOTH X           X .GT. 1
C
C                                  2   2
C                  ARCCOTH X = RC(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  R1MACH, 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  RC
      CHARACTER*16 XERN3, XERN4, XERN5
      INTEGER IER
      REAL C1, C2, ERRTOL, LAMDA, LOLIM
      REAL 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  RC
      IF (FIRST) THEN
         ERRTOL = (R1MACH(3)/16.0E0)**(1.0E0/6.0E0)
         LOLIM  = 5.0E0 * R1MACH(1)
         UPLIM  = R1MACH(2) / 5.0E0
C
         C1 = 1.0E0/7.0E0
         C2 = 9.0E0/22.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RC = 0.0E0
      IF (X.LT.0.0E0.OR.Y.LE.0.0E0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         CALL XERMSG ('SLATEC', 'RC',
     *      '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', 'RC',
     *      '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', 'RC',
     *      '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.0E0
      SN = (YN+MU)/MU - 2.0E0
      IF (ABS(SN).LT.ERRTOL) GO TO 40
      LAMDA = 2.0E0*SQRT(XN)*SQRT(YN) + YN
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      GO TO 30
C
   40 S = SN*SN*(0.30E0+SN*(C1+SN*(0.3750E0+SN*C2)))
      RC = (1.0E0+S)/SQRT(MU)
      RETURN
      END
*DECK RC3JJ
      SUBROUTINE RC3JJ (L2, L3, M2, M3, L1MIN, L1MAX, THRCOF, NDIM, IER)
C***BEGIN PROLOGUE  RC3JJ
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      SINGLE 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        REAL L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
C        INTEGER NDIM, IER
C
C        CALL RC3JJ (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  R1MACH, 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 R1MACH.
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  RC3JJ
C
      INTEGER NDIM, IER
      REAL L2, L3, M2, M3, L1MIN, L1MAX, THRCOF(NDIM)
C
      INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM,
     +        NSTEP2
      REAL A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, R1MACH,
     +     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.0,0.01,1.0,2.0,3.0/
C
C***FIRST EXECUTABLE STATEMENT  RC3JJ
      IER=0
C  HUGE is the square root of one twentieth of the largest floating
C  point number, approximately.
      HUGE = SQRT(R1MACH(2)/20.0)
      SRHUGE = SQRT(HUGE)
      TINY = 1.0/HUGE
      SRTINY = 1.0/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','RC3JJ','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','RC3JJ','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','RC3JJ','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','RC3JJ','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','RC3JJ','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.0
      C1 = 0.0
      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 RC3JM
      SUBROUTINE RC3JM (L1, L2, L3, M1, M2MIN, M2MAX, THRCOF, NDIM, IER)
C***BEGIN PROLOGUE  RC3JM
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      SINGLE 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        REAL L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM)
C        INTEGER NDIM, IER
C
C        CALL RC3JM (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  R1MACH, 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 R1MACH.
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  RC3JM
C
      INTEGER NDIM, IER
      REAL L1, L2, L3, M1, M2MIN, M2MAX, THRCOF(NDIM)
C
      INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM,
     +        NSTEP2
      REAL A1, A1S, C1, C1OLD, C2, CNORM, R1MACH, 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.0,0.01,1.0,2.0/
C
C***FIRST EXECUTABLE STATEMENT  RC3JM
      IER=0
C  HUGE is the square root of one twentieth of the largest floating
C  point number, approximately.
      HUGE = SQRT(R1MACH(2)/20.0)
      SRHUGE = SQRT(HUGE)
      TINY = 1.0/HUGE
      SRTINY = 1.0/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','RC3JM','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','RC3JM','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','RC3JM','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','RC3JM','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','RC3JM','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','RC3JM','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.0
      C1 = 0.0
      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 RC6J
      SUBROUTINE RC6J (L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF, NDIM,
     +   IER)
C***BEGIN PROLOGUE  RC6J
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      SINGLE 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        REAL L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM)
C        INTEGER NDIM, IER
C
C        CALL RC6J(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  R1MACH, 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 R1MACH.
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  RC6J
C
      INTEGER NDIM, IER
      REAL L2, L3, L4, L5, L6, L1MIN, L1MAX, SIXCOF(NDIM)
C
      INTEGER I, INDEX, LSTEP, N, NFIN, NFINP1, NFINP2, NFINP3, NLIM,
     +        NSTEP2
      REAL A1, A1S, A2, A2S, C1, C1OLD, C2, CNORM, R1MACH,
     +     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.0,0.01,1.0,2.0,3.0/
C
C***FIRST EXECUTABLE STATEMENT  RC6J
      IER=0
C  HUGE is the square root of one twentieth of the largest floating
C  point number, approximately.
      HUGE = SQRT(R1MACH(2)/20.0)
      SRHUGE = SQRT(HUGE)
      TINY = 1.0/HUGE
      SRTINY = 1.0/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','RC6J','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','RC6J','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','RC6J','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','RC6J','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','RC6J','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','RC6J','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.0
      C1 = 0.0
      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 RD
      REAL FUNCTION RD (X, Y, Z, IER)
C***BEGIN PROLOGUE  RD
C***PURPOSE  Compute the incomplete or complete elliptic integral of the
C            2nd kind.  For X and Y nonnegative, X+Y and Z positive,
C             RD(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      SINGLE 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.     RD
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the second kind
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation result to
C          RD(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          RD( X, Y, Z, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, nonnegative variable
C
C                   X + Y is positive
C
C          Z      - Real, positive variable
C
C
C
C          On Return     (values assigned by the RD routine)
C
C          RD     - Real 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 RD routine
C
C                  Value Assigned         Error Message Printed
C                  IER = 1                MIN(X,Y) .LT. 0.0E0
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.1E0 * ERRTOL / machine
C                    minimum) ** (2/3), where ERRTOL is described below.
C                    In the following table it is assumed that ERRTOL
C                    will never be chosen smaller than 1.0E-5.
C
C
C                    Acceptable Values For:   LOLIM      UPLIM
C                    IBM 360/370 SERIES   :   6.0E-51     1.0E+48
C                    CDC 6000/7000 SERIES :   5.0E-215    2.0E+191
C                    UNIVAC 1100 SERIES   :   1.0E-25     2.0E+21
C                    CRAY                 :   3.0E-1644   1.69E+1640
C                    VAX 11 SERIES        :   1.0E-25     4.5E+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 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
C          Sample Choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0E-3    4.0E-18
C                           3.0E-3    3.0E-15
C                           1.0E-2    4.0E-12
C                           3.0E-2    3.0E-9
C                           1.0E-1    4.0E-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   RD Special Comments
C
C
C
C          Check: RD(X,Y,Z) + RD(Y,Z,X) + RD(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 RD(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, and 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 Functions via RD and RF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 2nd kind
C                  ----------------------------------------------
C
C
C                                            2         2   2
C                  E(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1) -
C
C                     2      3            2         2   2
C                  -(K/3) SIN (PHI) RD(COS (PHI),1-K SIN (PHI),1)
C
C
C                                 2        2           2
C                  E(K) = RF(0,1-K ,1) - (K/3) RD(3,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 2nd kind
C                  ----------------------------------------------
C
C                                              2 2    2
C                  EL2(X,KC,A,B) = AX RF(1,1+KC X ,1+X ) +
C
C                                              3         2 2    2
C                                 +(1/3)(B-A) X RD(1,1+KC X ,1+X )
C
C
C
C                  Legendre form of alternative ELLIPTIC INTEGRAL of 2nd
C                  -----------------------------------------------------
C                        kind
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)  RD(COS Q,1-K SIN Q,1)
C
C
C
C
C
C                  Lemniscate constant B
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)RD (0,2,1)
C
C
C
C
C                  Heuman's LAMBDA function
C                  ------------------------
C
C
C
C                  (PI/2) LAMBDA0(A,B) =
C
C                                       2                2
C                     = SIN(B) (RF(0,COS (A),1)-(1/3) SIN (A) *
C
C                               2              2         2       2
C                      *RD(0,COS (A),1)) RF(COS (B),1-COS (A) SIN (B),1)
C
C                               2       3            2
C                     -(1/3) COS (A) SIN (B) RF(0,COS (A),1) *
C
C                             2         2       2
C                      *RD(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) RF(COS (B),1-K SIN (B),1)
C
C
C                                      2            2
C                             *RD(0,1-K ,1)/RF(0,1-K ,1)
C
C                               2       3          2       2   2
C                            -(K /3) SIN (B) RD(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  R1MACH, 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  RD
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      REAL LOLIM, UPLIM, EPSLON, ERRTOL
      REAL C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA
      REAL MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV
      REAL 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  RD
      IF (FIRST) THEN
         ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0)
         LOLIM  = 2.0E0/(R1MACH(2))**(2.0E0/3.0E0)
         TUPLIM = R1MACH(1)**(1.0E0/3.0E0)
         TUPLIM = (0.10E0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM
         UPLIM  = TUPLIM**2.0E0
C
         C1 = 3.0E0/14.0E0
         C2 = 1.0E0/6.0E0
         C3 = 9.0E0/22.0E0
         C4 = 3.0E0/26.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RD = 0.0E0
      IF( MIN(X,Y).LT.0.0E0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         CALL XERMSG ('SLATEC', 'RD',
     *      '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', 'RD',
     *      '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', 'RD',
     *      '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.0E0
      POWER4 = 1.0E0
C
   30 MU = (XN+YN+3.0E0*ZN)*0.20E0
      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.250E0
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      ZN = (ZN+LAMDA)*0.250E0
      GO TO 30
C
   40 EA = XNDEV*YNDEV
      EB = ZNDEV*ZNDEV
      EC = EA - EB
      ED = EA - 6.0E0*EB
      EF = ED + EC + EC
      S1 = ED*(-C1+0.250E0*C3*ED-1.50E0*C4*ZNDEV*EF)
      S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA))
      RD = 3.0E0*SIGMA + POWER4*(1.0E0+S1+S2)/(MU* SQRT(MU))
C
      RETURN
      END
*DECK REBAK
      SUBROUTINE REBAK (NM, N, B, DL, M, Z)
C***BEGIN PROLOGUE  REBAK
C***PURPOSE  Form the eigenvectors of a generalized symmetric
C            eigensystem from the eigenvectors of derived matrix output
C            from REDUC or REDUC2.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (REBAK-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure REBAKA,
C     NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
C
C     This subroutine forms the eigenvectors of a generalized
C     SYMMETRIC eigensystem by back transforming those of the
C     derived symmetric matrix determined by  REDUC  or  REDUC2.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, B and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix system.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        B contains information about the similarity transformation
C          (Cholesky decomposition) used in the reduction by  REDUC
C          or  REDUC2  in its strict lower triangle.  B is a two-
C          dimensional REAL array, dimensioned B(NM,N).
C
C        DL contains further information about the transformation.
C          DL is a one-dimensional REAL array, dimensioned DL(N).
C
C        M is the number of eigenvectors to be back transformed.
C          M is an INTEGER variable.
C
C        Z contains the eigenvectors to be back transformed in its
C          first M columns.  Z is a two-dimensional REAL array
C          dimensioned Z(NM,M).
C
C     On Output
C
C        Z contains the transformed eigenvectors in its first
C          M columns.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  REBAK
C
      INTEGER I,J,K,M,N,I1,II,NM
      REAL B(NM,*),DL(*),Z(NM,*)
      REAL X
C
C***FIRST EXECUTABLE STATEMENT  REBAK
      IF (M .EQ. 0) GO TO 200
C
      DO 100 J = 1, M
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
         DO 100 II = 1, N
            I = N + 1 - II
            I1 = I + 1
            X = Z(I,J)
            IF (I .EQ. N) GO TO 80
C
            DO 60 K = I1, N
   60       X = X - B(K,I) * Z(K,J)
C
   80       Z(I,J) = X / DL(I)
  100 CONTINUE
C
  200 RETURN
      END
*DECK REBAKB
      SUBROUTINE REBAKB (NM, N, B, DL, M, Z)
C***BEGIN PROLOGUE  REBAKB
C***PURPOSE  Form the eigenvectors of a generalized symmetric
C            eigensystem from the eigenvectors of derived matrix output
C            from REDUC2.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (REBAKB-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure REBAKB,
C     NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
C
C     This subroutine forms the eigenvectors of a generalized
C     SYMMETRIC eigensystem by back transforming those of the
C     derived symmetric matrix determined by  REDUC2.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, B and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix system.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        B contains information about the similarity transformation
C          (Cholesky decomposition) used in the reduction by  REDUC2
C          in its strict lower triangle.  B is a two-dimensional
C          REAL array, dimensioned B(NM,N).
C
C        DL contains further information about the transformation.
C          DL is a one-dimensional REAL array, dimensioned DL(N).
C
C        M is the number of eigenvectors to be back transformed.
C          M is an INTEGER variable.
C
C        Z contains the eigenvectors to be back transformed in its
C          first M columns.  Z is a two-dimensional REAL array
C          dimensioned Z(NM,M).
C
C     On Output
C
C        Z contains the transformed eigenvectors in its first
C          M columns.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  REBAKB
C
      INTEGER I,J,K,M,N,I1,II,NM
      REAL B(NM,*),DL(*),Z(NM,*)
      REAL X
C
C***FIRST EXECUTABLE STATEMENT  REBAKB
      IF (M .EQ. 0) GO TO 200
C
      DO 100 J = 1, M
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
         DO 100 II = 1, N
            I1 = N - II
            I = I1 + 1
            X = DL(I) * Z(I,J)
            IF (I .EQ. 1) GO TO 80
C
            DO 60 K = 1, I1
   60       X = X + B(I,K) * Z(K,J)
C
   80       Z(I,J) = X
  100 CONTINUE
C
  200 RETURN
      END
*DECK REDUC
      SUBROUTINE REDUC (NM, N, A, B, DL, IERR)
C***BEGIN PROLOGUE  REDUC
C***PURPOSE  Reduce a generalized symmetric eigenproblem to a standard
C            symmetric eigenproblem using Cholesky factorization.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1C
C***TYPE      SINGLE PRECISION (REDUC-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure REDUC1,
C     NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
C
C     This subroutine reduces the generalized SYMMETRIC eigenproblem
C     Ax=(LAMBDA)Bx, where B is POSITIVE DEFINITE, to the standard
C     symmetric eigenproblem using the Cholesky factorization of B.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and B, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  If the Cholesky
C          factor L of B is already available, N should be prefixed
C          with a minus sign.  N is an INTEGER variable.
C
C        A and B contain the real symmetric input matrices.  Only
C          the full upper triangles of the matrices need be supplied.
C          If N is negative, the strict lower triangle of B contains,
C          instead, the strict lower triangle of its Cholesky factor L.
C          A and B are two-dimensional REAL arrays, dimensioned A(NM,N)
C          and B(NM,N).
C
C       DL contains, if N is negative, the diagonal elements of L.
C          DL is a one-dimensional REAL array, dimensioned DL(N).
C
C     On Output
C
C        A contains in its full lower triangle the full lower triangle
C          of the symmetric matrix derived from the reduction to the
C          standard form.  The strict upper triangle of A is unaltered.
C
C        B contains in its strict lower triangle the strict lower
C          triangle of its Cholesky factor L.  The full upper triangle
C          of B is unaltered.
C
C        DL contains the diagonal elements of L.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          7*N+1      if B is not positive definite.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  REDUC
C
      INTEGER I,J,K,N,I1,J1,NM,NN,IERR
      REAL A(NM,*),B(NM,*),DL(*)
      REAL X,Y
C
C***FIRST EXECUTABLE STATEMENT  REDUC
      IERR = 0
      NN = ABS(N)
      IF (N .LT. 0) GO TO 100
C     .......... FORM L IN THE ARRAYS B AND DL ..........
      DO 80 I = 1, N
         I1 = I - 1
C
         DO 80 J = I, N
            X = B(I,J)
            IF (I .EQ. 1) GO TO 40
C
            DO 20 K = 1, I1
   20       X = X - B(I,K) * B(J,K)
C
   40       IF (J .NE. I) GO TO 60
            IF (X .LE. 0.0E0) GO TO 1000
            Y = SQRT(X)
            DL(I) = Y
            GO TO 80
   60       B(J,I) = X / Y
   80 CONTINUE
C     .......... FORM THE TRANSPOSE OF THE UPPER TRIANGLE OF INV(L)*A
C                IN THE LOWER TRIANGLE OF THE ARRAY A ..........
  100 DO 200 I = 1, NN
         I1 = I - 1
         Y = DL(I)
C
         DO 200 J = I, NN
            X = A(I,J)
            IF (I .EQ. 1) GO TO 180
C
            DO 160 K = 1, I1
  160       X = X - B(I,K) * A(J,K)
C
  180       A(J,I) = X / Y
  200 CONTINUE
C     .......... PRE-MULTIPLY BY INV(L) AND OVERWRITE ..........
      DO 300 J = 1, NN
         J1 = J - 1
C
         DO 300 I = J, NN
            X = A(I,J)
            IF (I .EQ. J) GO TO 240
            I1 = I - 1
C
            DO 220 K = J, I1
  220       X = X - A(K,J) * B(I,K)
C
  240       IF (J .EQ. 1) GO TO 280
C
            DO 260 K = 1, J1
  260       X = X - A(J,K) * B(I,K)
C
  280       A(I,J) = X / DL(I)
  300 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- B IS NOT POSITIVE DEFINITE ..........
 1000 IERR = 7 * N + 1
 1001 RETURN
      END
*DECK REDUC2
      SUBROUTINE REDUC2 (NM, N, A, B, DL, IERR)
C***BEGIN PROLOGUE  REDUC2
C***PURPOSE  Reduce a certain generalized symmetric eigenproblem to a
C            standard symmetric eigenproblem using Cholesky
C            factorization.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1C
C***TYPE      SINGLE PRECISION (REDUC2-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure REDUC2,
C     NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
C
C     This subroutine reduces the generalized SYMMETRIC eigenproblems
C     ABx=(LAMBDA)x OR BAy=(LAMBDA)y, where B is POSITIVE DEFINITE,
C     to the standard symmetric eigenproblem using the Cholesky
C     factorization of B.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and B, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  If the Cholesky
C          factor L of B is already available, N should be prefixed
C          with a minus sign.  N is an INTEGER variable.
C
C        A and B contain the real symmetric input matrices.  Only
C          the full upper triangles of the matrices need be supplied.
C          If N is negative, the strict lower triangle of B contains,
C          instead, the strict lower triangle of its Cholesky factor L.
C          A and B are two-dimensional REAL arrays, dimensioned A(NM,N)
C          and B(NM,N).
C
C       DL contains, if N is negative, the diagonal elements of L.
C          DL is a one-dimensional REAL array, dimensioned DL(N).
C
C     On Output
C
C        A contains in its full lower triangle the full lower triangle
C          of the symmetric matrix derived from the reduction to the
C          standard form.  The strict upper triangle of A is unaltered.
C
C        B contains in its strict lower triangle the strict lower
C          triangle of its Cholesky factor L.  The full upper triangle
C          of B is unaltered.
C
C        DL contains the diagonal elements of L.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          7*N+1      if B is not positive definite.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  REDUC2
C
      INTEGER I,J,K,N,I1,J1,NM,NN,IERR
      REAL A(NM,*),B(NM,*),DL(*)
      REAL X,Y
C
C***FIRST EXECUTABLE STATEMENT  REDUC2
      IERR = 0
      NN = ABS(N)
      IF (N .LT. 0) GO TO 100
C     .......... FORM L IN THE ARRAYS B AND DL ..........
      DO 80 I = 1, N
         I1 = I - 1
C
         DO 80 J = I, N
            X = B(I,J)
            IF (I .EQ. 1) GO TO 40
C
            DO 20 K = 1, I1
   20       X = X - B(I,K) * B(J,K)
C
   40       IF (J .NE. I) GO TO 60
            IF (X .LE. 0.0E0) GO TO 1000
            Y = SQRT(X)
            DL(I) = Y
            GO TO 80
   60       B(J,I) = X / Y
   80 CONTINUE
C     .......... FORM THE LOWER TRIANGLE OF A*L
C                IN THE LOWER TRIANGLE OF THE ARRAY A ..........
  100 DO 200 I = 1, NN
         I1 = I + 1
C
         DO 200 J = 1, I
            X = A(J,I) * DL(J)
            IF (J .EQ. I) GO TO 140
            J1 = J + 1
C
            DO 120 K = J1, I
  120       X = X + A(K,I) * B(K,J)
C
  140       IF (I .EQ. NN) GO TO 180
C
            DO 160 K = I1, NN
  160       X = X + A(I,K) * B(K,J)
C
  180       A(I,J) = X
  200 CONTINUE
C     .......... PRE-MULTIPLY BY TRANSPOSE(L) AND OVERWRITE ..........
      DO 300 I = 1, NN
         I1 = I + 1
         Y = DL(I)
C
         DO 300 J = 1, I
            X = Y * A(I,J)
            IF (I .EQ. NN) GO TO 280
C
            DO 260 K = I1, NN
  260       X = X + A(K,J) * B(K,I)
C
  280       A(I,J) = X
  300 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- B IS NOT POSITIVE DEFINITE ..........
 1000 IERR = 7 * N + 1
 1001 RETURN
      END
*DECK REORT
      SUBROUTINE REORT (NCOMP, Y, YP, YHP, NIV, W, S, P, IP, STOWA,
     +   IFLAG)
C***BEGIN PROLOGUE  REORT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE 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  BVSUP
C***ROUTINES CALLED  MGSBV, SDOT, STOR1, STWAY
C***COMMON BLOCKS    ML15TO, ML18JR, ML8SZ
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  REORT
C
      DIMENSION Y(NCOMP,*),YP(*),W(*),S(*),P(*),IP(*),
     1          STOWA(*),YHP(NCOMP,*)
C
C **********************************************************************
C
      COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFC
      COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
     1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
      COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ,
     1                INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC,
     2                ICOCO
C
C **********************************************************************
C***FIRST EXECUTABLE STATEMENT  REORT
      NFCP=NFC+1
C
C     CHECK TO SEE IF ORTHONORMALIZATION TEST IS TO BE PERFORMED
C
      IF (IFLAG .NE. 1) GO TO 5
      KNSWOT=KNSWOT+1
      IF (KNSWOT .GE. NSWOT) GO TO 5
      IF ((XEND-X)*(X-XOT) .LT. 0.) RETURN
    5 CALL STOR1(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 MGSBV(NCOMP,NFC,Y,NCOMP,NIV,MFLAG,S,P,IP,INHOMO,YP,W,WCND)
C
C     ****************************************
C
C  CHECK FOR LINEAR DEPENDENCE OF THE SOLUTIONS.
C
      IF (MFLAG .EQ. 0)  GO TO 25
      IF (IFLAG .EQ. 2) GO TO 15
      IF (NSWOT .GT. 1  .OR.  LOTJP .EQ. 0) GO TO 20
   15 IFLAG=30
      RETURN
C
C     RETRIEVE DATA FOR A RESTART AT LAST ORTHONORMALIZATION POINT
C
   20 CALL STWAY(Y,YP,YHP,1,STOWA)
      LOTJP=1
      NSWOT=1
      KNSWOT=0
      MNSWOT=MNSWOT/2
      TND=TND+1.
      IFLAG=10
      RETURN
C
C     ****************************************
C
   25 IF (IFLAG .NE. 1) GO TO 60
C
C     TEST FOR ORTHONORMALIZATION
C
      IF (WCND .LT. 50.*TOL) GO TO 60
      DO 30 IJK=1,NFCP
      IF (S(IJK) .GT. 1.0E+20) GO TO 60
   30 CONTINUE
C
C     USE LINEAR EXTRAPOLATION ON LOGARITHMIC VALUES OF THE NORM
C     DECREMENTS TO DETERMINE NEXT ORTHONORMALIZATION CHECKPOINT.
C     OTHER CONTROLS ON THE NUMBER OF STEPS TO THE NEXT CHECKPOINT
C     ARE ADDED FOR SAFETY PURPOSES.
C
      NSWOT=KNSWOT
      KNSWOT=0
      LOTJP=0
      WCND=LOG10(WCND)
      IF (WCND .GT. TND+3.) NSWOT=2*NSWOT
      IF (WCND .GE. PWCND) GO TO 40
      DX=X-PX
      DND=PWCND-WCND
      IF (DND .GE. 4) NSWOT=NSWOT/2
      DNDT=WCND-TND
      IF (ABS(DX*DNDT) .GT. DND*ABS(XEND-X)) GO TO 40
      XOT=X+DX*DNDT/DND
      GO TO 50
   40 XOT=XEND
   50 NSWOT=MIN(MNSWOT,NSWOT)
      PWCND=WCND
      PX=X
      RETURN
C
C     ****************************************
C
C     ORTHONORMALIZATION NECESSARY SO WE NORMALIZE THE HOMOGENEOUS
C     SOLUTION VECTORS AND CHANGE W ACCORDINGLY.
C
   60 NSWOT=1
      KNSWOT=0
      LOTJP=1
      KK = 1
      L=1
      DO 70 K = 1,NFCC
      SRP=SQRT(P(KK))
      IF (INHOMO .EQ. 1) W(K)=SRP*W(K)
      VNORM=1./SRP
      P(KK)=VNORM
      KK = KK + NFCC + 1 - K
      IF (NFC .EQ. NFCC) GO TO 63
      IF (L .NE. K/2) GO TO 70
   63 DO 65 J = 1,NCOMP
   65 Y(J,L) = Y(J,L)*VNORM
      L=L+1
   70 CONTINUE
C
      IF (INHOMO .NE. 1  .OR.  NPS .EQ. 1)  GO TO 100
C
C     NORMALIZE THE PARTICULAR SOLUTION
C
      YPNM=SDOT(NCOMP,YP,1,YP,1)
      IF (YPNM .EQ. 0.0)  YPNM = 1.0
      YPNM = SQRT(YPNM)
      S(NFCP) = YPNM
      DO 80 J = 1,NCOMP
   80 YP(J) = YP(J) / YPNM
      DO 90 J = 1,NFCC
   90 W(J) = C * W(J)
C
  100 IF (IFLAG .EQ. 1) CALL STWAY(Y,YP,YHP,0,STOWA)
      IFLAG=0
      RETURN
      END
*DECK RF
      REAL FUNCTION RF (X, Y, Z, IER)
C***BEGIN PROLOGUE  RF
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      SINGLE 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.     RF
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the first kind
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation result to
C          RF(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          RF( X, Y, Z, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, nonnegative variable
C
C          Z      - Single precision, nonnegative variable
C
C
C
C          On Return     (values assigned by the RF routine)
C
C          RF     - Single 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         Value of IER assigned by the RF routine
C
C                  Value assigned         Error Message Printed
C                  IER = 1                MIN(X,Y,Z) .LT. 0.0E0
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.0E-78     1.0E+75
C                     CDC 6000/7000 SERIES :   1.0E-292    1.0E+321
C                     UNIVAC 1100 SERIES   :   1.0E-37     1.0E+37
C                     CRAY                 :   2.3E-2466   1.09E+2465
C                     VAX 11 SERIES        :   1.5E-38     3.0E+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 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
C
C          Sample Choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0E-3    3.0E-19
C                           3.0E-3    2.0E-16
C                           1.0E-2    3.0E-13
C                           3.0E-2    2.0E-10
C                           1.0E-1    3.0E-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   RF Special Comments
C
C
C
C          Check by addition theorem: RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W)
C          = RF(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 RF(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, and 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 Functions via RF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 1st kind
C                  ----------------------------------------------
C
C
C                                            2         2   2
C                  F(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1)
C
C
C                                 2
C                  K(K) = RF(0,1-K ,1)
C
C                         PI/2     2   2      -1/2
C                       = INT  (1-K SIN (PHI) )   D PHI
C                          0
C
C
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 1st kind
C                  ----------------------------------------------
C
C
C                                         2 2    2
C                  EL1(X,KC) = X RF(1,1+KC X ,1+X )
C
C
C
C
C                  Lemniscate constant A
C                  ---------------------
C
C
C                       1      4 -1/2
C                  A = INT (1-S )    DS = RF(0,1,2) = RF(0,2,1)
C                       0
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  R1MACH, 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  RF
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      REAL LOLIM, UPLIM, EPSLON, ERRTOL
      REAL C1, C2, C3, E2, E3, LAMDA
      REAL MU, S, X, XN, XNDEV
      REAL 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  RF
C
      IF (FIRST) THEN
         ERRTOL = (4.0E0*R1MACH(3))**(1.0E0/6.0E0)
         LOLIM  = 5.0E0 * R1MACH(1)
         UPLIM  = R1MACH(2)/5.0E0
C
         C1 = 1.0E0/24.0E0
         C2 = 3.0E0/44.0E0
         C3 = 1.0E0/14.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RF = 0.0E0
      IF (MIN(X,Y,Z).LT.0.0E0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         CALL XERMSG ('SLATEC', 'RF',
     *      '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', 'RF',
     *      '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', 'RF',
     *      '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.0E0
      XNDEV = 2.0E0 - (MU+XN)/MU
      YNDEV = 2.0E0 - (MU+YN)/MU
      ZNDEV = 2.0E0 - (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.250E0
      YN = (YN+LAMDA)*0.250E0
      ZN = (ZN+LAMDA)*0.250E0
      GO TO 30
C
   40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV
      E3 = XNDEV*YNDEV*ZNDEV
      S  = 1.0E0 + (C1*E2-0.10E0-C2*E3)*E2 + C3*E3
      RF = S/SQRT(MU)
C
      RETURN
      END
*DECK RFFTB
      SUBROUTINE RFFTB (N, R, WSAVE)
C***BEGIN PROLOGUE  RFFTB
C***SUBSIDIARY
C***PURPOSE  Compute the backward fast Fourier transform of a real
C            coefficient array.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (RFFTB-S, CFFTB-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C   ********************************************************************
C   *   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   *
C   ********************************************************************
C   *                                                                  *
C   *   This routine uses non-standard Fortran 77 constructs and will  *
C   *   be removed from the library at a future date.  You are         *
C   *   requested to use RFFTB1.                                       *
C   *                                                                  *
C   ********************************************************************
C
C   Subroutine RFFTB computes the real periodic sequence from its
C   Fourier coefficients (Fourier synthesis).  The transform is defined
C   below at output parameter R.
C
C   Input Arguments
C
C   N       the length of the array R to be transformed.  The method
C           is most efficient when N is a product of small primes.
C           N may change so long as different work arrays are provided.
C
C   R       a real array of length N which contains the sequence
C           to be transformed.
C
C   WSAVE   a work array which must be dimensioned at least 2*N+15
C           in the program that calls RFFTB.  The WSAVE array must be
C           initialized by calling subroutine RFFTI, and a different
C           WSAVE array must be used for each different value of N.
C           This initialization does not have to be repeated so long as
C           remains unchanged.  Thus subsequent transforms can be
C           obtained faster than the first.  Moreover, the same WSAVE
C           array can be used by RFFTF and RFFTB as long as N remains
C           unchanged.
C
C   Output Argument
C
C   R       For N even and for I = 1,...,N
C
C                R(I) = R(1)+(-1)**(I-1)*R(N)
C
C                     plus the sum from K=2 to K=N/2 of
C
C                      2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                     -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C           For N odd and for I = 1,...,N
C
C                R(I) = R(1) plus the sum from K=2 to K=(N+1)/2 of
C
C                     2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                    -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C   Note:  This transform is unnormalized since a call of RFFTF
C          followed by a call of RFFTB will multiply the input
C          sequence by N.
C
C   WSAVE  contains results which must not be destroyed between
C          calls of RFFTB or RFFTF.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RFFTB1
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   861211  REVISION DATE from Version 3.2
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from user-callable to subsidiary
C           because of non-standard Fortran 77 arguments in the
C           call to CFFTB1.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RFFTB
      DIMENSION R(*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  RFFTB
      IF (N .EQ. 1) RETURN
      CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
*DECK RFFTB1
      SUBROUTINE RFFTB1 (N, C, CH, WA, IFAC)
C***BEGIN PROLOGUE  RFFTB1
C***PURPOSE  Compute the backward fast Fourier transform of a real
C            coefficient array.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (RFFTB1-S, CFFTB1-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C   Subroutine RFFTB1 computes the real periodic sequence from its
C   Fourier coefficients (Fourier synthesis).  The transform is defined
C   below at output parameter C.
C
C   The arrays WA and IFAC which are used by subroutine RFFTB1 must be
C   initialized by calling subroutine RFFTI1.
C
C   Input Arguments
C
C   N       the length of the array R to be transformed.  The method
C           is most efficient when N is a product of small primes.
C           N may change so long as different work arrays are provided.
C
C   C       a real array of length N which contains the sequence
C           to be transformed.
C
C   CH      a real work array of length at least N.
C
C   WA      a real work array which must be dimensioned at least N.
C
C   IFAC    an integer work array which must be dimensioned at least 15.
C
C           The WA and IFAC arrays must be initialized by calling
C           subroutine RFFTI1, and different WA and IFAC arrays must be
C           used for each different value of N.  This initialization
C           does not have to be repeated so long as N remains unchanged.
C           Thus subsequent transforms can be obtained faster than the
C           first.  The same WA and IFAC arrays can be used by RFFTF1
C           and RFFTB1.
C
C   Output Argument
C
C   C       For N even and for I = 1,...,N
C
C                C(I) = C(1)+(-1)**(I-1)*C(N)
C
C                     plus the sum from K=2 to K=N/2 of
C
C                      2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                     -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C           For N odd and for I = 1,...,N
C
C                C(I) = C(1) plus the sum from K=2 to K=(N+1)/2 of
C
C                     2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                    -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C   Notes:  This transform is unnormalized since a call of RFFTF1
C           followed by a call of RFFTB1 will multiply the input
C           sequence by N.
C
C           WA and IFAC contain initialization calculations which must
C           not be destroyed between calls of subroutine RFFTF1 or
C           RFFTB1.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RADB2, RADB3, RADB4, RADB5, RADBG
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from subsidiary to user-callable.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RFFTB1
      DIMENSION CH(*), C(*), WA(*), IFAC(*)
C***FIRST EXECUTABLE STATEMENT  RFFTB1
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDL1 = IDO*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL RADB2 (IDO,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL RADB2 (IDO,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 110
         CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (IDO .EQ. 1) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDO
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      DO 117 I=1,N
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END
*DECK RFFTF
      SUBROUTINE RFFTF (N, R, WSAVE)
C***BEGIN PROLOGUE  RFFTF
C***SUBSIDIARY
C***PURPOSE  Compute the forward transform of a real, periodic sequence.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (RFFTF-S, CFFTF-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C   ********************************************************************
C   *   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   *
C   ********************************************************************
C   *                                                                  *
C   *   This routine uses non-standard Fortran 77 constructs and will  *
C   *   be removed from the library at a future date.  You are         *
C   *   requested to use RFFTF1.                                       *
C   *                                                                  *
C   ********************************************************************
C
C   Subroutine RFFTF computes the Fourier coefficients of a real
C   periodic sequence (Fourier analysis).  The transform is defined
C   below at output parameter R.
C
C   Input Arguments
C
C   N       the length of the array R to be transformed.  The method
C           is most efficient when N is a product of small primes.
C           N may change so long as different work arrays are provided.
C
C   R       a real array of length N which contains the sequence
C           to be transformed.
C
C   WSAVE   a work array which must be dimensioned at least 2*N+15
C           in the program that calls RFFTF.  The WSAVE array must be
C           initialized by calling subroutine RFFTI, and a different
C           WSAVE array must be used for each different value of N.
C           This initialization does not have to be repeated so long as
C           remains unchanged.  Thus subsequent transforms can be
C           obtained faster than the first.  Moreover, the same WSAVE
C           array can be used by RFFTF and RFFTB as long as N remains
C           unchanged.
C
C   Output Argument
C
C   R       R(1) = the sum from I=1 to I=N of R(I)
C
C           If N is even set L = N/2; if N is odd set L = (N+1)/2
C
C             then for K = 2,...,L
C
C                R(2*K-2) = the sum from I = 1 to I = N of
C
C                     R(I)*COS((K-1)*(I-1)*2*PI/N)
C
C                R(2*K-1) = the sum from I = 1 to I = N of
C
C                    -R(I)*SIN((K-1)*(I-1)*2*PI/N)
C
C           If N is even
C
C                R(N) = the sum from I = 1 to I = N of
C
C                     (-1)**(I-1)*R(I)
C
C   Note:  This transform is unnormalized since a call of RFFTF
C          followed by a call of RFFTB will multiply the input
C          sequence by N.
C
C   WSAVE  contains results which must not be destroyed between
C          calls of RFFTF or RFFTB.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RFFTF1
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   861211  REVISION DATE from Version 3.2
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from user-callable to subsidiary
C           because of non-standard Fortran 77 arguments in the
C           call to CFFTB1.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RFFTF
      DIMENSION R(*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  RFFTF
      IF (N .EQ. 1) RETURN
      CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
*DECK RFFTF1
      SUBROUTINE RFFTF1 (N, C, CH, WA, IFAC)
C***BEGIN PROLOGUE  RFFTF1
C***PURPOSE  Compute the forward transform of a real, periodic sequence.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (RFFTF1-S, CFFTF1-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C   Subroutine RFFTF1 computes the Fourier coefficients of a real
C   periodic sequence (Fourier analysis).  The transform is defined
C   below at output parameter C.
C
C   The arrays WA and IFAC which are used by subroutine RFFTB1 must be
C   initialized by calling subroutine RFFTI1.
C
C   Input Arguments
C
C   N       the length of the array R to be transformed.  The method
C           is most efficient when N is a product of small primes.
C           N may change so long as different work arrays are provided.
C
C   C       a real array of length N which contains the sequence
C           to be transformed.
C
C   CH      a real work array of length at least N.
C
C   WA      a real work array which must be dimensioned at least N.
C
C   IFAC    an integer work array which must be dimensioned at least 15.
C
C           The WA and IFAC arrays must be initialized by calling
C           subroutine RFFTI1, and different WA and IFAC arrays must be
C           used for each different value of N.  This initialization
C           does not have to be repeated so long as N remains unchanged.
C           Thus subsequent transforms can be obtained faster than the
C           first.  The same WA and IFAC arrays can be used by RFFTF1
C           and RFFTB1.
C
C   Output Argument
C
C   C       C(1) = the sum from I=1 to I=N of R(I)
C
C           If N is even set L = N/2; if N is odd set L = (N+1)/2
C
C             then for K = 2,...,L
C
C                C(2*K-2) = the sum from I = 1 to I = N of
C
C                     C(I)*COS((K-1)*(I-1)*2*PI/N)
C
C                C(2*K-1) = the sum from I = 1 to I = N of
C
C                    -C(I)*SIN((K-1)*(I-1)*2*PI/N)
C
C           If N is even
C
C                C(N) = the sum from I = 1 to I = N of
C
C                     (-1)**(I-1)*C(I)
C
C   Notes:  This transform is unnormalized since a call of RFFTF1
C           followed by a call of RFFTB1 will multiply the input
C           sequence by N.
C
C           WA and IFAC contain initialization calculations which must
C           not be destroyed between calls of subroutine RFFTF1 or
C           RFFTB1.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RADF2, RADF3, RADF4, RADF5, RADFG
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from subsidiary to user-callable.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RFFTF1
      DIMENSION CH(*), C(*), WA(*), IFAC(*)
C***FIRST EXECUTABLE STATEMENT  RFFTF1
      NF = IFAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = IFAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .NE. 4) GO TO 102
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  101    CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  102    IF (IP .NE. 2) GO TO 104
         IF (NA .NE. 0) GO TO 103
         CALL RADF2 (IDO,L1,C,CH,WA(IW))
         GO TO 110
  103    CALL RADF2 (IDO,L1,CH,C,WA(IW))
         GO TO 110
  104    IF (IP .NE. 3) GO TO 106
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 105
         CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 110
  105    CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
         GO TO 110
  106    IF (IP .NE. 5) GO TO 108
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  107    CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  108    IF (IDO .EQ. 1) NA = 1-NA
         IF (NA .NE. 0) GO TO 109
         CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         NA = 1
         GO TO 110
  109    CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
         NA = 0
  110    L2 = L1
  111 CONTINUE
      IF (NA .EQ. 1) RETURN
      DO 112 I=1,N
         C(I) = CH(I)
  112 CONTINUE
      RETURN
      END
*DECK RFFTI
      SUBROUTINE RFFTI (N, WSAVE)
C***BEGIN PROLOGUE  RFFTI
C***SUBSIDIARY
C***PURPOSE  Initialize a work array for RFFTF and RFFTB.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (RFFTI-S, CFFTI-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C   ********************************************************************
C   *   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   NOTICE   *
C   ********************************************************************
C   *                                                                  *
C   *   This routine uses non-standard Fortran 77 constructs and will  *
C   *   be removed from the library at a future date.  You are         *
C   *   requested to use RFFTI1.                                       *
C   *                                                                  *
C   ********************************************************************
C
C   Subroutine RFFTI initializes the array WSAVE which is used in
C   both RFFTF and RFFTB.  The prime factorization of N together with
C   a tabulation of the trigonometric functions are computed and
C   stored in WSAVE.
C
C   Input Argument
C
C   N       the length of the sequence to be transformed.
C
C   Output Argument
C
C   WSAVE   a work array which must be dimensioned at least 2*N+15.
C           The same work array can be used for both RFFTF and RFFTB
C           as long as N remains unchanged.  Different WSAVE arrays
C           are required for different values of N.  The contents of
C           WSAVE must not be changed between calls of RFFTF or RFFTB.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RFFTI1
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   861211  REVISION DATE from Version 3.2
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from user-callable to subsidiary
C           because of non-standard Fortran 77 arguments in the
C           call to CFFTB1.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RFFTI
      DIMENSION WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  RFFTI
      IF (N .EQ. 1) RETURN
      CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
*DECK RFFTI1
      SUBROUTINE RFFTI1 (N, WA, IFAC)
C***BEGIN PROLOGUE  RFFTI1
C***PURPOSE  Initialize a real and an integer work array for RFFTF1 and
C            RFFTB1.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (RFFTI1-S, CFFTI1-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C   Subroutine RFFTI1 initializes the work arrays WA and IFAC which are
C   used in both RFFTF1 and RFFTB1.  The prime factorization of N and a
C   tabulation of the trigonometric functions are computed and stored in
C   IFAC and WA, respectively.
C
C   Input Argument
C
C   N       the length of the sequence to be transformed.
C
C   Output Arguments
C
C   WA      a real work array which must be dimensioned at least N.
C
C   IFAC    an integer work array which must be dimensioned at least 15.
C
C   The same work arrays can be used for both RFFTF1 and RFFTB1 as long
C   as N remains unchanged.  Different WA and IFAC arrays are required
C   for different values of N.  The contents of WA and IFAC must not be
C   changed between calls of RFFTF1 or RFFTB1.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing references to intrinsic function FLOAT
C               to REAL, and
C           (c) changing definition of variable TPI by using
C               FORTRAN intrinsic functions instead of DATA
C               statements.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from subsidiary to user-callable.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RFFTI1
      DIMENSION WA(*), IFAC(*), NTRYH(4)
      SAVE NTRYH
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
C***FIRST EXECUTABLE STATEMENT  RFFTI1
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 8.*ATAN(1.)
      ARGH = TPI/N
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 110 K1=1,NFM1
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         DO 109 J=1,IPM
            LD = LD+L1
            I = IS
            ARGLD = LD*ARGH
            FI = 0.
            DO 108 II=3,IDO,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IS = IS+IDO
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END
*DECK RG
      SUBROUTINE RG (NM, N, A, WR, WI, MATZ, Z, IV1, FV1, IERR)
C***BEGIN PROLOGUE  RG
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a real general matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A2
C***TYPE      SINGLE PRECISION (RG-S, CG-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     To find the eigenvalues and eigenvectors (if desired)
C     of a REAL GENERAL matrix.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        A contains the real general matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        A has been destroyed.
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues.  The eigenvalues are unordered except
C          that complex conjugate pairs of eigenvalues appear consecu-
C          tively with the eigenvalue having the positive imaginary part
C          first.  If an error exit is made, the eigenvalues should be
C          correct for indices IERR+1, IERR+2, ..., N.  WR and WI are
C          one-dimensional REAL arrays, dimensioned WR(N) and WI(N).
C
C        Z contains the real and imaginary parts of the eigenvectors
C          if MATZ is not zero.  If the J-th eigenvalue is real, the
C          J-th column of Z contains its eigenvector.  If the J-th
C          eigenvalue is complex with positive imaginary part, the
C          J-th and (J+1)-th columns of Z contain the real and
C          imaginary parts of its eigenvector.  The conjugate of this
C          vector is the eigenvector for the conjugate eigenvalue.
C          Z is a two-dimensional REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30 iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
C                     computed.
C
C        IV1 and FV1 are one-dimensional temporary storage arrays of
C          dimension N.  IV1 is of type INTEGER and FV1 of type REAL.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  BALANC, BALBAK, ELMHES, ELTRAN, HQR, HQR2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C   921103  Corrected description of IV1.  (DWL, FNF and WRB)
C***END PROLOGUE  RG
C
      INTEGER N,NM,IS1,IS2,IERR,MATZ
      REAL A(NM,*),WR(*),WI(*),Z(NM,*),FV1(*)
      INTEGER IV1(*)
C
C***FIRST EXECUTABLE STATEMENT  RG
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 CALL  BALANC(NM,N,A,IS1,IS2,FV1)
      CALL  ELMHES(NM,N,IS1,IS2,A,IV1)
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  HQR(NM,N,IS1,IS2,A,WR,WI,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  ELTRAN(NM,N,IS1,IS2,A,IV1,Z)
      CALL  HQR2(NM,N,IS1,IS2,A,WR,WI,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  BALBAK(NM,N,IS1,IS2,FV1,N,Z)
   50 RETURN
      END
#ifdef GAG_USE_UNDERSCORE
C Symbol RAND (and RGAUSS and RUNIF using it) conflicts with the C
C standard symbol 'rand' when compiling with the -assume nounderscore
C option (used at PdBI).
*DECK RGAUSS
      FUNCTION RGAUSS (XMEAN, SD)
C***BEGIN PROLOGUE  RGAUSS
C***PURPOSE  Generate a normally distributed (Gaussian) random number.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  L6A14
C***TYPE      SINGLE PRECISION (RGAUSS-S)
C***KEYWORDS  FNLIB, GAUSSIAN, NORMAL, RANDOM NUMBER, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Generate a normally distributed random number, i.e., generate random
C numbers with a Gaussian distribution.  These random numbers are not
C exceptionally good -- especially in the tails of the distribution,
C but this implementation is simple and suitable for most applications.
C See R. W. Hamming, Numerical Methods for Scientists and Engineers,
C McGraw-Hill, 1962, pages 34 and 389.
C
C             Input Arguments --
C XMEAN  the mean of the Guassian distribution.
C SD     the standard deviation of the Guassian function
C          EXP (-1/2 * (X-XMEAN)**2 / SD**2)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RAND
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   910819  Added EXTERNAL statement for RAND due to problem on IBM
C           RS 6000.  (WRB)
C***END PROLOGUE  RGAUSS
      EXTERNAL RAND
C***FIRST EXECUTABLE STATEMENT  RGAUSS
      RGAUSS = -6.0
      DO 10 I=1,12
        RGAUSS = RGAUSS + RAND(0.0)
 10   CONTINUE
C
      RGAUSS = XMEAN + SD*RGAUSS
C
      RETURN
      END
#endif
*DECK RGG
      SUBROUTINE RGG (NM, N, A, B, ALFR, ALFI, BETA, MATZ, Z, IERR)
C***BEGIN PROLOGUE  RGG
C***PURPOSE  Compute the eigenvalues and eigenvectors for a real
C            generalized eigenproblem.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4B2
C***TYPE      SINGLE PRECISION (RGG-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     for the REAL GENERAL GENERALIZED eigenproblem  Ax = (LAMBDA)Bx.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real general matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        B contains a real general matrix.  B is a two-dimensional
C          REAL array, dimensioned B(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        A and B have been destroyed.
C
C        ALFR and ALFI contain the real and imaginary parts,
C          respectively, of the numerators of the eigenvalues.
C          ALFR and ALFI are one-dimensional REAL arrays,
C          dimensioned ALFR(N) and ALFI(N).
C
C        BETA contains the denominators of the eigenvalues,
C          which are thus given by the ratios  (ALFR+I*ALFI)/BETA.
C          Complex conjugate pairs of eigenvalues appear consecutively
C          with the eigenvalue having the positive imaginary part first.
C          BETA is a one-dimensional REAL array, dimensioned BETA(N).
C
C        Z contains the real and imaginary parts of the eigenvectors
C          if MATZ is not zero.  If the J-th eigenvalue is real, the
C          J-th column of  Z  contains its eigenvector.  If the J-th
C          eigenvalue is complex with positive imaginary part, the
C          J-th and (J+1)-th columns of  Z  contain the real and
C          imaginary parts of its eigenvector.  The conjugate of this
C          vector is the eigenvector for the conjugate eigenvalue.
C          Z is a two-dimensional REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30*N iterations.
C                     The eigenvalues should be correct for indices
C                     IERR+1, IERR+2, ..., N, but no eigenvectors are
C                     computed.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  QZHES, QZIT, QZVAL, QZVEC
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RGG
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*)
      LOGICAL TF
C
C***FIRST EXECUTABLE STATEMENT  RGG
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      TF = .FALSE.
      CALL  QZHES(NM,N,A,B,TF,Z)
      CALL  QZIT(NM,N,A,B,0.0E0,TF,Z,IERR)
      CALL  QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 TF = .TRUE.
      CALL  QZHES(NM,N,A,B,TF,Z)
      CALL  QZIT(NM,N,A,B,0.0E0,TF,Z,IERR)
      CALL  QZVAL(NM,N,A,B,ALFR,ALFI,BETA,TF,Z)
      IF (IERR .NE. 0) GO TO 50
      CALL  QZVEC(NM,N,A,B,ALFR,ALFI,BETA,Z)
   50 RETURN
      END
*DECK RJ
      REAL FUNCTION RJ (X, Y, Z, P, IER)
C***BEGIN PROLOGUE  RJ
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      SINGLE 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.     RJ
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation result to
C          RJ(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          RJ( X, Y, Z, P, IER )
C
C          Parameters On Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, nonnegative variable
C
C          Z      - Single precision, nonnegative variable
C
C          P      - Single precision, positive variable
C
C
C          On  Return     (values assigned by the RJ routine)
C
C          RJ     - Single 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 RJ routine
C
C                  Value Assigned        Error Message Printed
C                  IER = 1               MIN(X,Y,Z) .LT. 0.0E0
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 RC.
C
C          UPLIM is not greater than 0.3 times the cube root of
C          the value of UPLIM used in the routine for RC.
C
C
C                     Acceptable Values For:   LOLIM      UPLIM
C                     IBM 360/370 SERIES   :   2.0E-26     3.0E+24
C                     CDC 6000/7000 SERIES :   5.0E-98     3.0E+106
C                     UNIVAC 1100 SERIES   :   5.0E-13     6.0E+11
C                     CRAY                 :   1.32E-822   1.4E+821
C                     VAX 11 SERIES        :   2.5E-13     9.0E+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 RJ
C          is less than 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C
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.0E-3    4.0E-18
C                           3.0E-3    3.0E-15
C                           1.0E-2    4.0E-12
C                           3.0E-2    3.0E-9
C                           1.0E-1    4.0E-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   RJ Special Comments
C
C
C          Check by addition theorem: RJ(X,X+Z,X+W,X+P)
C          + RJ(Y,Y+Z,Y+W,Y+P) + (A-B) * RJ(A,B,B,A) + 3 / SQRT(A)
C          = RJ(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 * RC(A,B).
C
C
C          On Input:
C
C          X, Y, Z, and P are the variables in the integral RJ(X,Y,Z,P).
C
C
C          On Output:
C
C
C          X, Y, Z, and 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 Functions via RJ and RF
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                                      2    2         -1/2
C                                 *(1-K  SIN (THETA) )     D THETA
C
C
C                                         2          2   2
C                       = SIN (PHI) RF(COS (PHI), 1-K SIN (PHI),1)
C
C                                  3            2         2   2
C                        -(N/3) SIN (PHI) RJ(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 RF(1,1+KC X ,1+X ) +
C
C                                            3          2 2    2     2
C                               +(1/3)(1-P) X  RJ(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                                                     2
C                                 +(1/3)(B-PA) RJ(0,KC ,1,P)
C
C
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) RF(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                            *RJ(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
C                  (PI/2) LAMBDA0(A,B) =L(A,B,PI/2) =
C
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                  *RF(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                  *RJ(0,COS (A),1,COS (A) COS (B)/(1-COS (A) SIN (B)))
C
C
C
C                  Jacobi ZETA function
C                  --------------------
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                             *RJ(0,1-K ,1,1-K SIN (B)) / RF (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  R1MACH, RC, 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  RJ
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6, XERN7
      INTEGER IER
      REAL ALFA, BETA, C1, C2, C3, C4, EA, EB, EC, E2, E3
      REAL LOLIM, UPLIM, EPSLON, ERRTOL
      REAL LAMDA, MU, P, PN, PNDEV
      REAL POWER4, RC, SIGMA, S1, S2, S3, X, XN, XNDEV
      REAL 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  RJ
      IF (FIRST) THEN
         ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0)
         LOLIM  = (5.0E0 * R1MACH(1))**(1.0E0/3.0E0)
         UPLIM  = 0.30E0*( R1MACH(2) / 5.0E0)**(1.0E0/3.0E0)
C
         C1 = 3.0E0/14.0E0
         C2 = 1.0E0/3.0E0
         C3 = 3.0E0/22.0E0
         C4 = 3.0E0/26.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RJ = 0.0E0
      IF (MIN(X,Y,Z).LT.0.0E0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         CALL XERMSG ('SLATEC', 'RJ',
     *      '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', 'RJ',
     *      '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.0E0
      POWER4 = 1.0E0
C
   30 MU = (XN+YN+ZN+PN+PN)*0.20E0
      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*RC(ALFA,BETA,IER)
      POWER4 = POWER4*0.250E0
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      ZN = (ZN+LAMDA)*0.250E0
      PN = (PN+LAMDA)*0.250E0
      GO TO 30
C
   40 EA = XNDEV*(YNDEV+ZNDEV) + YNDEV*ZNDEV
      EB = XNDEV*YNDEV*ZNDEV
      EC = PNDEV*PNDEV
      E2 = EA - 3.0E0*EC
      E3 = EB + 2.0E0*PNDEV*(EA-EC)
      S1 = 1.0E0 + E2*(-C1+0.750E0*C3*E2-1.50E0*C4*E3)
      S2 = EB*(0.50E0*C2+PNDEV*(-C3-C3+PNDEV*C4))
      S3 = PNDEV*EA*(C2-PNDEV*C3) - C2*PNDEV*EC
      RJ = 3.0E0*SIGMA + POWER4*(S1+S2+S3)/(MU* SQRT(MU))
      RETURN
      END
*DECK RKFAB
      SUBROUTINE RKFAB (NCOMP, XPTS, NXPTS, NFC, IFLAG, Z, MXNON, P,
     +   NTP, IP, YHP, NIV, U, V, W, S, STOWA, G, WORK, IWORK, NFCC)
C***BEGIN PROLOGUE  RKFAB
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (RKFAB-S, DRKFAB-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C
C     Subroutine RKFAB 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  BVSUP
C***ROUTINES CALLED  BVDER, DEABM, DERKF, REORT, STOR1
C***COMMON BLOCKS    ML15TO, ML17BW, ML18JR, ML8SZ
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
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  RKFAB
C
      DIMENSION P(NTP,*),IP(NFCC,*),U(NCOMP,NFC,*),
     1          V(NCOMP,*),W(NFCC,*),Z(*),YHP(NCOMP,*),
     2          XPTS(*),S(*),STOWA(*),WORK(*),IWORK(*),
     3          G(*)
C
C **********************************************************************
C
      COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD
      COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
     1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
      COMMON /ML18JR/ AE,RE,TOL,NXPTSD,NIC,NOPG,MXNOND,NDISK,NTAPE,NEQ,
     1                INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD,
     2                ICOCO
      COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9,
     1                K10,K11,L1,L2,KKKINT,LLLINT
C
      EXTERNAL BVDER
C
C **********************************************************************
C  INITIALIZATION OF COUNTERS AND VARIABLES.
C
C***FIRST EXECUTABLE STATEMENT  RKFAB
      KOD = 1
      NON = 1
      X = XBEG
      JON = 1
      INFO(1) = 0
      INFO(2) = 0
      INFO(3) = 1
      INFO(4) = 1
      WORK(1) = XEND
      IF (NOPG .EQ. 0)  GO TO 1
      INFO(3) = 0
      IF (X .EQ. Z(1))  JON = 2
    1 NFCP1 = NFC + 1
C
C **********************************************************************
C *****BEGINNING OF INTEGRATION LOOP AT OUTPUT POINTS.******************
C **********************************************************************
C
      DO 110 KOPP = 2,NXPTS
      KOP=KOPP
C
    5 XOP = XPTS(KOP)
      IF (NDISK .EQ. 0)  KOD = KOP
C
C     STEP BY STEP INTEGRATION LOOP BETWEEN OUTPUT POINTS.
C
   10 XXOP = XOP
      IF (NOPG .EQ. 0)   GO TO 15
      IF (XEND.GT.XBEG.AND.XOP.GT.Z(JON)) XXOP=Z(JON)
      IF (XEND.LT.XBEG.AND.XOP.LT.Z(JON)) XXOP=Z(JON)
C
C **********************************************************************
   15 GO TO (20,25),INTEG
C     DERKF INTEGRATOR
C
   20 CALL DERKF(BVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,IDID,WORK,KKKINT,
     1           IWORK,LLLINT,G,IPAR)
      GO TO 28
C     DEABM INTEGRATOR
C
   25 CALL DEABM(BVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,IDID,WORK,KKKINT,
     1           IWORK,LLLINT,G,IPAR)
   28 IF(IDID .GE. 1) GO TO 30
      INFO(1) = 1
      IF(IDID .EQ. -1) GO TO 15
      IFLAG = 20 - IDID
      RETURN
C
C **********************************************************************
C     GRAM-SCHMIDT ORTHOGONALIZATION TEST FOR ORTHONORMALIZATION
C     (TEMPORARILY USING U AND V IN THE TEST)
C
   30 IF (NOPG .EQ. 0)  GO TO 35
      IF (XXOP .NE. Z(JON))  GO TO 100
      JFLAG=2
      GO TO 40
   35 JFLAG=1
      IF (INHOMO .EQ. 3  .AND.  X .EQ. XEND) JFLAG=3
C
   40 IF (NDISK .EQ. 0) NON=NUMORT+1
      CALL REORT(NCOMP,U(1,1,KOD),V(1,KOD),YHP,NIV,
     1           W(1,NON),S,P(1,NON),IP(1,NON),STOWA,JFLAG)
C
      IF (JFLAG .NE. 30) GO TO 45
      IFLAG=30
      RETURN
C
   45 IF (JFLAG .EQ. 10) GO TO 5
C
      IF (JFLAG .NE. 0)  GO TO 100
C
C **********************************************************************
C     STORE ORTHONORMALIZED VECTORS INTO SOLUTION VECTORS.
C
      IF (NUMORT .LT. MXNON)  GO TO 65
      IF (X .EQ. XEND) GO TO 65
      IFLAG = 13
      RETURN
C
   65 NUMORT = NUMORT + 1
      CALL STOR1(YHP,U(1,1,KOD),YHP(1,NFCP1),V(1,KOD),1,
     1           NDISK,NTAPE)
C
C **********************************************************************
C     STORE ORTHONORMALIZATION INFORMATION, INITIALIZE
C     INTEGRATION FLAG, AND CONTINUE INTEGRATION TO THE NEXT
C     ORTHONORMALIZATION POINT OR OUTPUT POINT.
C
      Z(NUMORT) = X
      IF (INHOMO .EQ. 1  .AND.  NPS .EQ. 0)  C = S(NFCP1) * C
      IF (NDISK .EQ. 0)  GO TO 90
      IF (INHOMO .EQ. 1)  WRITE (NTAPE) (W(J,1), J = 1,NFCC)
      WRITE(NTAPE) (IP(J,1), J = 1,NFCC),(P(J,1), J = 1,NTP)
   90 INFO(1) = 0
      JON = JON + 1
      IF (NOPG .EQ. 1  .AND.  X .NE. XOP)  GO TO 10
C
C **********************************************************************
C     CONTINUE INTEGRATION IF WE ARE NOT AT AN OUTPUT POINT.
C
  100 IF (IDID .EQ. 1)  GO TO 15
C
C     STORAGE OF HOMOGENEOUS SOLUTIONS IN U AND THE PARTICULAR
C     SOLUTION IN V AT THE OUTPUT POINTS.
C
      CALL STOR1(U(1,1,KOD),YHP,V(1,KOD),YHP(1,NFCP1),0,NDISK,NTAPE)
  110 CONTINUE
C **********************************************************************
C **********************************************************************
C
      IFLAG = 0
      RETURN
      END
*DECK RPQR79
      SUBROUTINE RPQR79 (NDEG, COEFF, ROOT, IERR, WORK)
C***BEGIN PROLOGUE  RPQR79
C***PURPOSE  Find the zeros of a polynomial with real coefficients.
C***LIBRARY   SLATEC
C***CATEGORY  F1A1A
C***TYPE      SINGLE PRECISION (RPQR79-S, CPQR79-C)
C***KEYWORDS  COMPLEX POLYNOMIAL, POLYNOMIAL ROOTS, POLYNOMIAL ZEROS
C***AUTHOR  Vandevender, W. H., (SNLA)
C***DESCRIPTION
C
C   Abstract
C       This routine computes all zeros of a polynomial of degree NDEG
C       with real coefficients by computing the eigenvalues of the
C       companion matrix.
C
C   Description of Parameters
C       The user must dimension all arrays appearing in the call list
C            COEFF(NDEG+1), ROOT(NDEG), WORK(NDEG*(NDEG+2))
C
C    --Input--
C      NDEG    degree of polynomial
C
C      COEFF   REAL coefficients in descending order.  i.e.,
C              P(Z)= COEFF(1)*(Z**NDEG) + COEFF(NDEG)*Z + COEFF(NDEG+1)
C
C      WORK    REAL work array of dimension at least NDEG*(NDEG+2)
C
C   --Output--
C      ROOT    COMPLEX vector of roots
C
C      IERR    Output Error Code
C           - Normal Code
C          0  means the roots were computed.
C           - Abnormal Codes
C          1  more than 30 QR iterations on some eigenvalue of the
C             companion matrix
C          2  COEFF(1)=0.0
C          3  NDEG is invalid (less than or equal to 0)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  HQR, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800601  DATE WRITTEN
C   890505  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   911010  Code reworked and simplified.  (RWC and WRB)
C***END PROLOGUE  RPQR79
      REAL COEFF(*), WORK(*), SCALE
      COMPLEX ROOT(*)
      INTEGER NDEG, IERR, K, KH, KWR, KWI, KCOL
C***FIRST EXECUTABLE STATEMENT  RPQR79
      IERR = 0
      IF (ABS(COEFF(1)) .EQ. 0.0) THEN
         IERR = 2
         CALL XERMSG ('SLATEC', 'RPQR79',
     +      'LEADING COEFFICIENT IS ZERO.', 2, 1)
         RETURN
      ENDIF
C
      IF (NDEG .LE. 0) THEN
         IERR = 3
         CALL XERMSG ('SLATEC', 'RPQR79', 'DEGREE INVALID.', 3, 1)
         RETURN
      ENDIF
C
      IF (NDEG .EQ. 1) THEN
         ROOT(1) = CMPLX(-COEFF(2)/COEFF(1),0.0)
         RETURN
      ENDIF
C
      SCALE = 1.0E0/COEFF(1)
      KH = 1
      KWR = KH+NDEG*NDEG
      KWI = KWR+NDEG
      KWEND = KWI+NDEG-1
C
      DO 10 K=1,KWEND
         WORK(K) = 0.0E0
   10 CONTINUE
C
      DO 20 K=1,NDEG
         KCOL = (K-1)*NDEG+1
         WORK(KCOL) = -COEFF(K+1)*SCALE
         IF (K .NE. NDEG) WORK(KCOL+K) = 1.0E0
   20 CONTINUE
C
      CALL HQR (NDEG,NDEG,1,NDEG,WORK(KH),WORK(KWR),WORK(KWI),IERR)
C
      IF (IERR .NE. 0) THEN
         IERR = 1
         CALL XERMSG ('SLATEC', 'CPQR79',
     +      'NO CONVERGENCE IN 30 QR ITERATIONS.', 1, 1)
         RETURN
      ENDIF
C
      DO 30 K=1,NDEG
         KM1 = K-1
         ROOT(K) = CMPLX(WORK(KWR+KM1),WORK(KWI+KM1))
   30 CONTINUE
      RETURN
      END
*DECK RPZERO
      SUBROUTINE RPZERO (N, A, R, T, IFLG, S)
C***BEGIN PROLOGUE  RPZERO
C***PURPOSE  Find the zeros of a polynomial with real coefficients.
C***LIBRARY   SLATEC
C***CATEGORY  F1A1A
C***TYPE      SINGLE PRECISION (RPZERO-S, CPZERO-C)
C***KEYWORDS  POLYNOMIAL ROOTS, POLYNOMIAL ZEROS, REAL ROOTS
C***AUTHOR  Kahaner, D. K., (NBS)
C***DESCRIPTION
C
C      Find the zeros of the real polynomial
C         P(X)= A(1)*X**N + A(2)*X**(N-1) +...+ A(N+1)
C
C    Input...
C       N = degree of P(X)
C       A = real vector containing coefficients of P(X),
C            A(I) = coefficient of X**(N+1-I)
C       R = N word complex vector containing initial estimates for zeros
C            if these are known.
C       T = 6(N+1) word array used for temporary storage
C       IFLG = flag to indicate if initial estimates of
C              zeros are input.
C            If IFLG .EQ. 0, no estimates are input.
C            If IFLG .NE. 0, the vector R contains estimates of
C               the zeros
C       ** Warning ****** If estimates are input, they must
C                         be separated; that is, distinct or
C                         not repeated.
C       S = an N word array
C
C    Output...
C       R(I) = ith zero,
C       S(I) = bound for R(I) .
C       IFLG = error diagnostic
C    Error Diagnostics...
C       If IFLG .EQ. 0 on return, all is well.
C       If IFLG .EQ. 1 on return, A(1)=0.0 or N=0 on input.
C       If IFLG .EQ. 2 on return, the program failed to converge
C                after 25*N iterations.  Best current estimates of the
C                zeros are in R(I).  Error bounds are not calculated.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CPZERO
C***REVISION HISTORY  (YYMMDD)
C   810223  DATE WRITTEN
C   890206  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  RPZERO
C
      COMPLEX R(*), T(*)
      REAL A(*), S(*)
C***FIRST EXECUTABLE STATEMENT  RPZERO
      N1=N+1
      DO 1 I=1,N1
      T(I)= CMPLX(A(I),0.0)
    1 CONTINUE
      CALL CPZERO(N,T,R,T(N+2),IFLG,S)
      RETURN
      END
*DECK RS
      SUBROUTINE RS (NM, N, A, W, MATZ, Z, FV1, FV2, IERR)
C***BEGIN PROLOGUE  RS
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a real symmetric matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A1
C***TYPE      SINGLE PRECISION (RS-S, CH-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     of a REAL SYMMETRIC matrix.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        A contains the real symmetric matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        A is unaltered.
C
C        W contains the eigenvalues in ascending order.  W is a one-
C          dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  The
C          eigenvectors are orthonormal.  Z is a two-dimensional
C          REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues, and eigenvectors if requested,
C                     should be correct for indices 1, 2, ..., IERR-1.
C
C        FV1 and FV2 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned FV1(N) and FV2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  TQL2, TQLRAT, TRED1, TRED2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RS
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,*),W(*),Z(NM,*),FV1(*),FV2(*)
C
C***FIRST EXECUTABLE STATEMENT  RS
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  TRED1(NM,N,A,W,FV1,FV2)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  TRED2(NM,N,A,W,FV1,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
   50 RETURN
      END
*DECK RSB
      SUBROUTINE RSB (NM, N, MB, A, W, MATZ, Z, FV1, FV2, IERR)
C***BEGIN PROLOGUE  RSB
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a symmetric band matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A6
C***TYPE      SINGLE PRECISION (RSB-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     of a REAL SYMMETRIC BAND matrix.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        MB is the half band width of the matrix, defined as the
C          number of adjacent diagonals, including the principal
C          diagonal, required to specify the non-zero portion of the
C          lower triangle of the matrix.  MB must be less than or
C          equal to N.  MB is an INTEGER variable.
C
C        A contains the lower triangle of the real symmetric band
C          matrix.  Its lowest subdiagonal is stored in the last
C          N+1-MB  positions of the first column, its next subdiagonal
C          in the last  N+2-MB  positions of the second column, further
C          subdiagonals similarly, and finally its principal diagonal
C          in the  N  positions of the last column.  Contents of storage
C          locations not part of the matrix are arbitrary.  A is a
C          two-dimensional REAL array, dimensioned A(NM,MB).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        A has been destroyed.
C
C        W contains the eigenvalues in ascending order.  W is a one-
C          dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  The
C          eigenvectors are orthonormal.  Z is a two-dimensional
C          REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          12*N       if MB is either non-positive or greater than N,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues and eigenvectors, if requested,
C                     should be correct for indices 1, 2, ..., IERR-1.
C
C        FV1 and FV2 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned FV1(N) and FV2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  BANDR, TQL2, TQLRAT
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RSB
C
      INTEGER N,MB,NM,IERR,MATZ
      REAL A(NM,*),W(*),Z(NM,*),FV1(*),FV2(*)
      LOGICAL TF
C
C***FIRST EXECUTABLE STATEMENT  RSB
      IF (N .LE. NM) GO TO 5
      IERR = 10 * N
      GO TO 50
    5 IF (MB .GT. 0) GO TO 10
      IERR = 12 * N
      GO TO 50
   10 IF (MB .LE. N) GO TO 15
      IERR = 12 * N
      GO TO 50
C
   15 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      TF = .FALSE.
      CALL  BANDR(NM,N,MB,A,W,FV1,FV2,TF,Z)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 TF = .TRUE.
      CALL  BANDR(NM,N,MB,A,W,FV1,FV1,TF,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
   50 RETURN
      END
*DECK RSCO
      SUBROUTINE RSCO (RSAV, ISAV)
C***BEGIN PROLOGUE  RSCO
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DEBDF
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (RSCO-S, DRSCO-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   RSCO transfers data from arrays to a common block within the
C   integrator package DEBDF.
C
C***SEE ALSO  DEBDF
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    DEBDF1
C***REVISION HISTORY  (YYMMDD)
C   800901  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  RSCO
C
C
C-----------------------------------------------------------------------
C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON
C BLOCK DEBDF1  , WHICH IS USED INTERNALLY IN THE DEBDF
C PACKAGE.  THIS PRESUMES THAT RSAV AND ISAV WERE LOADED BY MEANS
C OF SUBROUTINE SVCO OR THE EQUIVALENT.
C-----------------------------------------------------------------------
      INTEGER ISAV, I,      ILS, LENILS, LENRLS
      REAL RSAV, RLS
      DIMENSION RSAV(*), ISAV(*)
      COMMON /DEBDF1/ RLS(218), ILS(33)
      SAVE LENRLS, LENILS
      DATA LENRLS/218/, LENILS/33/
C
C***FIRST EXECUTABLE STATEMENT  RSCO
      DO 10 I = 1,LENRLS
 10     RLS(I) = RSAV(I)
      DO 20 I = 1,LENILS
 20     ILS(I) = ISAV(I)
      RETURN
C----------------------- END OF SUBROUTINE RSCO -----------------------
      END
*DECK RSG
      SUBROUTINE RSG (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR)
C***BEGIN PROLOGUE  RSG
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a symmetric generalized eigenproblem.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4B1
C***TYPE      SINGLE PRECISION (RSG-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     To find the eigenvalues and eigenvectors (if desired)
C     for the REAL SYMMETRIC generalized eigenproblem  Ax = (LAMBDA)Bx.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real symmetric matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        B contains a positive definite real symmetric matrix.  B is a
C          two-dimensional REAL array, dimensioned B(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        W contains the eigenvalues in ascending order.  W is a
C          one-dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  Z is a
C          two-dimensional REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          7*N+1      if B is not positive definite,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues should be correct for indices
C                     1, 2, ..., IERR-1, but no eigenvectors are
C                     computed.
C
C        FV1 and FV2 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned FV1(N) and FV2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  REBAK, REDUC, TQL2, TQLRAT, TRED1, TRED2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RSG
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*)
C
C***FIRST EXECUTABLE STATEMENT  RSG
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 CALL  REDUC(NM,N,A,B,FV2,IERR)
      IF (IERR .NE. 0) GO TO 50
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  TRED1(NM,N,A,W,FV1,FV2)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  TRED2(NM,N,A,W,FV1,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  REBAK(NM,N,B,FV2,N,Z)
   50 RETURN
      END
*DECK RSGAB
      SUBROUTINE RSGAB (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR)
C***BEGIN PROLOGUE  RSGAB
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a symmetric generalized eigenproblem.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4B1
C***TYPE      SINGLE PRECISION (RSGAB-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     for the REAL SYMMETRIC generalized eigenproblem  ABx = (LAMBDA)x.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real symmetric matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        B contains a positive definite real symmetric matrix.  B is a
C          two-dimensional REAL array, dimensioned B(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        W contains the eigenvalues in ascending order.  W is a
C          one-dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  Z is a
C          two-dimensional REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          7*N+1      if B is not positive definite,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues should be correct for indices
C                     1, 2, ..., IERR-1, but no eigenvectors are
C                     computed.
C
C        FV1 and FV2 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned FV1(N) and FV2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  REBAK, REDUC2, TQL2, TQLRAT, TRED1, TRED2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RSGAB
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*)
C
C***FIRST EXECUTABLE STATEMENT  RSGAB
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 CALL  REDUC2(NM,N,A,B,FV2,IERR)
      IF (IERR .NE. 0) GO TO 50
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  TRED1(NM,N,A,W,FV1,FV2)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  TRED2(NM,N,A,W,FV1,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  REBAK(NM,N,B,FV2,N,Z)
   50 RETURN
      END
*DECK RSGBA
      SUBROUTINE RSGBA (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR)
C***BEGIN PROLOGUE  RSGBA
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a symmetric generalized eigenproblem.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4B1
C***TYPE      SINGLE PRECISION (RSGBA-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     for the REAL SYMMETRIC generalized eigenproblem  BAx = (LAMBDA)x.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real symmetric matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        B contains a positive definite real symmetric matrix.  B is a
C          two-dimensional REAL array, dimensioned B(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        W contains the eigenvalues in ascending order.  W is a
C          one-dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  Z is a
C          two-dimensional REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          7*N+1      if B is not positive definite,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues should be correct for indices
C                     1, 2, ..., IERR-1, but no eigenvectors are
C                     computed.
C
C        FV1 and FV2 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned FV1(N) and FV2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  REBAKB, REDUC2, TQL2, TQLRAT, TRED1, TRED2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RSGBA
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*)
C
C***FIRST EXECUTABLE STATEMENT  RSGBA
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 CALL  REDUC2(NM,N,A,B,FV2,IERR)
      IF (IERR .NE. 0) GO TO 50
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  TRED1(NM,N,A,W,FV1,FV2)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  TRED2(NM,N,A,W,FV1,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  REBAKB(NM,N,B,FV2,N,Z)
   50 RETURN
      END
*DECK RSP
      SUBROUTINE RSP (NM, N, NV, A, W, MATZ, Z, FV1, FV2, IERR)
C***BEGIN PROLOGUE  RSP
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a real symmetric matrix packed into a one dimensional
C            array.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A1
C***TYPE      SINGLE PRECISION (RSP-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     of a REAL SYMMETRIC PACKED matrix.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, Z, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        NV is an INTEGER variable set equal to the dimension of the
C          array A as specified in the calling program.  NV must not
C          be less than  N*(N+1)/2.
C
C        A contains the lower triangle, stored row-wise, of the real
C          symmetric packed matrix.  A is a one-dimensional REAL
C          array, dimensioned A(NV).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        A has been destroyed.
C
C        W contains the eigenvalues in ascending order.  W is a
C          one-dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  The eigen-
C          vectors are orthonormal.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          20*N       if NV is less than N*(N+1)/2,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues and eigenvectors in the W and Z
C                     arrays should be correct for indices
C                     1, 2, ..., IERR-1.
C
C        FV1 and FV2 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned FV1(N) and FV2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  TQL2, TQLRAT, TRBAK3, TRED3
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RSP
C
      INTEGER I,J,N,NM,NV,IERR,MATZ
      REAL A(*),W(*),Z(NM,*),FV1(*),FV2(*)
C
C***FIRST EXECUTABLE STATEMENT  RSP
      IF (N .LE. NM) GO TO 5
      IERR = 10 * N
      GO TO 50
    5 IF (NV .GE. (N * (N + 1)) / 2) GO TO 10
      IERR = 20 * N
      GO TO 50
C
   10 CALL  TRED3(N,NV,A,W,FV1,FV2)
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 DO 40 I = 1, N
C
         DO 30 J = 1, N
            Z(J,I) = 0.0E0
   30    CONTINUE
C
         Z(I,I) = 1.0E0
   40 CONTINUE
C
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  TRBAK3(NM,N,NV,A,N,Z)
   50 RETURN
      END
*DECK RST
      SUBROUTINE RST (NM, N, W, E, MATZ, Z, IERR)
C***BEGIN PROLOGUE  RST
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a real symmetric tridiagonal matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5
C***TYPE      SINGLE PRECISION (RST-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     of a REAL SYMMETRIC TRIDIAGONAL matrix.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, Z, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        W contains the diagonal elements of the real symmetric
C          tridiagonal matrix.  W is a one-dimensional REAL array,
C          dimensioned W(N).
C
C        E contains the subdiagonal elements of the matrix in its last
C          N-1 positions.  E(1) is arbitrary.  E is a one-dimensional
C          REAL array, dimensioned E(N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        W contains the eigenvalues in ascending order.
C
C        Z contains the eigenvectors if MATZ is not zero.  The eigen-
C          vectors are orthonormal.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues and eigenvectors in the W and Z
C                     arrays should be correct for indices
C                     1, 2, ..., IERR-1.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  IMTQL1, IMTQL2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RST
C
      INTEGER I,J,N,NM,IERR,MATZ
      REAL W(*),E(*),Z(NM,*)
C
C***FIRST EXECUTABLE STATEMENT  RST
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  IMTQL1(N,W,E,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 DO 40 I = 1, N
C
         DO 30 J = 1, N
            Z(J,I) = 0.0E0
   30    CONTINUE
C
         Z(I,I) = 1.0E0
   40 CONTINUE
C
      CALL  IMTQL2(NM,N,W,E,Z,IERR)
   50 RETURN
      END
*DECK RT
      SUBROUTINE RT (NM, N, A, W, MATZ, Z, FV1, IERR)
C***BEGIN PROLOGUE  RT
C***PURPOSE  Compute the eigenvalues and eigenvectors of a special real
C            tridiagonal matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5
C***TYPE      SINGLE PRECISION (RT-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of subroutines
C     from the eigensystem subroutine package (EISPACK) to find the
C     eigenvalues and eigenvectors (if desired) of a special REAL
C     TRIDIAGONAL matrix.  The property of the matrix required for use
C     of this subroutine is that the products of pairs of corresponding
C     off-diagonal elements be all non-negative.  If eigenvectors are
C     desired, no product can be zero unless both factors are zero.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        A contains the special real tridiagonal matrix in its first
C          three columns.  The subdiagonal elements are stored in the
C          last N-1 positions of the first column, the diagonal elements
C          in the second column, and the superdiagonal elements in the
C          first N-1 positions of the third column.  Elements A(1,1) and
C          A(N,3) are arbitrary.  A is a two-dimensional REAL array,
C          dimensioned A(NM,3).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        W contains the eigenvalues in ascending order.  W is a
C          one-dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  The eigen-
C          vectors are not normalized.  Z is a two-dimensional REAL
C          array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          N+J        if A(J,1)*A(J-1,3) is negative,
C          2*N+J      if the product is zero with one factor non-zero,
C                     and MATZ is non-zero;
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues and eigenvectors in the W and Z
C                     arrays should be correct for indices
C                     1, 2, ..., IERR-1.
C
C        FV1 is a one-dimensional REAL array used for temporary storage,
C          dimensioned FV1(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  FIGI, FIGI2, IMTQL1, IMTQL2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RT
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,3),W(*),Z(NM,*),FV1(*)
C
C***FIRST EXECUTABLE STATEMENT  RT
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  FIGI(NM,N,A,W,FV1,FV1,IERR)
      IF (IERR .GT. 0) GO TO 50
      CALL  IMTQL1(N,W,FV1,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  FIGI2(NM,N,A,W,FV1,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  IMTQL2(NM,N,W,FV1,Z,IERR)
   50 RETURN
      END
#ifdef GAG_USE_UNDERSCORE
C Symbol RAND (and RGAUSS and RUNIF using it) conflicts with the C
C standard symbol 'rand' when compiling with the -assume nounderscore
C option (used at PdBI).
*DECK RUNIF
      FUNCTION RUNIF (T, N)
C***BEGIN PROLOGUE  RUNIF
C***PURPOSE  Generate a uniformly distributed random number.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  L6A21
C***TYPE      SINGLE PRECISION (RUNIF-S)
C***KEYWORDS  FNLIB, RANDOM NUMBER, SPECIAL FUNCTIONS, UNIFORM
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C This random number generator is portable among a wide variety of
C computers.  It generates a random number between 0.0 and 1.0 accord-
C ing to the algorithm presented by Bays and Durham (TOMS, 2, 59,
C 1976).  The motivation for using this scheme, which resembles the
C Maclaren-Marsaglia method, is to greatly increase the period of the
C random sequence.  If the period of the basic generator (RAND) is P,
C then the expected mean period of the sequence generated by RUNIF is
C given by   new mean P = SQRT (PI*FACTORIAL(N)/(8*P)),
C where FACTORIAL(N) must be much greater than P in this asymptotic
C formula.  Generally, N should be around 32 if P=4.E6 as for RAND.
C
C             Input Argument --
C N      ABS(N) is the number of random numbers in an auxiliary table.
C        Note though that ABS(N)+1 is the number of items in array T.
C        If N is positive and differs from its value in the previous
C        invocation, then the table is initialized for the new value of
C        N.  If N is negative, ABS(N) is the number of items in an
C        auxiliary table, but the tables are now assumed already to
C        be initialized.  This option enables the user to save the
C        table T at the end of a long computer run and to restart with
C        the same sequence.  Normally, RUNIF would be called at most
C        once with negative N.  Subsequent invocations would have N
C        positive and of the correct magnitude.
C
C             Input and Output Argument  --
C T      an array of ABS(N)+1 random numbers from a previous invocation
C        of RUNIF.  Whenever N is positive and differs from the old
C        N, the table is initialized.  The first ABS(N) numbers are the
C        table discussed in the reference, and the N+1 -st value is Y.
C        This array may be saved in order to restart a sequence.
C
C             Output Value --
C RUNIF  a random number between 0.0 and 1.0.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RAND
C***REVISION HISTORY  (YYMMDD)
C   770401  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   910819  Added EXTERNAL statement for RAND due to problem on IBM
C           RS 6000.  (WRB)
C***END PROLOGUE  RUNIF
      DIMENSION T(*)
      EXTERNAL RAND
      SAVE NOLD, FLOATN
      DATA NOLD /-1/
C***FIRST EXECUTABLE STATEMENT  RUNIF
      IF (N.EQ.NOLD) GO TO 20
C
      NOLD = ABS(N)
      FLOATN = NOLD
      IF (N.LT.0) DUMMY = RAND (T(NOLD+1))
      IF (N.LT.0) GO TO 20
C
      DO 10 I=1,NOLD
        T(I) = RAND (0.)
 10   CONTINUE
      T(NOLD+1) = RAND (0.)
C
 20   J = T(NOLD+1)*FLOATN + 1.
      T(NOLD+1) = T(J)
      RUNIF = T(J)
      T(J) = RAND (0.)
C
      RETURN
      END
#endif
*DECK RWUPDT
      SUBROUTINE RWUPDT (N, R, LDR, W, B, ALPHA, COS, SIN)
C***BEGIN PROLOGUE  RWUPDT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SNLS1 and SNLS1E
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (RWUPDT-S, DWUPDT-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an N by N upper triangular matrix R, this subroutine
C     computes the QR decomposition of the matrix formed when a row
C     is added to R. If the row is specified by the vector W, then
C     RWUPDT determines an orthogonal matrix Q such that when the
C     N+1 by N matrix composed of R augmented by W is premultiplied
C     by (Q TRANSPOSE), the resulting matrix is upper trapezoidal.
C     The orthogonal matrix Q is the product of N transformations
C
C           G(1)*G(2)* ... *G(N)
C
C     where G(I) is a Givens rotation in the (I,N+1) plane which
C     eliminates elements in the I-th plane. RWUPDT also
C     computes the product (Q TRANSPOSE)*C where C is the
C     (N+1)-vector (b,alpha). Q itself is not accumulated, rather
C     the information to recover the G rotations is supplied.
C
C     The subroutine statement is
C
C       SUBROUTINE RWUPDT(N,R,LDR,W,B,ALPHA,COS,SIN)
C
C     where
C
C       N is a positive integer input variable set to the order of R.
C
C       R is an N by N array. On input the upper triangular part of
C         R must contain the matrix to be updated. On output R
C         contains the updated triangular matrix.
C
C       LDR is a positive integer input variable not less than N
C         which specifies the leading dimension of the array R.
C
C       W is an input array of length N which must contain the row
C         vector to be added to R.
C
C       B is an array of length N. On input B must contain the
C         first N elements of the vector C. On output B contains
C         the first N elements of the vector (Q TRANSPOSE)*C.
C
C       ALPHA is a variable. On input ALPHA must contain the
C         (N+1)-st element of the vector C. On output ALPHA contains
C         the (N+1)-st element of the vector (Q TRANSPOSE)*C.
C
C       COS is an output array of length N which contains the
C         cosines of the transforming Givens rotations.
C
C       SIN is an output array of length N which contains the
C         sines of the transforming Givens rotations.
C
C***SEE ALSO  SNLS1, SNLS1E
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  RWUPDT
      INTEGER N,LDR
      REAL ALPHA
      REAL R(LDR,*),W(*),B(*),COS(*),SIN(*)
      INTEGER I,J,JM1
      REAL COTAN,ONE,P5,P25,ROWJ,TAN,TEMP,ZERO
      SAVE ONE, P5, P25, ZERO
      DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/
C***FIRST EXECUTABLE STATEMENT  RWUPDT
      DO 60 J = 1, N
         ROWJ = W(J)
         JM1 = J - 1
C
C        APPLY THE PREVIOUS TRANSFORMATIONS TO
C        R(I,J), I=1,2,...,J-1, AND TO W(J).
C
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            TEMP = COS(I)*R(I,J) + SIN(I)*ROWJ
            ROWJ = -SIN(I)*R(I,J) + COS(I)*ROWJ
            R(I,J) = TEMP
   10       CONTINUE
   20    CONTINUE
C
C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES W(J).
C
         COS(J) = ONE
         SIN(J) = ZERO
         IF (ROWJ .EQ. ZERO) GO TO 50
         IF (ABS(R(J,J)) .GE. ABS(ROWJ)) GO TO 30
            COTAN = R(J,J)/ROWJ
            SIN(J) = P5/SQRT(P25+P25*COTAN**2)
            COS(J) = SIN(J)*COTAN
            GO TO 40
   30    CONTINUE
            TAN = ROWJ/R(J,J)
            COS(J) = P5/SQRT(P25+P25*TAN**2)
            SIN(J) = COS(J)*TAN
   40    CONTINUE
C
C        APPLY THE CURRENT TRANSFORMATION TO R(J,J), B(J), AND ALPHA.
C
         R(J,J) = COS(J)*R(J,J) + SIN(J)*ROWJ
         TEMP = COS(J)*B(J) + SIN(J)*ALPHA
         ALPHA = -SIN(J)*B(J) + COS(J)*ALPHA
         B(J) = TEMP
   50    CONTINUE
   60    CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE RWUPDT.
C
      END
