*DECK E1
      FUNCTION E1 (X)
C***BEGIN PROLOGUE  E1
C***PURPOSE  Compute the exponential integral E1(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      SINGLE PRECISION (E1-S, DE1-D)
C***KEYWORDS  E1 FUNCTION, EXPONENTIAL INTEGRAL, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C E1 calculates the single precision exponential integral, E1(X), for
C positive single precision argument X and the Cauchy principal value
C for negative X.  If principal values are used everywhere, then, for
C all X,
C
C    E1(X) = -Ei(-X)
C or
C    Ei(X) = -E1(-X).
C
C
C Series for AE11       on the interval -1.00000D-01 to  0.
C                                        with weighted error   1.76E-17
C                                         log weighted error  16.75
C                               significant figures required  15.70
C                                    decimal places required  17.55
C
C
C Series for AE12       on the interval -2.50000D-01 to -1.00000D-01
C                                        with weighted error   5.83E-17
C                                         log weighted error  16.23
C                               significant figures required  15.76
C                                    decimal places required  16.93
C
C
C Series for E11        on the interval -4.00000D+00 to -1.00000D+00
C                                        with weighted error   1.08E-18
C                                         log weighted error  17.97
C                               significant figures required  19.02
C                                    decimal places required  18.61
C
C
C Series for E12        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   3.15E-18
C                                         log weighted error  17.50
C                        approx significant figures required  15.8
C                                    decimal places required  18.10
C
C
C Series for AE13       on the interval  2.50000D-01 to  1.00000D+00
C                                        with weighted error   2.34E-17
C                                         log weighted error  16.63
C                               significant figures required  16.14
C                                    decimal places required  17.33
C
C
C Series for AE14       on the interval  0.          to  2.50000D-01
C                                        with weighted error   5.41E-17
C                                         log weighted error  16.27
C                               significant figures required  15.38
C                                    decimal places required  16.97
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891115  Modified prologue description.  (WRB)
C   891115  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   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  E1
      DIMENSION AE11CS(39), AE12CS(25), E11CS(19), E12CS(16),
     1  AE13CS(25), AE14CS(26)
      LOGICAL FIRST
      SAVE AE11CS, AE12CS, E11CS, E12CS, AE13CS, AE14CS,
     1 NTAE11, NTAE12, NTE11, NTE12, NTAE13, NTAE14, XMAX, FIRST
      DATA AE11CS( 1) /    .1215032397 1606579E0 /
      DATA AE11CS( 2) /   -.0650887785 13550150E0 /
      DATA AE11CS( 3) /    .0048976513 57459670E0 /
      DATA AE11CS( 4) /   -.0006492378 43027216E0 /
      DATA AE11CS( 5) /    .0000938404 34587471E0 /
      DATA AE11CS( 6) /    .0000004202 36380882E0 /
      DATA AE11CS( 7) /   -.0000081133 74735904E0 /
      DATA AE11CS( 8) /    .0000028042 47688663E0 /
      DATA AE11CS( 9) /    .0000000564 87164441E0 /
      DATA AE11CS(10) /   -.0000003448 09174450E0 /
      DATA AE11CS(11) /    .0000000582 09273578E0 /
      DATA AE11CS(12) /    .0000000387 11426349E0 /
      DATA AE11CS(13) /   -.0000000124 53235014E0 /
      DATA AE11CS(14) /   -.0000000051 18504888E0 /
      DATA AE11CS(15) /    .0000000021 48771527E0 /
      DATA AE11CS(16) /    .0000000008 68459898E0 /
      DATA AE11CS(17) /   -.0000000003 43650105E0 /
      DATA AE11CS(18) /   -.0000000001 79796603E0 /
      DATA AE11CS(19) /    .0000000000 47442060E0 /
      DATA AE11CS(20) /    .0000000000 40423282E0 /
      DATA AE11CS(21) /   -.0000000000 03543928E0 /
      DATA AE11CS(22) /   -.0000000000 08853444E0 /
      DATA AE11CS(23) /   -.0000000000 00960151E0 /
      DATA AE11CS(24) /    .0000000000 01692921E0 /
      DATA AE11CS(25) /    .0000000000 00607990E0 /
      DATA AE11CS(26) /   -.0000000000 00224338E0 /
      DATA AE11CS(27) /   -.0000000000 00200327E0 /
      DATA AE11CS(28) /   -.0000000000 00006246E0 /
      DATA AE11CS(29) /    .0000000000 00045571E0 /
      DATA AE11CS(30) /    .0000000000 00016383E0 /
      DATA AE11CS(31) /   -.0000000000 00005561E0 /
      DATA AE11CS(32) /   -.0000000000 00006074E0 /
      DATA AE11CS(33) /   -.0000000000 00000862E0 /
      DATA AE11CS(34) /    .0000000000 00001223E0 /
      DATA AE11CS(35) /    .0000000000 00000716E0 /
      DATA AE11CS(36) /   -.0000000000 00000024E0 /
      DATA AE11CS(37) /   -.0000000000 00000201E0 /
      DATA AE11CS(38) /   -.0000000000 00000082E0 /
      DATA AE11CS(39) /    .0000000000 00000017E0 /
      DATA AE12CS( 1) /    .5824174951 3472674E0 /
      DATA AE12CS( 2) /   -.1583488509 0578275E0 /
      DATA AE12CS( 3) /   -.0067642755 90323141E0 /
      DATA AE12CS( 4) /    .0051258439 50185725E0 /
      DATA AE12CS( 5) /    .0004352324 92169391E0 /
      DATA AE12CS( 6) /   -.0001436133 66305483E0 /
      DATA AE12CS( 7) /   -.0000418013 20556301E0 /
      DATA AE12CS( 8) /   -.0000027133 95758640E0 /
      DATA AE12CS( 9) /    .0000011513 81913647E0 /
      DATA AE12CS(10) /    .0000004206 50022012E0 /
      DATA AE12CS(11) /    .0000000665 81901391E0 /
      DATA AE12CS(12) /    .0000000006 62143777E0 /
      DATA AE12CS(13) /   -.0000000028 44104870E0 /
      DATA AE12CS(14) /   -.0000000009 40724197E0 /
      DATA AE12CS(15) /   -.0000000001 77476602E0 /
      DATA AE12CS(16) /   -.0000000000 15830222E0 /
      DATA AE12CS(17) /    .0000000000 02905732E0 /
      DATA AE12CS(18) /    .0000000000 01769356E0 /
      DATA AE12CS(19) /    .0000000000 00492735E0 /
      DATA AE12CS(20) /    .0000000000 00093709E0 /
      DATA AE12CS(21) /    .0000000000 00010707E0 /
      DATA AE12CS(22) /   -.0000000000 00000537E0 /
      DATA AE12CS(23) /   -.0000000000 00000716E0 /
      DATA AE12CS(24) /   -.0000000000 00000244E0 /
      DATA AE12CS(25) /   -.0000000000 00000058E0 /
      DATA E11CS( 1) / -16.1134616555 71494026E0 /
      DATA E11CS( 2) /   7.7940727787 426802769E0 /
      DATA E11CS( 3) /  -1.9554058188 631419507E0 /
      DATA E11CS( 4) /    .3733729386 6277945612E0 /
      DATA E11CS( 5) /   -.0569250319 1092901938E0 /
      DATA E11CS( 6) /    .0072110777 6966009185E0 /
      DATA E11CS( 7) /   -.0007810490 1449841593E0 /
      DATA E11CS( 8) /    .0000738809 3356262168E0 /
      DATA E11CS( 9) /   -.0000062028 6187580820E0 /
      DATA E11CS(10) /    .0000004681 6002303176E0 /
      DATA E11CS(11) /   -.0000000320 9288853329E0 /
      DATA E11CS(12) /    .0000000020 1519974874E0 /
      DATA E11CS(13) /   -.0000000001 1673686816E0 /
      DATA E11CS(14) /    .0000000000 0627627066E0 /
      DATA E11CS(15) /   -.0000000000 0031481541E0 /
      DATA E11CS(16) /    .0000000000 0001479904E0 /
      DATA E11CS(17) /   -.0000000000 0000065457E0 /
      DATA E11CS(18) /    .0000000000 0000002733E0 /
      DATA E11CS(19) /   -.0000000000 0000000108E0 /
      DATA E12CS( 1) /  -0.0373902147 92202795E0 /
      DATA E12CS( 2) /   0.0427239860 62209577E0 /
      DATA E12CS( 3) /   -.1303182079 849700544E0 /
      DATA E12CS( 4) /    .0144191240 2469889073E0 /
      DATA E12CS( 5) /   -.0013461707 8051068022E0 /
      DATA E12CS( 6) /    .0001073102 9253063780E0 /
      DATA E12CS( 7) /   -.0000074299 9951611943E0 /
      DATA E12CS( 8) /    .0000004537 7325690753E0 /
      DATA E12CS( 9) /   -.0000000247 6417211390E0 /
      DATA E12CS(10) /    .0000000012 2076581374E0 /
      DATA E12CS(11) /   -.0000000000 5485141480E0 /
      DATA E12CS(12) /    .0000000000 0226362142E0 /
      DATA E12CS(13) /   -.0000000000 0008635897E0 /
      DATA E12CS(14) /    .0000000000 0000306291E0 /
      DATA E12CS(15) /   -.0000000000 0000010148E0 /
      DATA E12CS(16) /    .0000000000 0000000315E0 /
      DATA AE13CS( 1) /   -.6057732466 4060346E0 /
      DATA AE13CS( 2) /   -.1125352434 8366090E0 /
      DATA AE13CS( 3) /    .0134322662 47902779E0 /
      DATA AE13CS( 4) /   -.0019268451 87381145E0 /
      DATA AE13CS( 5) /    .0003091183 37720603E0 /
      DATA AE13CS( 6) /   -.0000535641 32129618E0 /
      DATA AE13CS( 7) /    .0000098278 12880247E0 /
      DATA AE13CS( 8) /   -.0000018853 68984916E0 /
      DATA AE13CS( 9) /    .0000003749 43193568E0 /
      DATA AE13CS(10) /   -.0000000768 23455870E0 /
      DATA AE13CS(11) /    .0000000161 43270567E0 /
      DATA AE13CS(12) /   -.0000000034 66802211E0 /
      DATA AE13CS(13) /    .0000000007 58754209E0 /
      DATA AE13CS(14) /   -.0000000001 68864333E0 /
      DATA AE13CS(15) /    .0000000000 38145706E0 /
      DATA AE13CS(16) /   -.0000000000 08733026E0 /
      DATA AE13CS(17) /    .0000000000 02023672E0 /
      DATA AE13CS(18) /   -.0000000000 00474132E0 /
      DATA AE13CS(19) /    .0000000000 00112211E0 /
      DATA AE13CS(20) /   -.0000000000 00026804E0 /
      DATA AE13CS(21) /    .0000000000 00006457E0 /
      DATA AE13CS(22) /   -.0000000000 00001568E0 /
      DATA AE13CS(23) /    .0000000000 00000383E0 /
      DATA AE13CS(24) /   -.0000000000 00000094E0 /
      DATA AE13CS(25) /    .0000000000 00000023E0 /
      DATA AE14CS( 1) /   -.1892918000 753017E0 /
      DATA AE14CS( 2) /   -.0864811785 5259871E0 /
      DATA AE14CS( 3) /    .0072241015 4374659E0 /
      DATA AE14CS( 4) /   -.0008097559 4575573E0 /
      DATA AE14CS( 5) /    .0001099913 4432661E0 /
      DATA AE14CS( 6) /   -.0000171733 2998937E0 /
      DATA AE14CS( 7) /    .0000029856 2751447E0 /
      DATA AE14CS( 8) /   -.0000005659 6491457E0 /
      DATA AE14CS( 9) /    .0000001152 6808397E0 /
      DATA AE14CS(10) /   -.0000000249 5030440E0 /
      DATA AE14CS(11) /    .0000000056 9232420E0 /
      DATA AE14CS(12) /   -.0000000013 5995766E0 /
      DATA AE14CS(13) /    .0000000003 3846628E0 /
      DATA AE14CS(14) /   -.0000000000 8737853E0 /
      DATA AE14CS(15) /    .0000000000 2331588E0 /
      DATA AE14CS(16) /   -.0000000000 0641148E0 /
      DATA AE14CS(17) /    .0000000000 0181224E0 /
      DATA AE14CS(18) /   -.0000000000 0052538E0 /
      DATA AE14CS(19) /    .0000000000 0015592E0 /
      DATA AE14CS(20) /   -.0000000000 0004729E0 /
      DATA AE14CS(21) /    .0000000000 0001463E0 /
      DATA AE14CS(22) /   -.0000000000 0000461E0 /
      DATA AE14CS(23) /    .0000000000 0000148E0 /
      DATA AE14CS(24) /   -.0000000000 0000048E0 /
      DATA AE14CS(25) /    .0000000000 0000016E0 /
      DATA AE14CS(26) /   -.0000000000 0000005E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  E1
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NTAE11 = INITS (AE11CS, 39, ETA)
         NTAE12 = INITS (AE12CS, 25, ETA)
         NTE11 = INITS (E11CS, 19, ETA)
         NTE12 = INITS (E12CS, 16, ETA)
         NTAE13 = INITS (AE13CS, 25, ETA)
         NTAE14 = INITS (AE14CS, 26, ETA)
C
         XMAXT = -LOG (R1MACH(1))
         XMAX = XMAXT - LOG(XMAXT)
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GT.(-10.)) GO TO 20
C
C E1(X) = -EI(-X) FOR X .LE. -10.
C
      E1 = EXP(-X)/X * (1.+CSEVL (20./X+1., AE11CS, NTAE11))
      RETURN
C
 20   IF (X.GT.(-4.0)) GO TO 30
C
C E1(X) = -EI(-X) FOR -10. .LT. X .LE. -4.
C
      E1 = EXP(-X)/X * (1.+CSEVL ((40./X+7.)/3., AE12CS, NTAE12))
      RETURN
C
 30   IF (X.GT.(-1.0)) GO TO 40
C
C E1(X) = -EI(-X) FOR -4. .LT. X .LE. -1.
C
      E1 = -LOG(ABS(X)) + CSEVL ((2.*X+5.)/3., E11CS, NTE11)
      RETURN
C
 40   IF (X.GT.1.) GO TO 50
      IF (X .EQ. 0.) CALL XERMSG ('SLATEC', 'E1', 'X IS 0', 2, 2)
C
C E1(X) = -EI(-X) FOR -1. .LT. X .LE. 1.,  X .NE. 0.
C
      E1 = (-LOG(ABS(X)) - 0.6875 + X) + CSEVL (X, E12CS, NTE12)
      RETURN
C
 50   IF (X.GT.4.) GO TO 60
C
C E1(X) = -EI(-X) FOR 1. .LT. X .LE. 4.
C
      E1 = EXP(-X)/X * (1.+CSEVL ((8./X-5.)/3., AE13CS, NTAE13))
      RETURN
C
 60   IF (X.GT.XMAX) GO TO 70
C
C E1(X) = -EI(-X) FOR 4. .LT. X .LE. XMAX
C
      E1 = EXP(-X)/X * (1. + CSEVL (8./X-1., AE14CS, NTAE14))
      RETURN
C
C E1(X) = -EI(-X) FOR X .GT. XMAX
C
 70   CALL XERMSG ('SLATEC', 'E1', 'X SO BIG E1 UNDERFLOWS', 1, 1)
      E1 = 0.
      RETURN
C
      END
*DECK EFC
      SUBROUTINE EFC (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT, BKPT,
     +   MDEIN, MDEOUT, COEFF, LW, W)
C***BEGIN PROLOGUE  EFC
C***PURPOSE  Fit a piecewise polynomial curve to discrete data.
C            The piecewise polynomials are represented as B-splines.
C            The fitting is done in a weighted least squares sense.
C***LIBRARY   SLATEC
C***CATEGORY  K1A1A1, K1A2A, L8A3
C***TYPE      SINGLE PRECISION (EFC-S, DEFC-D)
C***KEYWORDS  B-SPLINE, CURVE FITTING, WEIGHTED LEAST SQUARES
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C      This subprogram fits a piecewise polynomial curve
C      to discrete data.  The piecewise polynomials are
C      represented as B-splines.
C      The fitting is done in a weighted least squares sense.
C
C      The data can be processed in groups of modest size.
C      The size of the group is chosen by the user.  This feature
C      may be necessary for purposes of using constrained curve fitting
C      with subprogram FC( ) on a very large data set.
C
C      For a description of the B-splines and usage instructions to
C      evaluate them, see
C
C      C. W. de Boor, Package for Calculating with B-Splines.
C                     SIAM J. Numer. Anal., p. 441, (June, 1977).
C
C      For further discussion of (constrained) curve fitting using
C      B-splines, see
C
C      R. J. Hanson, Constrained Least Squares Curve Fitting
C                   to Discrete Data Using B-Splines, a User's
C                   Guide. Sandia Labs. Tech. Rept. SAND-78-1291,
C                   December, (1978).
C
C  Input..
C      NDATA,XDATA(*),
C      YDATA(*),
C      SDDATA(*)
C                         The NDATA discrete (X,Y) pairs and the Y value
C                         standard deviation or uncertainty, SD, are in
C                         the respective arrays XDATA(*), YDATA(*), and
C                         SDDATA(*).  No sorting of XDATA(*) is
C                         required.  Any non-negative value of NDATA is
C                         allowed.  A negative value of NDATA is an
C                         error.  A zero value for any entry of
C                         SDDATA(*) will weight that data point as 1.
C                         Otherwise the weight of that data point is
C                         the reciprocal of this entry.
C
C      NORD,NBKPT,
C      BKPT(*)
C                         The NBKPT knots of the B-spline of order NORD
C                         are in the array BKPT(*).  Normally the
C                         problem data interval will be included between
C                         the limits BKPT(NORD) and BKPT(NBKPT-NORD+1).
C                         The additional end knots BKPT(I),I=1,...,
C                         NORD-1 and I=NBKPT-NORD+2,...,NBKPT, are
C                         required to compute the functions used to fit
C                         the data.  No sorting of BKPT(*) is required.
C                         Internal to  EFC( ) the extreme end knots may
C                         be reduced and increased respectively to
C                         accommodate any data values that are exterior
C                         to the given knot values.  The contents of
C                         BKPT(*) is not changed.
C
C                         NORD must be in the range 1 .LE. NORD .LE. 20.
C                         The value of NBKPT must satisfy the condition
C                         NBKPT .GE. 2*NORD.
C                         Other values are considered errors.
C
C                         (The order of the spline is one more than the
C                         degree of the piecewise polynomial defined on
C                         each interval.  This is consistent with the
C                         B-spline package convention.  For example,
C                         NORD=4 when we are using piecewise cubics.)
C
C        MDEIN
C                         An integer flag, with one of two possible
C                         values (1 or 2), that directs the subprogram
C                         action with regard to new data points provided
C                         by the user.
C
C                         =1  The first time that EFC( ) has been
C                         entered.  There are NDATA points to process.
C
C                         =2  This is another entry to EFC( ).  The sub-
C                         program EFC( ) has been entered with MDEIN=1
C                         exactly once before for this problem.  There
C                         are NDATA new additional points to merge and
C                         process with any previous points.
C                         (When using EFC( ) with MDEIN=2 it is import-
C                         ant that the set of knots remain fixed at the
C                         same values for all entries to EFC( ).)
C       LW
C                         The amount of working storage actually
C                         allocated for the working array W(*).
C                         This quantity is compared with the
C                         actual amount of storage needed in EFC( ).
C                         Insufficient storage allocated for W(*) is
C                         an error.  This feature was included in EFC( )
C                         because misreading the storage formula
C                         for W(*) might very well lead to subtle
C                         and hard-to-find programming bugs.
C
C                         The length of the array W(*) must satisfy
C
C                         LW .GE. (NBKPT-NORD+3)*(NORD+1)+
C                                 (NBKPT+1)*(NORD+1)+
C                               2*MAX(NDATA,NBKPT)+NBKPT+NORD**2
C
C  Output..
C      MDEOUT
C                         An output flag that indicates the status
C                         of the curve fit.
C
C                         =-1  A usage error of EFC( ) occurred.  The
C                         offending condition is noted with the SLATEC
C                         library error processor, XERMSG( ).  In case
C                         the working array W(*) is not long enough, the
C                         minimal acceptable length is printed.
C
C                         =1  The B-spline coefficients for the fitted
C                         curve have been returned in array COEFF(*).
C
C                         =2  Not enough data has been processed to
C                         determine the B-spline coefficients.
C                         The user has one of two options.  Continue
C                         to process more data until a unique set
C                         of coefficients is obtained, or use the
C                         subprogram FC( ) to obtain a specific
C                         set of coefficients.  The user should read
C                         the usage instructions for FC( ) for further
C                         details if this second option is chosen.
C      COEFF(*)
C                         If the output value of MDEOUT=1, this array
C                         contains the unknowns obtained from the least
C                         squares fitting process.  These N=NBKPT-NORD
C                         parameters are the B-spline coefficients.
C                         For MDEOUT=2, not enough data was processed to
C                         uniquely determine the B-spline coefficients.
C                         In this case, and also when MDEOUT=-1, all
C                         values of COEFF(*) are set to zero.
C
C                         If the user is not satisfied with the fitted
C                         curve returned by EFC( ), the constrained
C                         least squares curve fitting subprogram FC( )
C                         may be required.  The work done within EFC( )
C                         to accumulate the data can be utilized by
C                         the user, if so desired.  This involves
C                         saving the first (NBKPT-NORD+3)*(NORD+1)
C                         entries of W(*) and providing this data
C                         to FC( ) with the "old problem" designation.
C                         The user should read the usage instructions
C                         for subprogram FC( ) for further details.
C
C  Working Array..
C      W(*)
C                         This array is typed REAL.
C                         Its length is  specified as an input parameter
C                         in LW as noted above.  The contents of W(*)
C                         must not be modified by the user between calls
C                         to EFC( ) with values of MDEIN=1,2,2,... .
C                         The first (NBKPT-NORD+3)*(NORD+1) entries of
C                         W(*) are acceptable as direct input to FC( )
C                         for an "old problem" only when MDEOUT=1 or 2.
C
C  Evaluating the
C  Fitted Curve..
C                         To evaluate derivative number IDER at XVAL,
C                         use the function subprogram BVALU( ).
C
C                         F = BVALU(BKPT,COEFF,NBKPT-NORD,NORD,IDER,
C                                      XVAL,INBV,WORKB)
C
C                         The output of this subprogram will not be
C                         defined unless an output value of MDEOUT=1
C                         was obtained from EFC( ), XVAL is in the data
C                         interval, and IDER is nonnegative and .LT.
C                         NORD.
C
C                         The first time BVALU( ) is called, INBV=1
C                         must be specified.  This value of INBV is the
C                         overwritten by BVALU( ).  The array WORKB(*)
C                         must be of length at least 3*NORD, and must
C                         not be the same as the W(*) array used in the
C                         call to EFC( ).
C
C                         BVALU( ) expects the breakpoint array BKPT(*)
C                         to be sorted.
C
C***REFERENCES  R. J. Hanson, Constrained least squares curve fitting
C                 to discrete data using B-splines, a users guide,
C                 Report SAND78-1291, Sandia Laboratories, December
C                 1978.
C***ROUTINES CALLED  EFCMN
C***REVISION HISTORY  (YYMMDD)
C   800801  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   900510  Change Prologue comments to refer to XERMSG.  (RWC)
C   900607  Editorial changes to Prologue to make Prologues for EFC,
C           DEFC, FC, and DFC look as much the same as possible.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  EFC
C
C      SUBROUTINE           FUNCTION/REMARKS
C
C      BSPLVN( )          COMPUTE FUNCTION VALUES OF B-SPLINES.  FROM
C                         THE B-SPLINE PACKAGE OF DE BOOR NOTED ABOVE.
C
C      BNDACC( ),         BANDED LEAST SQUARES MATRIX PROCESSORS.
C      BNDSOL( )          FROM LAWSON-HANSON, SOLVING LEAST
C                         SQUARES PROBLEMS.
C
C      SSORT( )           DATA SORTING SUBROUTINE, FROM THE
C                         SANDIA MATH. LIBRARY, SAND77-1441.
C
C      XERMSG( )          ERROR HANDLING ROUTINE
C                         FOR THE SLATEC MATH. LIBRARY.
C                         SEE SAND78-1189, BY R. E. JONES.
C
C      SCOPY( ),SSCAL( )  SUBROUTINES FROM THE BLAS PACKAGE.
C
C                         WRITTEN BY R. HANSON, SANDIA NATL. LABS.,
C                         ALB., N. M., AUGUST-SEPTEMBER, 1980.
C
      REAL BKPT(*),COEFF(*),SDDATA(*),W(*),XDATA(*),YDATA(*)
      INTEGER LW, MDEIN, MDEOUT, NBKPT, NDATA, NORD
C
      EXTERNAL EFCMN
C
      INTEGER LBF, LBKPT, LG, LPTEMP, LWW, LXTEMP, MDG, MDW
C
C***FIRST EXECUTABLE STATEMENT  EFC
C     LWW=1               USAGE IN EFCMN( ) OF W(*)..
C     LWW,...,LG-1        W(*,*)
C
C     LG,...,LXTEMP-1     G(*,*)
C
C     LXTEMP,...,LPTEMP-1 XTEMP(*)
C
C     LPTEMP,...,LBKPT-1  PTEMP(*)
C
C     LBKPT,...,LBF       BKPT(*) (LOCAL TO EFCMN( ))
C
C     LBF,...,LBF+NORD**2 BF(*,*)
C
      MDG = NBKPT+1
      MDW = NBKPT-NORD+3
      LWW = 1
      LG = LWW + MDW*(NORD+1)
      LXTEMP = LG + MDG*(NORD+1)
      LPTEMP = LXTEMP + MAX(NDATA,NBKPT)
      LBKPT  = LPTEMP + MAX(NDATA,NBKPT)
      LBF = LBKPT + NBKPT
      CALL EFCMN(NDATA,XDATA,YDATA,SDDATA,
     1         NORD,NBKPT,BKPT,
     2         MDEIN,MDEOUT,
     3         COEFF,
     4         W(LBF),W(LXTEMP),W(LPTEMP),W(LBKPT),
     5         W(LG),MDG,W(LWW),MDW,LW)
      RETURN
      END
*DECK EFCMN
      SUBROUTINE EFCMN (NDATA, XDATA, YDATA, SDDATA, NORD, NBKPT,
     +   BKPTIN, MDEIN, MDEOUT, COEFF, BF, XTEMP, PTEMP, BKPT, G, MDG,
     +   W, MDW, LW)
C***BEGIN PROLOGUE  EFCMN
C***SUBSIDIARY
C***PURPOSE  Subsidiary to EFC
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (EFCMN-S, DEFCMN-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     This is a companion subprogram to EFC( ).
C     This subprogram does weighted least squares fitting of data by
C     B-spline curves.
C     The documentation for EFC( ) has complete usage instructions.
C
C***SEE ALSO  EFC
C***ROUTINES CALLED  BNDACC, BNDSOL, BSPLVN, SCOPY, SSCAL, SSORT, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890618  Completely restructured and extensively revised (WRB & RWC)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C***END PROLOGUE  EFCMN
      INTEGER LW, MDEIN, MDEOUT, MDG, MDW, NBKPT, NDATA, NORD
      REAL             BF(NORD,*), BKPT(*), BKPTIN(*), COEFF(*),
     *   G(MDG,*), PTEMP(*), SDDATA(*), W(MDW,*), XDATA(*), XTEMP(*),
     *   YDATA(*)
C
      EXTERNAL BNDACC, BNDSOL, BSPLVN, SCOPY, SSCAL, SSORT, XERMSG
C
      REAL             DUMMY, RNORM, XMAX, XMIN, XVAL
      INTEGER I, IDATA, ILEFT, INTSEQ, IP, IR, IROW, L, MT, N, NB,
     *   NORDM1, NORDP1, NP1
      CHARACTER*8 XERN1, XERN2
C
C***FIRST EXECUTABLE STATEMENT  EFCMN
C
C     Initialize variables and analyze input.
C
      N = NBKPT - NORD
      NP1 = N + 1
C
C     Initially set all output coefficients to zero.
C
      CALL SCOPY (N, 0.E0, 0, COEFF, 1)
      MDEOUT = -1
      IF (NORD.LT.1 .OR. NORD.GT.20) THEN
         CALL XERMSG ('SLATEC', 'EFCMN',
     +      'IN EFC, THE ORDER OF THE B-SPLINE MUST BE 1 THRU 20.',
     +      3, 1)
         RETURN
      ENDIF
C
      IF (NBKPT.LT.2*NORD) THEN
         CALL XERMSG ('SLATEC', 'EFCMN',
     +      'IN EFC, THE NUMBER OF KNOTS MUST BE AT LEAST TWICE ' //
     +      'THE B-SPLINE ORDER.', 4, 1)
         RETURN
      ENDIF
C
      IF (NDATA.LT.0) THEN
         CALL XERMSG ('SLATEC', 'EFCMN',
     +      'IN EFC, THE NUMBER OF DATA POINTS MUST BE NONNEGATIVE.',
     +      5, 1)
         RETURN
      ENDIF
C
      NB = (NBKPT-NORD+3)*(NORD+1) + (NBKPT+1)*(NORD+1) +
     +     2*MAX(NBKPT,NDATA) + NBKPT + NORD**2
      IF (LW .LT. NB) THEN
         WRITE (XERN1, '(I8)') NB
         WRITE (XERN2, '(I8)') LW
         CALL XERMSG ('SLATEC', 'EFCMN',
     *      'IN EFC, INSUFFICIENT STORAGE FOR W(*).  CHECK FORMULA ' //
     *      'THAT READS LW.GE. ... .  NEED = ' // XERN1 //
     *      ' GIVEN = ' // XERN2, 6, 1)
         MDEOUT = -1
         RETURN
      ENDIF
C
      IF (MDEIN.NE.1 .AND. MDEIN.NE.2) THEN
         CALL XERMSG ('SLATEC', 'EFCMN',
     +      'IN EFC, INPUT VALUE OF MDEIN MUST BE 1-2.', 7, 1)
         RETURN
      ENDIF
C
C     Sort the breakpoints.
C
      CALL SCOPY (NBKPT, BKPTIN, 1, BKPT, 1)
      CALL SSORT (BKPT, DUMMY, NBKPT, 1)
C
C     Save interval containing knots.
C
      XMIN = BKPT(NORD)
      XMAX = BKPT(NP1)
      NORDM1 = NORD - 1
      NORDP1 = NORD + 1
C
C     Process least squares equations.
C
C     Sort data and an array of pointers.
C
      CALL SCOPY (NDATA, XDATA, 1, XTEMP, 1)
      DO 100 I = 1,NDATA
         PTEMP(I) = I
  100 CONTINUE
C
      IF (NDATA.GT.0) THEN
         CALL SSORT (XTEMP, PTEMP, NDATA, 2)
         XMIN = MIN(XMIN,XTEMP(1))
         XMAX = MAX(XMAX,XTEMP(NDATA))
      ENDIF
C
C     Fix breakpoint array if needed. This should only involve very
C     minor differences with the input array of breakpoints.
C
      DO 110 I = 1,NORD
         BKPT(I) = MIN(BKPT(I),XMIN)
  110 CONTINUE
C
      DO 120 I = NP1,NBKPT
         BKPT(I) = MAX(BKPT(I),XMAX)
  120 CONTINUE
C
C     Initialize parameters of banded matrix processor, BNDACC( ).
C
      MT = 0
      IP = 1
      IR = 1
      ILEFT = NORD
      INTSEQ = 1
      DO 150 IDATA = 1,NDATA
C
C        Sorted indices are in PTEMP(*).
C
         L = PTEMP(IDATA)
         XVAL = XDATA(L)
C
C        When interval changes, process equations in the last block.
C
         IF (XVAL.GE.BKPT(ILEFT+1)) THEN
            CALL BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1)
            MT = 0
C
C           Move pointer up to have BKPT(ILEFT).LE.XVAL, ILEFT.LE.N.
C
            DO 130 ILEFT = ILEFT,N
               IF (XVAL.LT.BKPT(ILEFT+1)) GO TO 140
               IF (MDEIN.EQ.2) THEN
C
C                 Data is being sequentially accumulated.
C                 Transfer previously accumulated rows from W(*,*) to
C                 G(*,*) and process them.
C
                  CALL SCOPY (NORDP1, W(INTSEQ,1), MDW, G(IR,1), MDG)
                  CALL BNDACC (G, MDG, NORD, IP, IR, 1, INTSEQ)
                  INTSEQ = INTSEQ + 1
               ENDIF
  130       CONTINUE
         ENDIF
C
C        Obtain B-spline function value.
C
  140    CALL BSPLVN (BKPT, NORD, 1, XVAL, ILEFT, BF)
C
C        Move row into place.
C
         IROW = IR + MT
         MT = MT + 1
         CALL SCOPY (NORD, BF, 1, G(IROW,1), MDG)
         G(IROW,NORDP1) = YDATA(L)
C
C        Scale data if uncertainty is nonzero.
C
         IF (SDDATA(L).NE.0.E0) CALL SSCAL (NORDP1, 1.E0/SDDATA(L),
     +                               G(IROW,1), MDG)
C
C        When staging work area is exhausted, process rows.
C
         IF (IROW.EQ.MDG-1) THEN
            CALL BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1)
            MT = 0
         ENDIF
  150 CONTINUE
C
C     Process last block of equations.
C
      CALL BNDACC (G, MDG, NORD, IP, IR, MT, ILEFT-NORDM1)
C
C     Finish processing any previously accumulated rows from W(*,*)
C     to G(*,*).
C
      IF (MDEIN.EQ.2) THEN
         DO 160 I = INTSEQ,NP1
            CALL SCOPY (NORDP1, W(I,1), MDW, G(IR,1), MDG)
            CALL BNDACC (G, MDG, NORD, IP, IR, 1, MIN(N,I))
  160    CONTINUE
      ENDIF
C
C     Last call to adjust block positioning.
C
      CALL SCOPY (NORDP1, 0.E0, 0, G(IR,1), MDG)
      CALL BNDACC (G, MDG, NORD, IP, IR, 1, NP1)
C
C     Transfer accumulated rows from G(*,*) to W(*,*) for
C     possible later sequential accumulation.
C
      DO 170 I = 1,NP1
         CALL SCOPY (NORDP1, G(I,1), MDG, W(I,1), MDW)
  170 CONTINUE
C
C     Solve for coefficients when possible.
C
      DO 180 I = 1,N
         IF (G(I,1).EQ.0.E0) THEN
            MDEOUT = 2
            RETURN
         ENDIF
  180 CONTINUE
C
C     All the diagonal terms in the accumulated triangular
C     matrix are nonzero.  The solution can be computed but
C     it may be unsuitable for further use due to poor
C     conditioning or the lack of constraints.  No checking
C     for either of these is done here.
C
      CALL BNDSOL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM)
      MDEOUT = 1
      RETURN
      END
*DECK EI
      FUNCTION EI (X)
C***BEGIN PROLOGUE  EI
C***PURPOSE  Compute the exponential integral Ei(X).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      SINGLE PRECISION (EI-S, DEI-D)
C***KEYWORDS  EI FUNCTION, EXPONENTIAL INTEGRAL, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C EI calculates the single precision exponential integral, Ei(X), for
C positive single precision argument X and the Cauchy principal value
C for negative X.  If principal values are used everywhere, then, for
C all X,
C
C    Ei(X) = -E1(-X)
C or
C    E1(X) = -Ei(-X).
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  E1
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   891115  Modified prologue description.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  EI
C***FIRST EXECUTABLE STATEMENT  EI
      EI = -E1(-X)
C
      RETURN
      END
*DECK EISDOC
      SUBROUTINE EISDOC
C***BEGIN PROLOGUE  EISDOC
C***PURPOSE  Documentation for EISPACK, a collection of subprograms for
C            solving matrix eigen-problems.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4, Z
C***TYPE      ALL (EISDOC-A)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Vandevender, W. H., (SNLA)
C***DESCRIPTION
C
C                 **********EISPACK Routines**********
C
C single double complx
C ------ ------ ------
C
C RS       -    CH     Computes eigenvalues and, optionally,
C                      eigenvectors of real symmetric
C                      (complex Hermitian) matrix.
C
C RSP      -      -    Compute eigenvalues and, optionally,
C                      eigenvectors of real symmetric matrix
C                      packed into a one dimensional array.
C
C RG       -    CG     Computes eigenvalues and, optionally,
C                      eigenvectors of a real (complex) general
C                      matrix.
C
C BISECT   -      -    Compute eigenvalues of symmetric tridiagonal
C                      matrix given interval using Sturm sequencing.
C
C IMTQL1   -      -    Computes eigenvalues of symmetric tridiagonal
C                      matrix implicit QL method.
C
C IMTQL2   -      -    Computes eigenvalues and eigenvectors of
C                      symmetric tridiagonal matrix using
C                      implicit QL method.
C
C IMTQLV   -      -    Computes eigenvalues of symmetric tridiagonal
C                      matrix by the implicit QL method.
C                      Eigenvectors may be computed later.
C
C RATQR    -      -    Computes largest or smallest eigenvalues
C                      of symmetric tridiagonal matrix using
C                      rational QR method with Newton correction.
C
C RST      -      -    Compute eigenvalues and, optionally,
C                      eigenvectors of real symmetric tridiagonal
C                      matrix.
C
C RT       -      -    Compute eigenvalues and eigenvectors of
C                      a special real tridiagonal matrix.
C
C TQL1     -      -    Compute eigenvalues of symmetric tridiagonal
C                      matrix by QL method.
C
C TQL2     -      -    Compute eigenvalues and eigenvectors
C                      of symmetric tridiagonal matrix.
C
C TQLRAT   -      -    Computes eigenvalues of symmetric
C                      tridiagonal matrix a rational variant
C                      of the QL method.
C
C TRIDIB   -      -    Computes eigenvalues of symmetric
C                      tridiagonal matrix given interval using
C                      Sturm sequencing.
C
C TSTURM   -      -    Computes eigenvalues of symmetric tridiagonal
C                      matrix given interval and eigenvectors
C                      by Sturm sequencing.  This subroutine
C                      is a translation of the ALGOL procedure
C                      TRISTURM by Peters and Wilkinson. HANDBOOK
C                      FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA,
C                      418-439(1971).
C
C BQR      -      -    Computes some of the eigenvalues of a real
C                      symmetric matrix using the QR method with
C                      shifts of origin.
C
C RSB      -      -    Computes eigenvalues and, optionally,
C                      eigenvectors of symmetric band matrix.
C
C RSG      -      -    Computes eigenvalues and, optionally,
C                      eigenvectors of symmetric generalized
C                      eigenproblem: A*X=(LAMBDA)*B*X
C
C RSGAB    -      -    Computes eigenvalues and, optionally,
C                      eigenvectors of symmetric generalized
C                      eigenproblem: A*B*X=(LAMBDA)*X
C
C RSGBA    -      -    Computes eigenvalues and, optionally,
C                      eigenvectors of symmetric generalized
C                      eigenproblem: B*A*X=(LAMBDA)*X
C
C RGG      -      -    Computes eigenvalues and eigenvectors
C                      for real generalized eigenproblem:
C                      A*X=(LAMBDA)*B*X.
C
C BALANC   -    CBAL   Balances a general real (complex)
C                      matrix and isolates eigenvalues whenever
C                      possible.
C
C BANDR    -      -    Reduces real symmetric band matrix
C                      to symmetric tridiagonal matrix and,
C                      optionally, accumulates orthogonal similarity
C                      transformations.
C
C HTRID3   -      -    Reduces complex Hermitian (packed) matrix
C                      to real symmetric tridiagonal matrix by unitary
C                      similarity transformations.
C
C HTRIDI   -      -    Reduces complex Hermitian matrix to real
C                      symmetric tridiagonal matrix using unitary
C                      similarity transformations.
C
C TRED1    -      -    Reduce real symmetric matrix to symmetric
C                      tridiagonal matrix using orthogonal
C                      similarity transformations.
C
C TRED2    -      -    Reduce real symmetric matrix to symmetric
C                      tridiagonal matrix using and accumulating
C                      orthogonal transformations.
C
C TRED3    -      -    Reduce  symmetric matrix stored in packed
C                      form to symmetric tridiagonal matrix using
C                      orthogonal transformations.
C
C ELMHES   -    COMHES Reduces real (complex) general matrix to
C                      upper Hessenberg form using stabilized
C                      elementary similarity transformations.
C
C ORTHES   -    CORTH  Reduces real (complex) general matrix to upper
C                      Hessenberg form orthogonal (unitary)
C                      similarity transformations.
C
C QZHES    -      -    The first step of the QZ algorithm for solving
C                      generalized matrix eigenproblems.  Accepts
C                      a pair of real general matrices and reduces
C                      one of them to upper Hessenberg and the other
C                      to upper triangular form using orthogonal
C                      transformations. Usually followed by QZIT,
C                      QZVAL, QZ
C
C QZIT     -      -    The second step of the QZ algorithm for
C                      generalized eigenproblems.  Accepts an upper
C                      Hessenberg and an upper triangular matrix
C                      and reduces the former to quasi-triangular
C                      form while preserving the form of the latter.
C                      Usually preceded by QZHES and followed by QZVAL
C                      and QZVEC.
C
C FIGI     -      -    Transforms certain real non-symmetric
C                      tridiagonal matrix to symmetric tridiagonal
C                      matrix.
C
C FIGI2    -      -    Transforms certain real non-symmetric
C                      tridiagonal matrix to symmetric tridiagonal
C                      matrix.
C
C REDUC    -      -    Reduces generalized symmetric eigenproblem
C                      A*X=(LAMBDA)*B*X, to standard symmetric
C                      eigenproblem using Cholesky factorization.
C
C REDUC2   -      -    Reduces certain generalized symmetric
C                      eigenproblems standard symmetric eigenproblem,
C                      using Cholesky factorization.
C
C   -      -    COMLR  Computes eigenvalues of a complex upper
C                      Hessenberg matrix using the modified LR method.
C
C   -      -    COMLR2 Computes eigenvalues and eigenvectors of
C                      complex upper Hessenberg matrix using
C                      modified LR method.
C
C HQR      -    COMQR  Computes eigenvalues of a real (complex)
C                      upper Hessenberg matrix using the QR method.
C
C HQR2     -    COMQR2 Computes eigenvalues and eigenvectors of
C                      real (complex) upper Hessenberg matrix
C                      using QR method.
C
C INVIT    -    CINVIT Computes eigenvectors of real (complex)
C                      Hessenberg matrix associated with specified
C                      eigenvalues by inverse iteration.
C
C QZVAL    -      -    The third step of the QZ algorithm for
C                      generalized eigenproblems.  Accepts a pair
C                      of real matrices, one quasi-triangular form
C                      and the other in upper triangular form and
C                      computes the eigenvalues of the associated
C                      eigenproblem.  Usually preceded by QZHES,
C                      QZIT, and followed by QZVEC.
C
C BANDV    -      -    Forms eigenvectors of real symmetric band
C                      matrix associated with a set of ordered
C                      approximate eigenvalue by inverse iteration.
C
C QZVEC    -      -    The optional fourth step of the QZ algorithm
C                      for generalized eigenproblems.  Accepts
C                      a matrix in quasi-triangular form and another
C                      in upper triangular and computes the
C                      eigenvectors of the triangular problem
C                      and transforms them back to the original
C                      coordinates Usually preceded by QZHES, QZIT,
C                      QZVAL.
C
C TINVIT   -      -    Eigenvectors of symmetric tridiagonal
C                      matrix corresponding to some specified
C                      eigenvalues, using inverse iteration.
C
C BAKVEC   -      -    Forms eigenvectors of certain real
C                      non-symmetric tridiagonal matrix from
C                      symmetric tridiagonal matrix output from FIGI.
C
C BALBAK   -    CBABK2 Forms eigenvectors of real (complex) general
C                      matrix from eigenvectors of matrix output
C                      from BALANC (CBAL).
C
C ELMBAK   -    COMBAK Forms eigenvectors of real (complex) general
C                      matrix from eigenvectors of upper Hessenberg
C                      matrix output from ELMHES (COMHES).
C
C ELTRAN   -      -    Accumulates the stabilized elementary
C                      similarity transformations used in the
C                      reduction of a real general matrix to upper
C                      Hessenberg form by ELMHES.
C
C HTRIB3   -      -    Computes eigenvectors of complex Hermitian
C                      matrix from eigenvectors of real symmetric
C                      tridiagonal matrix output from HTRID3.
C
C HTRIBK   -      -    Forms eigenvectors of complex Hermitian
C                      matrix from eigenvectors of real symmetric
C                      tridiagonal matrix output from HTRIDI.
C
C ORTBAK   -    CORTB  Forms eigenvectors of general real (complex)
C                      matrix from eigenvectors of upper Hessenberg
C                      matrix output from ORTHES (CORTH).
C
C ORTRAN   -      -    Accumulates orthogonal similarity
C                      transformations in reduction of real general
C                      matrix by ORTHES.
C
C REBAK    -      -    Forms eigenvectors of generalized symmetric
C                      eigensystem from eigenvectors of derived
C                      matrix output from REDUC or REDUC2.
C
C REBAKB   -      -    Forms eigenvectors of generalized symmetric
C                      eigensystem from eigenvectors of derived
C                      matrix output from REDUC2
C
C TRBAK1   -      -    Forms the eigenvectors of real symmetric
C                      matrix from eigenvectors of symmetric
C                      tridiagonal matrix formed by TRED1.
C
C TRBAK3   -      -    Forms eigenvectors of real symmetric matrix
C                      from the eigenvectors of symmetric tridiagonal
C                      matrix formed by TRED3.
C
C MINFIT   -      -    Compute Singular Value Decomposition
C                      of rectangular matrix and solve related
C                      Linear Least Squares problem.
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   811101  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900723  PURPOSE section revised.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  EISDOC
C***FIRST EXECUTABLE STATEMENT  EISDOC
      RETURN
      END
*DECK ELMBAK
      SUBROUTINE ELMBAK (NM, LOW, IGH, A, INT, M, Z)
C***BEGIN PROLOGUE  ELMBAK
C***PURPOSE  Form the eigenvectors of a real general matrix from the
C            eigenvectors of the upper Hessenberg matrix output from
C            ELMHES.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (ELMBAK-S, COMBAK-C)
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 ELMBAK,
C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     This subroutine forms the eigenvectors of a REAL GENERAL
C     matrix by back transforming those of the corresponding
C     upper Hessenberg matrix determined by  ELMHES.
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        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix.
C
C        A contains the multipliers which were used in the reduction
C          by  ELMHES  in its lower triangle below the subdiagonal.
C          A is a two-dimensional REAL array, dimensioned A(NM,IGH).
C
C        INT contains information on the rows and columns interchanged
C          in the reduction by  ELMHES.  Only elements LOW through IGH
C          are used.  INT is a one-dimensional INTEGER array,
C          dimensioned INT(IGH).
C
C        M is the number of columns of Z to be back transformed.
C          M is an INTEGER variable.
C
C        Z contains the real and imaginary parts of the eigenvectors
C          to be back transformed in its first M columns.  Z is a
C          two-dimensional REAL array, dimensioned Z(NM,M).
C
C     On OUTPUT
C
C        Z contains the real and imaginary parts of the transformed
C          eigenvectors in its first 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  ELMBAK
C
      INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
      REAL A(NM,*),Z(NM,*)
      REAL X
      INTEGER INT(*)
C
C***FIRST EXECUTABLE STATEMENT  ELMBAK
      IF (M .EQ. 0) GO TO 200
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
      DO 140 MM = KP1, LA
         MP = LOW + IGH - MM
         MP1 = MP + 1
C
         DO 110 I = MP1, IGH
            X = A(I,MP-1)
            IF (X .EQ. 0.0E0) GO TO 110
C
            DO 100 J = 1, M
  100       Z(I,J) = Z(I,J) + X * Z(MP,J)
C
  110    CONTINUE
C
         I = INT(MP)
         IF (I .EQ. MP) GO TO 140
C
         DO 130 J = 1, M
            X = Z(I,J)
            Z(I,J) = Z(MP,J)
            Z(MP,J) = X
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
*DECK ELMHES
      SUBROUTINE ELMHES (NM, N, LOW, IGH, A, INT)
C***BEGIN PROLOGUE  ELMHES
C***PURPOSE  Reduce a real general matrix to upper Hessenberg form
C            using stabilized elementary similarity transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B2
C***TYPE      SINGLE PRECISION (ELMHES-S, COMHES-C)
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 ELMHES,
C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     Given a REAL GENERAL matrix, this subroutine
C     reduces a submatrix situated in rows and columns
C     LOW through IGH to upper Hessenberg form by
C     stabilized elementary similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A, 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        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix, N.
C
C        A contains the input matrix.  A is a two-dimensional REAL
C          array, dimensioned A(NM,N).
C
C     On OUTPUT
C
C        A contains the upper Hessenberg matrix.  The multipliers which
C          were used in the reduction are stored in the remaining
C          triangle under the Hessenberg matrix.
C
C        INT contains information on the rows and columns interchanged
C          in the reduction.  Only elements LOW through IGH are used.
C          INT is a one-dimensional INTEGER array, dimensioned INT(IGH).
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  ELMHES
C
      INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
      REAL A(NM,*)
      REAL X,Y
      INTEGER INT(*)
C
C***FIRST EXECUTABLE STATEMENT  ELMHES
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         MM1 = M - 1
         X = 0.0E0
         I = M
C
         DO 100 J = M, IGH
            IF (ABS(A(J,MM1)) .LE. ABS(X)) GO TO 100
            X = A(J,MM1)
            I = J
  100    CONTINUE
C
         INT(M) = I
         IF (I .EQ. M) GO TO 130
C    .......... INTERCHANGE ROWS AND COLUMNS OF A ..........
         DO 110 J = MM1, N
            Y = A(I,J)
            A(I,J) = A(M,J)
            A(M,J) = Y
  110    CONTINUE
C
         DO 120 J = 1, IGH
            Y = A(J,I)
            A(J,I) = A(J,M)
            A(J,M) = Y
  120    CONTINUE
C    .......... END INTERCHANGE ..........
  130    IF (X .EQ. 0.0E0) GO TO 180
         MP1 = M + 1
C
         DO 160 I = MP1, IGH
            Y = A(I,MM1)
            IF (Y .EQ. 0.0E0) GO TO 160
            Y = Y / X
            A(I,MM1) = Y
C
            DO 140 J = M, N
  140       A(I,J) = A(I,J) - Y * A(M,J)
C
            DO 150 J = 1, IGH
  150       A(J,M) = A(J,M) + Y * A(J,I)
C
  160    CONTINUE
C
  180 CONTINUE
C
  200 RETURN
      END
*DECK ELTRAN
      SUBROUTINE ELTRAN (NM, N, LOW, IGH, A, INT, Z)
C***BEGIN PROLOGUE  ELTRAN
C***PURPOSE  Accumulates the stabilized elementary similarity
C            transformations used in the reduction of a real general
C            matrix to upper Hessenberg form by ELMHES.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (ELTRAN-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 ELMTRANS,
C     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C     This subroutine accumulates the stabilized elementary
C     similarity transformations used in the reduction of a
C     REAL GENERAL matrix to upper Hessenberg form by  ELMHES.
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        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix, N.
C
C        A contains the multipliers which were used in the reduction
C          by  ELMHES  in its lower triangle below the subdiagonal.
C          A is a two-dimensional REAL array, dimensioned A(NM,IGH).
C
C        INT contains information on the rows and columns interchanged
C          in the reduction by  ELMHES.  Only elements LOW through IGH
C          are used.  INT is a one-dimensional INTEGER array,
C          dimensioned INT(IGH).
C
C     On OUTPUT
C
C        Z contains the transformation matrix produced in the reduction
C          by  ELMHES.  Z is a two-dimensional REAL array, dimensioned
C          Z(NM,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  (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  ELTRAN
C
      INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
      REAL A(NM,*),Z(NM,*)
      INTEGER INT(*)
C
C***FIRST EXECUTABLE STATEMENT  ELTRAN
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.0E0
C
         Z(I,I) = 1.0E0
   80 CONTINUE
C
      KL = IGH - LOW - 1
      IF (KL .LT. 1) GO TO 200
C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
      DO 140 MM = 1, KL
         MP = IGH - MM
         MP1 = MP + 1
C
         DO 100 I = MP1, IGH
  100    Z(I,MP) = A(I,MP-1)
C
         I = INT(MP)
         IF (I .EQ. MP) GO TO 140
C
         DO 130 J = MP, IGH
            Z(MP,J) = Z(I,J)
            Z(I,J) = 0.0E0
  130    CONTINUE
C
         Z(I,MP) = 1.0E0
  140 CONTINUE
C
  200 RETURN
      END
*DECK ENORM
      REAL FUNCTION ENORM (N, X)
C***BEGIN PROLOGUE  ENORM
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (ENORM-S, DENORM-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     Given an N-vector X, this function calculates the
C     Euclidean norm of X.
C
C     The Euclidean norm is computed by accumulating the sum of
C     squares in three different sums. The sums of squares for the
C     small and large components are scaled so that no overflows
C     occur. Non-destructive underflows are permitted. Underflows
C     and overflows do not occur in the computation of the unscaled
C     sum of squares for the intermediate components.
C     The definitions of small, intermediate and large components
C     depend on two constants, RDWARF and RGIANT. The main
C     restrictions on these constants are that RDWARF**2 not
C     underflow and RGIANT**2 not overflow. The constants
C     given here are suitable for every known computer.
C
C     The function statement is
C
C       REAL FUNCTION ENORM(N,X)
C
C     where
C
C       N is a positive integer input variable.
C
C       X is an input array of length N.
C
C***SEE ALSO  SNLS1, SNLS1E, 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  ENORM
      INTEGER N
      REAL X(*)
      INTEGER I
      REAL AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX,
     1     ZERO
      SAVE ONE, ZERO, RDWARF, RGIANT
      DATA ONE,ZERO,RDWARF,RGIANT /1.0E0,0.0E0,3.834E-20,1.304E19/
C***FIRST EXECUTABLE STATEMENT  ENORM
      S1 = ZERO
      S2 = ZERO
      S3 = ZERO
      X1MAX = ZERO
      X3MAX = ZERO
      FLOATN = N
      AGIANT = RGIANT/FLOATN
      DO 90 I = 1, N
         XABS = ABS(X(I))
         IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70
            IF (XABS .LE. RDWARF) GO TO 30
C
C              SUM FOR LARGE COMPONENTS.
C
               IF (XABS .LE. X1MAX) GO TO 10
                  S1 = ONE + S1*(X1MAX/XABS)**2
                  X1MAX = XABS
                  GO TO 20
   10          CONTINUE
                  S1 = S1 + (XABS/X1MAX)**2
   20          CONTINUE
               GO TO 60
   30       CONTINUE
C
C              SUM FOR SMALL COMPONENTS.
C
               IF (XABS .LE. X3MAX) GO TO 40
                  S3 = ONE + S3*(X3MAX/XABS)**2
                  X3MAX = XABS
                  GO TO 50
   40          CONTINUE
                  IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2
   50          CONTINUE
   60       CONTINUE
            GO TO 80
   70    CONTINUE
C
C           SUM FOR INTERMEDIATE COMPONENTS.
C
            S2 = S2 + XABS**2
   80    CONTINUE
   90    CONTINUE
C
C     CALCULATION OF NORM.
C
      IF (S1 .EQ. ZERO) GO TO 100
         ENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX)
         GO TO 130
  100 CONTINUE
         IF (S2 .EQ. ZERO) GO TO 110
            IF (S2 .GE. X3MAX)
     1         ENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3)))
            IF (S2 .LT. X3MAX)
     1         ENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3)))
            GO TO 120
  110    CONTINUE
            ENORM = X3MAX*SQRT(S3)
  120    CONTINUE
  130 CONTINUE
      RETURN
C
C     LAST CARD OF FUNCTION ENORM.
C
      END
*DECK ERF
      FUNCTION ERF (X)
C***BEGIN PROLOGUE  ERF
C***PURPOSE  Compute the error function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C8A, L5A1E
C***TYPE      SINGLE PRECISION (ERF-S, DERF-D)
C***KEYWORDS  ERF, ERROR FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ERF(X) calculates the single precision error function for
C single precision argument X.
C
C Series for ERF        on the interval  0.          to  1.00000D+00
C                                        with weighted error   7.10E-18
C                                         log weighted error  17.15
C                               significant figures required  16.31
C                                    decimal places required  17.71
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, ERFC, INITS, R1MACH
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   900727  Added EXTERNAL statement.  (WRB)
C   920618  Removed space from variable name.  (RWC, WRB)
C***END PROLOGUE  ERF
      DIMENSION ERFCS(13)
      LOGICAL FIRST
      EXTERNAL ERFC
      SAVE ERFCS, SQRTPI, NTERF, XBIG, SQEPS, FIRST
      DATA ERFCS( 1) /   -.0490461212 34691808E0 /
      DATA ERFCS( 2) /   -.1422612051 0371364E0 /
      DATA ERFCS( 3) /    .0100355821 87599796E0 /
      DATA ERFCS( 4) /   -.0005768764 69976748E0 /
      DATA ERFCS( 5) /    .0000274199 31252196E0 /
      DATA ERFCS( 6) /   -.0000011043 17550734E0 /
      DATA ERFCS( 7) /    .0000000384 88755420E0 /
      DATA ERFCS( 8) /   -.0000000011 80858253E0 /
      DATA ERFCS( 9) /    .0000000000 32334215E0 /
      DATA ERFCS(10) /   -.0000000000 00799101E0 /
      DATA ERFCS(11) /    .0000000000 00017990E0 /
      DATA ERFCS(12) /   -.0000000000 00000371E0 /
      DATA ERFCS(13) /    .0000000000 00000007E0 /
      DATA SQRTPI /1.772453850 9055160E0/
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  ERF
      IF (FIRST) THEN
         NTERF = INITS (ERFCS, 13, 0.1*R1MACH(3))
         XBIG = SQRT(-LOG(SQRTPI*R1MACH(3)))
         SQEPS = SQRT(2.0*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.1.) GO TO 20
C
C ERF(X) = 1. - ERFC(X) FOR -1. .LE. X .LE. 1.
C
      IF (Y.LE.SQEPS) ERF = 2.0*X/SQRTPI
      IF (Y.GT.SQEPS) ERF = X*(1.0 + CSEVL(2.*X**2-1., ERFCS, NTERF))
      RETURN
C
C ERF(X) = 1. - ERFC(X) FOR  ABS(X) .GT. 1.
C
 20   IF (Y.LE.XBIG) ERF = SIGN (1.0-ERFC(Y), X)
      IF (Y.GT.XBIG) ERF = SIGN (1.0, X)
C
      RETURN
      END
*DECK ERFC
      FUNCTION ERFC (X)
C***BEGIN PROLOGUE  ERFC
C***PURPOSE  Compute the complementary error function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C8A, L5A1E
C***TYPE      SINGLE PRECISION (ERFC-S, DERFC-D)
C***KEYWORDS  COMPLEMENTARY ERROR FUNCTION, ERFC, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ERFC(X) calculates the single precision complementary error
C function for single precision argument X.
C
C Series for ERF        on the interval  0.          to  1.00000D+00
C                                        with weighted error   7.10E-18
C                                         log weighted error  17.15
C                               significant figures required  16.31
C                                    decimal places required  17.71
C
C Series for ERFC       on the interval  0.          to  2.50000D-01
C                                        with weighted error   4.81E-17
C                                         log weighted error  16.32
C                        approx significant figures required  15.0
C
C
C Series for ERC2       on the interval  2.50000D-01 to  1.00000D+00
C                                        with weighted error   5.22E-17
C                                         log weighted error  16.28
C                        approx significant figures required  15.0
C                                    decimal places required  16.96
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, 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   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  ERFC
      DIMENSION ERFCS(13), ERFCCS(24), ERC2CS(23)
      LOGICAL FIRST
      SAVE ERFCS, ERC2CS, ERFCCS, SQRTPI, NTERF, NTERFC,
     1 NTERC2, XSML, XMAX, SQEPS, FIRST
      DATA ERFCS( 1) /   -.0490461212 34691808E0 /
      DATA ERFCS( 2) /   -.1422612051 0371364E0 /
      DATA ERFCS( 3) /    .0100355821 87599796E0 /
      DATA ERFCS( 4) /   -.0005768764 69976748E0 /
      DATA ERFCS( 5) /    .0000274199 31252196E0 /
      DATA ERFCS( 6) /   -.0000011043 17550734E0 /
      DATA ERFCS( 7) /    .0000000384 88755420E0 /
      DATA ERFCS( 8) /   -.0000000011 80858253E0 /
      DATA ERFCS( 9) /    .0000000000 32334215E0 /
      DATA ERFCS(10) /   -.0000000000 00799101E0 /
      DATA ERFCS(11) /    .0000000000 00017990E0 /
      DATA ERFCS(12) /   -.0000000000 00000371E0 /
      DATA ERFCS(13) /    .0000000000 00000007E0 /
      DATA ERC2CS( 1) /   -.0696013466 02309501E0 /
      DATA ERC2CS( 2) /   -.0411013393 62620893E0 /
      DATA ERC2CS( 3) /    .0039144958 66689626E0 /
      DATA ERC2CS( 4) /   -.0004906395 65054897E0 /
      DATA ERC2CS( 5) /    .0000715747 90013770E0 /
      DATA ERC2CS( 6) /   -.0000115307 16341312E0 /
      DATA ERC2CS( 7) /    .0000019946 70590201E0 /
      DATA ERC2CS( 8) /   -.0000003642 66647159E0 /
      DATA ERC2CS( 9) /    .0000000694 43726100E0 /
      DATA ERC2CS(10) /   -.0000000137 12209021E0 /
      DATA ERC2CS(11) /    .0000000027 88389661E0 /
      DATA ERC2CS(12) /   -.0000000005 81416472E0 /
      DATA ERC2CS(13) /    .0000000001 23892049E0 /
      DATA ERC2CS(14) /   -.0000000000 26906391E0 /
      DATA ERC2CS(15) /    .0000000000 05942614E0 /
      DATA ERC2CS(16) /   -.0000000000 01332386E0 /
      DATA ERC2CS(17) /    .0000000000 00302804E0 /
      DATA ERC2CS(18) /   -.0000000000 00069666E0 /
      DATA ERC2CS(19) /    .0000000000 00016208E0 /
      DATA ERC2CS(20) /   -.0000000000 00003809E0 /
      DATA ERC2CS(21) /    .0000000000 00000904E0 /
      DATA ERC2CS(22) /   -.0000000000 00000216E0 /
      DATA ERC2CS(23) /    .0000000000 00000052E0 /
      DATA ERFCCS( 1) /   0.0715179310 202925E0 /
      DATA ERFCCS( 2) /   -.0265324343 37606719E0 /
      DATA ERFCCS( 3) /    .0017111539 77920853E0 /
      DATA ERFCCS( 4) /   -.0001637516 63458512E0 /
      DATA ERFCCS( 5) /    .0000198712 93500549E0 /
      DATA ERFCCS( 6) /   -.0000028437 12412769E0 /
      DATA ERFCCS( 7) /    .0000004606 16130901E0 /
      DATA ERFCCS( 8) /   -.0000000822 77530261E0 /
      DATA ERFCCS( 9) /    .0000000159 21418724E0 /
      DATA ERFCCS(10) /   -.0000000032 95071356E0 /
      DATA ERFCCS(11) /    .0000000007 22343973E0 /
      DATA ERFCCS(12) /   -.0000000001 66485584E0 /
      DATA ERFCCS(13) /    .0000000000 40103931E0 /
      DATA ERFCCS(14) /   -.0000000000 10048164E0 /
      DATA ERFCCS(15) /    .0000000000 02608272E0 /
      DATA ERFCCS(16) /   -.0000000000 00699105E0 /
      DATA ERFCCS(17) /    .0000000000 00192946E0 /
      DATA ERFCCS(18) /   -.0000000000 00054704E0 /
      DATA ERFCCS(19) /    .0000000000 00015901E0 /
      DATA ERFCCS(20) /   -.0000000000 00004729E0 /
      DATA ERFCCS(21) /    .0000000000 00001432E0 /
      DATA ERFCCS(22) /   -.0000000000 00000439E0 /
      DATA ERFCCS(23) /    .0000000000 00000138E0 /
      DATA ERFCCS(24) /   -.0000000000 00000048E0 /
      DATA SQRTPI /1.772453850 9055160E0/
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  ERFC
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NTERF = INITS (ERFCS, 13, ETA)
         NTERFC = INITS (ERFCCS, 24, ETA)
         NTERC2 = INITS (ERC2CS, 23, ETA)
C
         XSML = -SQRT (-LOG(SQRTPI*R1MACH(3)))
         TXMAX = SQRT (-LOG(SQRTPI*R1MACH(1)))
         XMAX = TXMAX - 0.5*LOG(TXMAX)/TXMAX - 0.01
         SQEPS = SQRT (2.0*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GT.XSML) GO TO 20
C
C ERFC(X) = 1.0 - ERF(X) FOR X .LT. XSML
C
      ERFC = 2.
      RETURN
C
 20   IF (X.GT.XMAX) GO TO 40
      Y = ABS(X)
      IF (Y.GT.1.0) GO TO 30
C
C ERFC(X) = 1.0 - ERF(X) FOR -1. .LE. X .LE. 1.
C
      IF (Y.LT.SQEPS) ERFC = 1.0 - 2.0*X/SQRTPI
      IF (Y.GE.SQEPS) ERFC = 1.0 -
     1  X*(1.0 + CSEVL (2.*X*X-1., ERFCS, NTERF) )
      RETURN
C
C ERFC(X) = 1.0 - ERF(X) FOR 1. .LT. ABS(X) .LE. XMAX
C
 30   Y = Y*Y
      IF (Y.LE.4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL ((8./Y-5.)/3.,
     1  ERC2CS, NTERC2) )
      IF (Y.GT.4.) ERFC = EXP(-Y)/ABS(X) * (0.5 + CSEVL (8./Y-1.,
     1  ERFCCS, NTERFC) )
      IF (X.LT.0.) ERFC = 2.0 - ERFC
      RETURN
C
 40   CALL XERMSG ('SLATEC', 'ERFC', 'X SO BIG ERFC UNDERFLOWS', 1, 1)
      ERFC = 0.
      RETURN
C
      END
*DECK EXBVP
      SUBROUTINE EXBVP (Y, NROWY, XPTS, A, NROWA, ALPHA, B, NROWB, BETA,
     +   IFLAG, WORK, IWORK)
C***BEGIN PROLOGUE  EXBVP
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (EXBVP-S, DEXBVP-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C  This subroutine is used to execute the basic technique for solving
C  the two-point boundary value problem
C
C***SEE ALSO  BVSUP
C***ROUTINES CALLED  BVPOR, XERMSG
C***COMMON BLOCKS    ML15TO, ML17BW, ML18JR, ML5MCO, ML8SZ
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  EXBVP
C
      DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*),BETA(*),
     1         WORK(*),IWORK(*),XPTS(*)
      CHARACTER*8 XERN1, XERN2
C
C     ****************************************************************
C
      COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC
      COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ,
     1                INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC,
     2                ICOCO
      COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
     1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
      COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9,
     1                K10,K11,L1,L2,KKKINT,LLLINT
C
      COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR
C
C***FIRST EXECUTABLE STATEMENT  EXBVP
      KOTC = 1
      IEXP = 0
      IF (IWORK(7) .EQ. -1) IEXP = IWORK(8)
C
C     COMPUTE ORTHONORMALIZATION TOLERANCES.
C
   10 TOL = 10.0**((-LPAR-IEXP)*2)
C
      IWORK(8) = IEXP
      MXNON = IWORK(2)
C
C **********************************************************************
C **********************************************************************
C
      CALL BVPOR(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B,
     1           NROWB,BETA,NFC,IFLAG,WORK(1),MXNON,WORK(K1),NTP,
     2           IWORK(18),WORK(K2),IWORK(16),WORK(K3),WORK(K4),
     3           WORK(K5),WORK(K6),WORK(K7),WORK(K8),WORK(K9),
     4           WORK(K10),IWORK(L1),NFCC)
C
C **********************************************************************
C **********************************************************************
C     IF MGSBV RETURNS WITH MESSAGE OF DEPENDENT VECTORS, WE REDUCE
C     ORTHONORMALIZATION TOLERANCE AND TRY AGAIN. THIS IS DONE
C     A MAXIMUM OF 2 TIMES.
C
      IF (IFLAG .NE. 30) GO TO 20
      IF (KOTC .EQ. 3  .OR.  NOPG .EQ. 1) GO TO 30
      KOTC = KOTC + 1
      IEXP = IEXP - 2
      GO TO 10
C
C **********************************************************************
C     IF BVPOR RETURNS MESSAGE THAT THE MAXIMUM NUMBER OF
C     ORTHONORMALIZATIONS HAS BEEN ATTAINED AND WE CANNOT CONTINUE, THEN
C     WE ESTIMATE THE NEW STORAGE REQUIREMENTS IN ORDER TO SOLVE PROBLEM
C
   20 IF (IFLAG .NE. 13) GO TO 30
      XL = ABS(XEND-XBEG)
      ZQUIT = ABS(X-XBEG)
      INC = 1.5 * XL/ZQUIT * (MXNON+1)
      IF (NDISK .NE. 1) THEN
         NSAFW = INC*KKKZPW + NEEDW
         NSAFIW = INC*NFCC + NEEDIW
      ELSE
         NSAFW = NEEDW + INC
         NSAFIW = NEEDIW
      ENDIF
C
      WRITE (XERN1, '(I8)') NSAFW
      WRITE (XERN2, '(I8)') NSAFIW
      CALL XERMSG ('SLATEC', 'EXBVP',
     *   'IN BVSUP, PREDICTED STORAGE ALLOCATION FOR WORK ARRAY IS ' //
     *   XERN1 // ', PREDICTED STORAGE ALLOCATION FOR IWORK ARRAY IS '
     *   // XERN2, 1, 0)
C
   30 IWORK(1) = MXNON
      RETURN
      END
*DECK EXINT
      SUBROUTINE EXINT (X, N, KODE, M, TOL, EN, NZ, IERR)
C***BEGIN PROLOGUE  EXINT
C***PURPOSE  Compute an M member sequence of exponential integrals
C            E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0.
C***LIBRARY   SLATEC
C***CATEGORY  C5
C***TYPE      SINGLE PRECISION (EXINT-S, DEXINT-D)
C***KEYWORDS  EXPONENTIAL INTEGRAL, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C         EXINT computes M member sequences of exponential integrals
C         E(N+K,X), K=0,1,...,M-1 for N .GE. 1 and X .GE. 0.  The
C         exponential integral is defined by
C
C         E(N,X)=integral on (1,infinity) of EXP(-XT)/T**N
C
C         where X=0.0 and N=1 cannot occur simultaneously.  Formulas
C         and notation are found in the NBS Handbook of Mathematical
C         Functions (ref. 1).
C
C         The power series is implemented for X .LE. XCUT and the
C         confluent hypergeometric representation
C
C                     E(A,X) = EXP(-X)*(X**(A-1))*U(A,A,X)
C
C         is computed for X .GT. XCUT.  Since sequences are computed in
C         a stable fashion by recurring away from X, A is selected as
C         the integer closest to X within the constraint N .LE. A .LE.
C         N+M-1.  For the U computation, A is further modified to be the
C         nearest even integer.  Indices are carried forward or
C         backward by the two term recursion relation
C
C                     K*E(K+1,X) + X*E(K,X) = EXP(-X)
C
C         once E(A,X) is computed.  The U function is computed by means
C         of the backward recursive Miller algorithm applied to the
C         three term contiguous relation for U(A+K,A,X), K=0,1,...
C         This produces accurate ratios and determines U(A+K,A,X), and
C         hence E(A,X), to within a multiplicative constant C.
C         Another contiguous relation applied to C*U(A,A,X) and
C         C*U(A+1,A,X) gets C*U(A+1,A+1,X), a quantity proportional to
C         E(A+1,X).  The normalizing constant C is obtained from the
C         two term recursion relation above with K=A.
C
C     Description of Arguments
C
C         Input
C           X       X .GT. 0.0 for N=1 and  X .GE. 0.0 for N .GE. 2
C           N       order of the first member of the sequence, N .GE. 1
C                   (X=0.0 and N=1 is an error)
C           KODE    a selection parameter for scaled values
C                   KODE=1   returns        E(N+K,X), K=0,1,...,M-1.
C                       =2   returns EXP(X)*E(N+K,X), K=0,1,...,M-1.
C           M       number of exponential integrals in the sequence,
C                   M .GE. 1
C           TOL     relative accuracy wanted, ETOL .LE. TOL .LE. 0.1
C                   ETOL = single precision unit roundoff = R1MACH(4)
C
C         Output
C           EN      a vector of dimension at least M containing values
C                   EN(K) = E(N+K-1,X) or EXP(X)*E(N+K-1,X), K=1,M
C                   depending on KODE
C           NZ      underflow indicator
C                   NZ=0   a normal return
C                   NZ=M   X exceeds XLIM and an underflow occurs.
C                          EN(K)=0.0E0 , K=1,M returned on KODE=1
C           IERR    error flag
C                   IERR=0, normal return, computation completed
C                   IERR=1, input error,   no computation
C                   IERR=2, error,         no computation
C                           algorithm termination condition not met
C
C***REFERENCES  M. Abramowitz and I. A. Stegun, Handbook of
C                 Mathematical Functions, NBS AMS Series 55, U.S. Dept.
C                 of Commerce, 1955.
C               D. E. Amos, Computation of exponential integrals, ACM
C                 Transactions on Mathematical Software 6, (1980),
C                 pp. 365-377 and pp. 420-428.
C***ROUTINES CALLED  I1MACH, PSIXN, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   800501  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   910408  Updated the REFERENCES section.  (WRB)
C   920207  Updated with code with a revision date of 880811 from
C           D. Amos.  Included correction of argument list.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  EXINT
      REAL             A,AA,AAMS,AH,AK,AT,B,BK,BT,CC,CNORM,CT,EM,EMX,EN,
     1                 ETOL,FNM,FX,PT,P1,P2,S,TOL,TX,X,XCUT,XLIM,XTOL,Y,
     2                 YT,Y1,Y2
      REAL             R1MACH,PSIXN
      INTEGER I,IC,ICASE,ICT,IERR,IK,IND,IX,I1M,JSET,K,KK,KN,KODE,KS,M,
     1        ML,MU,N,ND,NM,NZ
      INTEGER I1MACH
      DIMENSION EN(*), A(99), B(99), Y(2)
C***FIRST EXECUTABLE STATEMENT  EXINT
      IERR = 0
      NZ = 0
      ETOL = MAX(R1MACH(4),0.5E-18)
      IF (X.LT.0.0E0) IERR = 1
      IF (N.LT.1) IERR = 1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR = 1
      IF (M.LT.1) IERR = 1
      IF (TOL.LT.ETOL .OR. TOL.GT.0.1E0) IERR = 1
      IF (X.EQ.0.0E0 .AND. N.EQ.1) IERR = 1
      IF (IERR.NE.0) RETURN
      I1M = -I1MACH(12)
      PT = 2.3026E0*R1MACH(5)*I1M
      XLIM = PT - 6.907755E0
      BT = PT + (N+M-1)
      IF (BT.GT.1000.0E0) XLIM = PT - LOG(BT)
C
      XCUT = 2.0E0
      IF (ETOL.GT.2.0E-7) XCUT = 1.0E0
      IF (X.GT.XCUT) GO TO 100
      IF (X.EQ.0.0E0 .AND. N.GT.1) GO TO 80
C-----------------------------------------------------------------------
C     SERIES FOR E(N,X) FOR X.LE.XCUT
C-----------------------------------------------------------------------
      TX = X + 0.5E0
      IX = TX
C-----------------------------------------------------------------------
C     ICASE=1 MEANS INTEGER CLOSEST TO X IS 2 AND N=1
C     ICASE=2 MEANS INTEGER CLOSEST TO X IS 0,1, OR 2 AND N.GE.2
C-----------------------------------------------------------------------
      ICASE = 2
      IF (IX.GT.N) ICASE = 1
      NM = N - ICASE + 1
      ND = NM + 1
      IND = 3 - ICASE
      MU = M - IND
      ML = 1
      KS = ND
      FNM = NM
      S = 0.0E0
      XTOL = 3.0E0*TOL
      IF (ND.EQ.1) GO TO 10
      XTOL = 0.3333E0*TOL
      S = 1.0E0/FNM
   10 CONTINUE
      AA = 1.0E0
      AK = 1.0E0
      IC = 35
      IF (X.LT.ETOL) IC = 1
      DO 50 I=1,IC
        AA = -AA*X/AK
        IF (I.EQ.NM) GO TO 30
        S = S - AA/(AK-FNM)
        IF (ABS(AA).LE.XTOL*ABS(S)) GO TO 20
        AK = AK + 1.0E0
        GO TO 50
   20   CONTINUE
        IF (I.LT.2) GO TO 40
        IF (ND-2.GT.I .OR. I.GT.ND-1) GO TO 60
        AK = AK + 1.0E0
        GO TO 50
   30   S = S + AA*(-LOG(X)+PSIXN(ND))
        XTOL = 3.0E0*TOL
   40   AK = AK + 1.0E0
   50 CONTINUE
      IF (IC.NE.1) GO TO 340
   60 IF (ND.EQ.1) S = S + (-LOG(X)+PSIXN(1))
      IF (KODE.EQ.2) S = S*EXP(X)
      EN(1) = S
      EMX = 1.0E0
      IF (M.EQ.1) GO TO 70
      EN(IND) = S
      AA = KS
      IF (KODE.EQ.1) EMX = EXP(-X)
      GO TO (220, 240), ICASE
   70 IF (ICASE.EQ.2) RETURN
      IF (KODE.EQ.1) EMX = EXP(-X)
      EN(1) = (EMX-S)/X
      RETURN
   80 CONTINUE
      DO 90 I=1,M
        EN(I) = 1.0E0/(N+I-2)
   90 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     BACKWARD RECURSIVE MILLER ALGORITHM FOR
C              E(N,X)=EXP(-X)*(X**(N-1))*U(N,N,X)
C     WITH RECURSION AWAY FROM N=INTEGER CLOSEST TO X.
C     U(A,B,X) IS THE SECOND CONFLUENT HYPERGEOMETRIC FUNCTION
C-----------------------------------------------------------------------
  100 CONTINUE
      EMX = 1.0E0
      IF (KODE.EQ.2) GO TO 130
      IF (X.LE.XLIM) GO TO 120
      NZ = M
      DO 110 I=1,M
        EN(I) = 0.0E0
  110 CONTINUE
      RETURN
  120 EMX = EXP(-X)
  130 CONTINUE
      IX = X+0.5E0
      KN = N + M - 1
      IF (KN.LE.IX) GO TO 140
      IF (N.LT.IX .AND. IX.LT.KN) GO TO 170
      IF (N.GE.IX) GO TO 160
      GO TO 340
  140 ICASE = 1
      KS = KN
      ML = M - 1
      MU = -1
      IND = M
      IF (KN.GT.1) GO TO 180
  150 KS = 2
      ICASE = 3
      GO TO 180
  160 ICASE = 2
      IND = 1
      KS = N
      MU = M - 1
      IF (N.GT.1) GO TO 180
      IF (KN.EQ.1) GO TO 150
      IX = 2
  170 ICASE = 1
      KS = IX
      ML = IX - N
      IND = ML + 1
      MU = KN - IX
  180 CONTINUE
      IK = KS/2
      AH = IK
      JSET = 1 + KS - (IK+IK)
C-----------------------------------------------------------------------
C     START COMPUTATION FOR
C              EN(IND) = C*U( A , A ,X)    JSET=1
C              EN(IND) = C*U(A+1,A+1,X)    JSET=2
C     FOR AN EVEN INTEGER A.
C-----------------------------------------------------------------------
      IC = 0
      AA = AH + AH
      AAMS = AA - 1.0E0
      AAMS = AAMS*AAMS
      TX = X + X
      FX = TX + TX
      AK = AH
      XTOL = TOL
      IF (TOL.LE.1.0E-3) XTOL = 20.0E0*TOL
      CT = AAMS + FX*AH
      EM = (AH+1.0E0)/((X+AA)*XTOL*SQRT(CT))
      BK = AA
      CC = AH*AH
C-----------------------------------------------------------------------
C     FORWARD RECURSION FOR P(IC),P(IC+1) AND INDEX IC FOR BACKWARD
C     RECURSION
C-----------------------------------------------------------------------
      P1 = 0.0E0
      P2 = 1.0E0
  190 CONTINUE
      IF (IC.EQ.99) GO TO 340
      IC = IC + 1
      AK = AK + 1.0E0
      AT = BK/(BK+AK+CC+IC)
      BK = BK + AK + AK
      A(IC) = AT
      BT = (AK+AK+X)/(AK+1.0E0)
      B(IC) = BT
      PT = P2
      P2 = BT*P2 - AT*P1
      P1 = PT
      CT = CT + FX
      EM = EM*AT*(1.0E0-TX/CT)
      IF (EM*(AK+1.0E0).GT.P1*P1) GO TO 190
      ICT = IC
      KK = IC + 1
      BT = TX/(CT+FX)
      Y2 = (BK/(BK+CC+KK))*(P1/P2)*(1.0E0-BT+0.375E0*BT*BT)
      Y1 = 1.0E0
C-----------------------------------------------------------------------
C     BACKWARD RECURRENCE FOR
C              Y1=             C*U( A ,A,X)
C              Y2= C*(A/(1+A/2))*U(A+1,A,X)
C-----------------------------------------------------------------------
      DO 200 K=1,ICT
        KK = KK - 1
        YT = Y1
        Y1 = (B(KK)*Y1-Y2)/A(KK)
        Y2 = YT
  200 CONTINUE
C-----------------------------------------------------------------------
C     THE CONTIGUOUS RELATION
C              X*U(B,C+1,X)=(C-B)*U(B,C,X)+U(B-1,C,X)
C     WITH  B=A+1 , C=A IS USED FOR
C              Y(2) = C * U(A+1,A+1,X)
C     X IS INCORPORATED INTO THE NORMALIZING RELATION
C-----------------------------------------------------------------------
      PT = Y2/Y1
      CNORM = 1.0E0 - PT*(AH+1.0E0)/AA
      Y(1) = 1.0E0/(CNORM*AA+X)
      Y(2) = CNORM*Y(1)
      IF (ICASE.EQ.3) GO TO 210
      EN(IND) = EMX*Y(JSET)
      IF (M.EQ.1) RETURN
      AA = KS
      GO TO (220, 240), ICASE
C-----------------------------------------------------------------------
C     RECURSION SECTION  N*E(N+1,X) + X*E(N,X)=EMX
C-----------------------------------------------------------------------
  210 EN(1) = EMX*(1.0E0-Y(1))/X
      RETURN
  220 K = IND - 1
      DO 230 I=1,ML
        AA = AA - 1.0E0
        EN(K) = (EMX-AA*EN(K+1))/X
        K = K - 1
  230 CONTINUE
      IF (MU.LE.0) RETURN
      AA = KS
  240 K = IND
      DO 250 I=1,MU
        EN(K+1) = (EMX-X*EN(K))/AA
        AA = AA + 1.0E0
        K = K + 1
  250 CONTINUE
      RETURN
  340 CONTINUE
      IERR = 2
      RETURN
      END
*DECK EXPREL
      FUNCTION EXPREL (X)
C***BEGIN PROLOGUE  EXPREL
C***PURPOSE  Calculate the relative error exponential (EXP(X)-1)/X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      SINGLE PRECISION (EXPREL-S, DEXPRL-D, CEXPRL-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate  EXPREL(X) = (EXP(X) - 1.0) / X.   For small ABS(X) the
C Taylor series is used.  If X is negative, the reflection formula
C         EXPREL(X) = EXP(X) * EXPREL(ABS(X))
C may be used.  This reflection formula will be of use when the
C evaluation for small ABS(X) is done by Chebyshev series rather than
C Taylor series.  EXPREL and X are single precision.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH
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***END PROLOGUE  EXPREL
      LOGICAL FIRST
      SAVE NTERMS, XBND, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  EXPREL
      IF (FIRST) THEN
         ALNEPS = LOG(R1MACH(3))
         XN = 3.72 - 0.3*ALNEPS
         XLN = LOG((XN+1.0)/1.36)
         NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36) + 1.5
         XBND = R1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      ABSX = ABS(X)
      IF (ABSX.GT.0.5) EXPREL = (EXP(X) - 1.0) / X
      IF (ABSX.GT.0.5) RETURN
C
      EXPREL = 1.0
      IF (ABSX.LT.XBND) RETURN
C
      EXPREL = 0.0
      DO 20 I=1,NTERMS
        EXPREL = 1.0 + EXPREL*X/(NTERMS+2-I)
 20   CONTINUE
C
      RETURN
      END
*DECK EZFFT1
      SUBROUTINE EZFFT1 (N, WA, IFAC)
C***BEGIN PROLOGUE  EZFFT1
C***SUBSIDIARY
C***PURPOSE  EZFFTI calls EZFFT1 with appropriate work array
C            partitioning.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (EZFFT1-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   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  EZFFT1
      DIMENSION WA(*), IFAC(*), NTRYH(4)
      SAVE NTRYH
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
C***FIRST EXECUTABLE STATEMENT  EZFFT1
      TPI = 8.*ATAN(1.)
      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
      ARGH = TPI/N
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 111 K1=1,NFM1
         IP = IFAC(K1+2)
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         ARG1 = L1*ARGH
         CH1 = 1.
         SH1 = 0.
         DCH1 = COS(ARG1)
         DSH1 = SIN(ARG1)
         DO 110 J=1,IPM
            CH1H = DCH1*CH1-DSH1*SH1
            SH1 = DCH1*SH1+DSH1*CH1
            CH1 = CH1H
            I = IS+2
            WA(I-1) = CH1
            WA(I) = SH1
            IF (IDO .LT. 5) GO TO 109
            DO 108 II=5,IDO,2
               I = I+2
               WA(I-1) = CH1*WA(I-3)-SH1*WA(I-2)
               WA(I) = CH1*WA(I-2)+SH1*WA(I-3)
  108       CONTINUE
  109       IS = IS+IDO
  110    CONTINUE
         L1 = L2
  111 CONTINUE
      RETURN
      END
*DECK EZFFTB
      SUBROUTINE EZFFTB (N, R, AZERO, A, B, WSAVE)
C***BEGIN PROLOGUE  EZFFTB
C***PURPOSE  A simplified real, periodic, backward fast Fourier
C            transform.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (EZFFTB-S)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine EZFFTB computes a real periodic sequence from its
C  Fourier coefficients (Fourier synthesis).  The transform is
C  defined below at Output Parameter R.  EZFFTB is a simplified
C  but slower version of RFFTB.
C
C  Input Parameters
C
C  N       the length of the output array R.  The method is most
C          efficient when N is the product of small primes.
C
C  AZERO   the constant Fourier coefficient
C
C  A,B     arrays which contain the remaining Fourier coefficients.
C          These arrays are not destroyed.
C
C          The length of these arrays depends on whether N is even or
C          odd.
C
C          If N is even, N/2    locations are required.
C          If N is odd, (N-1)/2 locations are required
C
C  WSAVE   a work array which must be dimensioned at least 3*N+15
C          in the program that calls EZFFTB.  The WSAVE array must be
C          initialized by calling subroutine EZFFTI(N,WSAVE), and a
C          different WSAVE array must be used for each different
C          value of N.  This initialization does not have to be
C          repeated so long as N remains unchanged.  Thus subsequent
C          transforms can be obtained faster than the first.
C          The same WSAVE array can be used by EZFFTF and EZFFTB.
C
C  Output Parameters
C
C  R       if N is even, define KMAX=N/2
C          if N is odd,  define KMAX=(N-1)/2
C
C          Then for I=1,...,N
C
C               R(I)=AZERO plus the sum from K=1 to K=KMAX of
C
C               A(K)*COS(K*(I-1)*2*PI/N)+B(K)*SIN(K*(I-1)*2*PI/N)
C
C  ********************* Complex Notation **************************
C
C          For J=1,...,N
C
C          R(J) equals the sum from K=-KMAX to K=KMAX of
C
C               C(K)*EXP(I*K*(J-1)*2*PI/N)
C
C          where
C
C               C(K) = .5*CMPLX(A(K),-B(K))   for K=1,...,KMAX
C
C               C(-K) = CONJG(C(K))
C
C               C(0) = AZERO
C
C                    and I=SQRT(-1)
C
C  *************** Amplitude - Phase Notation ***********************
C
C          For I=1,...,N
C
C          R(I) equals AZERO plus the sum from K=1 to K=KMAX of
C
C               ALPHA(K)*COS(K*(I-1)*2*PI/N+BETA(K))
C
C          where
C
C               ALPHA(K) = SQRT(A(K)*A(K)+B(K)*B(K))
C
C               COS(BETA(K))=A(K)/ALPHA(K)
C
C               SIN(BETA(K))=-B(K)/ALPHA(K)
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  RFFTB
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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  EZFFTB
      DIMENSION R(*), A(*), B(*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  EZFFTB
      IF (N-2) 101,102,103
  101 R(1) = AZERO
      RETURN
  102 R(1) = AZERO+A(1)
      R(2) = AZERO-A(1)
      RETURN
  103 NS2 = (N-1)/2
      DO 104 I=1,NS2
         R(2*I) = .5*A(I)
         R(2*I+1) = -.5*B(I)
  104 CONTINUE
      R(1) = AZERO
      IF (MOD(N,2) .EQ. 0) R(N) = A(NS2+1)
      CALL RFFTB (N,R,WSAVE(N+1))
      RETURN
      END
*DECK EZFFTF
      SUBROUTINE EZFFTF (N, R, AZERO, A, B, WSAVE)
C***BEGIN PROLOGUE  EZFFTF
C***PURPOSE  Compute a simplified real, periodic, fast Fourier forward
C            transform.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (EZFFTF-S)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine EZFFTF computes the Fourier coefficients of a real
C  periodic sequence (Fourier analysis).  The transform is defined
C  below at Output Parameters AZERO, A and B.  EZFFTF is a simplified
C  but slower version of RFFTF.
C
C  Input Parameters
C
C  N       the length of the array R to be transformed.  The method
C          is most efficient when N is the product of small primes.
C
C  R       a real array of length N which contains the sequence
C          to be transformed.  R is not destroyed.
C
C
C  WSAVE   a work array which must be dimensioned at least 3*N+15
C          in the program that calls EZFFTF.  The WSAVE array must be
C          initialized by calling subroutine EZFFTI(N,WSAVE), and a
C          different WSAVE array must be used for each different
C          value of N.  This initialization does not have to be
C          repeated so long as N remains unchanged.  Thus subsequent
C          transforms can be obtained faster than the first.
C          The same WSAVE array can be used by EZFFTF and EZFFTB.
C
C  Output Parameters
C
C  AZERO   the sum from I=1 to I=N of R(I)/N
C
C  A,B     for N even B(N/2)=0. and A(N/2) is the sum from I=1 to
C          I=N of (-1)**(I-1)*R(I)/N
C
C          for N even define KMAX=N/2-1
C          for N odd  define KMAX=(N-1)/2
C
C          then for  K=1,...,KMAX
C
C               A(K) equals the sum from I=1 to I=N of
C
C                    2./N*R(I)*COS(K*(I-1)*2*PI/N)
C
C               B(K) equals the sum from I=1 to I=N of
C
C                    2./N*R(I)*SIN(K*(I-1)*2*PI/N)
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  RFFTF
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.
C   881128  Modified by Dick Valent to meet prologue standards.
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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  EZFFTF
      DIMENSION R(*), A(*), B(*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  EZFFTF
      IF (N-2) 101,102,103
  101 AZERO = R(1)
      RETURN
  102 AZERO = .5*(R(1)+R(2))
      A(1) = .5*(R(1)-R(2))
      RETURN
  103 DO 104 I=1,N
         WSAVE(I) = R(I)
  104 CONTINUE
      CALL RFFTF (N,WSAVE,WSAVE(N+1))
      CF = 2./N
      CFM = -CF
      AZERO = .5*CF*WSAVE(1)
      NS2 = (N+1)/2
      NS2M = NS2-1
      DO 105 I=1,NS2M
         A(I) = CF*WSAVE(2*I)
         B(I) = CFM*WSAVE(2*I+1)
  105 CONTINUE
      IF (MOD(N,2) .EQ. 0) A(NS2) = .5*CF*WSAVE(N)
      RETURN
      END
*DECK EZFFTI
      SUBROUTINE EZFFTI (N, WSAVE)
C***BEGIN PROLOGUE  EZFFTI
C***PURPOSE  Initialize a work array for EZFFTF and EZFFTB.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (EZFFTI-S)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine EZFFTI initializes the work array WSAVE which is used in
C  both EZFFTF and EZFFTB.  The prime factorization of N together with
C  a tabulation of the trigonometric functions are computed and
C  stored in WSAVE.
C
C  Input Parameter
C
C  N       the length of the sequence to be transformed.
C
C  Output Parameter
C
C  WSAVE   a work array which must be dimensioned at least 3*N+15.
C          The same work array can be used for both EZFFTF and EZFFTB
C          as long as N remains unchanged.  Different WSAVE arrays
C          are required for different values of N.
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  EZFFT1
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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  EZFFTI
      DIMENSION WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  EZFFTI
      IF (N .EQ. 1) RETURN
      CALL EZFFT1 (N,WSAVE(2*N+1),WSAVE(3*N+1))
      RETURN
      END
