      INTEGER FUNCTION IPMPAR (I)
C-----------------------------------------------------------------------
C
C     IPMPAR PROVIDES THE INTEGER MACHINE CONSTANTS FOR THE COMPUTER
C     THAT IS USED. IT IS ASSUMED THAT THE ARGUMENT I IS AN INTEGER
C     HAVING ONE OF THE VALUES 1-10. IPMPAR(I) HAS THE VALUE ...
C
C  INTEGERS.
C
C     ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM
C
C               SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) )
C
C               WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1.
C
C     IPMPAR(1) = A, THE BASE.
C
C     IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS.
C
C     IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE.
C
C  FLOATING-POINT NUMBERS.
C
C     IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING
C     POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE
C     NONZERO NUMBERS ARE REPRESENTED IN THE FORM
C
C               SIGN (B**E) * (X(1)/B + ... + X(M)/B**M)
C
C               WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M,
C               X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX.
C
C     IPMPAR(4) = B, THE BASE.
C
C  SINGLE-PRECISION
C
C     IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS.
C
C     IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E.
C
C     IPMPAR(7) = EMAX, THE LARGEST EXPONENT E.
C
C  DOUBLE-PRECISION
C
C     IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS.
C
C     IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E.
C
C     IPMPAR(10) = EMAX, THE LARGEST EXPONENT E.
C
C-----------------------------------------------------------------------
C
C     TO DEFINE THIS FUNCTION FOR THE COMPUTER BEING USED, ACTIVATE
C     THE DATA STATMENTS FOR THE COMPUTER BY REMOVING THE C FROM
C     COLUMN 1. (ALL THE OTHER DATA STATEMENTS SHOULD HAVE C IN
C     COLUMN 1.)
C
C     IF DATA STATEMENTS ARE NOT GIVEN FOR THE COMPUTER BEING USED,
C     THEN THE FORTRAN MANUAL FOR THE COMPUTER NORMALLY GIVES THE
C     CONSTANTS IPMPAR(1), IPMPAR(2), AND IPMPAR(3) FOR THE INTEGER
C     ARITHMETIC. HOWEVER, HELP MAY BE NEEDED TO OBTAIN THE CONSTANTS
C     IPMPAR(4),...,IPMPAR(10) FOR THE SINGLE AND DOUBLE PRECISION
C     ARITHMETICS. THE SUBROUTINES MACH AND RADIX ARE PROVIDED FOR
C     THIS PURPOSE.
C
C-----------------------------------------------------------------------
C
C     IPMPAR IS AN ADAPTATION OF THE FUNCTION I1MACH, WRITTEN BY
C     P.A. FOX, A.D. HALL, AND N.L. SCHRYER (BELL LABORATORIES).
C     IPMPAR WAS FORMED BY A.H. MORRIS (NSWC). THE CONSTANTS ARE
C     FROM BELL LABORATORIES, NSWC, AND OTHER SOURCES.
C
C-----------------------------------------------------------------------
      INTEGER IMACH(10)
C
C     MACHINE CONSTANTS FOR THE ALLIANT FX/8.
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -125 /
C     DATA IMACH( 7) /   128 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1021 /
C     DATA IMACH(10) /  1024 /
C
C     MACHINE CONSTANTS FOR THE AMDAHL MACHINES.
C
C     DATA IMACH( 1) /    2 /
C     DATA IMACH( 2) /   31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /   16 /
C     DATA IMACH( 5) /    6 /
C     DATA IMACH( 6) /  -64 /
C     DATA IMACH( 7) /   63 /
C     DATA IMACH( 8) /   14 /
C     DATA IMACH( 9) /  -64 /
C     DATA IMACH(10) /   63 /
C
C     MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T
C     PC 7300, AND AT&T 6300.
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -125 /
C     DATA IMACH( 7) /   128 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1021 /
C     DATA IMACH(10) /  1024 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C     DATA IMACH( 1) /    2 /
C     DATA IMACH( 2) /   33 /
C     DATA IMACH( 3) / 8589934591 /
C     DATA IMACH( 4) /    2 /
C     DATA IMACH( 5) /   24 /
C     DATA IMACH( 6) / -256 /
C     DATA IMACH( 7) /  255 /
C     DATA IMACH( 8) /   60 /
C     DATA IMACH( 9) / -256 /
C     DATA IMACH(10) /  255 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.
C
C     DATA IMACH( 1) /    2 /
C     DATA IMACH( 2) /   39 /
C     DATA IMACH( 3) / 549755813887 /
C     DATA IMACH( 4) /    8 /
C     DATA IMACH( 5) /   13 /
C     DATA IMACH( 6) /  -50 /
C     DATA IMACH( 7) /   76 /
C     DATA IMACH( 8) /   26 /
C     DATA IMACH( 9) /  -50 /
C     DATA IMACH(10) /   76 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.
C
C     DATA IMACH( 1) /      2 /
C     DATA IMACH( 2) /     39 /
C     DATA IMACH( 3) / 549755813887 /
C     DATA IMACH( 4) /      8 /
C     DATA IMACH( 5) /     13 /
C     DATA IMACH( 6) /    -50 /
C     DATA IMACH( 7) /     76 /
C     DATA IMACH( 8) /     26 /
C     DATA IMACH( 9) / -32754 /
C     DATA IMACH(10) /  32780 /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES
C     COMPUTERS, AND THE CDC CYBER 990 AND 995 (NOS
C     OPERATING SYSTEM).
C
C     DATA IMACH( 1) /    2 /
C     DATA IMACH( 2) /   48 /
C     DATA IMACH( 3) / 281474976710655 /
C     DATA IMACH( 4) /    2 /
C     DATA IMACH( 5) /   48 /
C     DATA IMACH( 6) / -974 /
C     DATA IMACH( 7) / 1070 /
C     DATA IMACH( 8) /   95 /
C     DATA IMACH( 9) / -926 /
C     DATA IMACH(10) / 1070 /
C
C     MACHINE CONSTANTS FOR THE CDC CYBER 990 AND 995
C     (NOS/VE OPERATING SYSTEM).
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    63 /
C     DATA IMACH( 3) / 9223372036854775807 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    48 /
C     DATA IMACH( 6) / -4096 /
C     DATA IMACH( 7) /  4095 /
C     DATA IMACH( 8) /    96 /
C     DATA IMACH( 9) / -4096 /
C     DATA IMACH(10) /  4095 /
C
C     MACHINE CONSTANTS FOR THE CONVEX COMPUTERS
C     (NATIVE MODE).
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -127 /
C     DATA IMACH( 7) /   127 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1023 /
C     DATA IMACH(10) /  1023 /
C
C     MACHINE CONSTANTS FOR THE CONVEX COMPUTERS
C     (IEEE MODE).
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -125 /
C     DATA IMACH( 7) /   128 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1021 /
C     DATA IMACH(10) /  1024 /
C
C     MACHINE CONSTANTS FOR THE CRAY 2, X-MP, AND Y-MP
C     (CFT77 COMPILER USING THE 64 BIT INTEGER ARITHMETIC).
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    63 /
C     DATA IMACH( 3) / 9223372036854775807 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    48 /
C     DATA IMACH( 6) / -8188 /
C     DATA IMACH( 7) /  8189 /
C     DATA IMACH( 8) /    96 /
C     DATA IMACH( 9) / -8188 /
C     DATA IMACH(10) /  8189 /
C
C     MACHINE CONSTANTS FOR THE CRAY 2, X-MP, AND Y-MP
C     (CFT77 COMPILER USING THE 46 BIT INTEGER ARITHMETIC).
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    46 /
C     DATA IMACH( 3) / 70368744177663 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    48 /
C     DATA IMACH( 6) / -8188 /
C     DATA IMACH( 7) /  8189 /
C     DATA IMACH( 8) /    96 /
C     DATA IMACH( 9) / -8188 /
C     DATA IMACH(10) /  8189 /
C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200.
C
C     DATA IMACH( 1) /    2 /
C     DATA IMACH( 2) /   15 /
C     DATA IMACH( 3) / 32767 /
C     DATA IMACH( 4) /   16 /
C     DATA IMACH( 5) /    6 /
C     DATA IMACH( 6) /  -64 /
C     DATA IMACH( 7) /   63 /
C     DATA IMACH( 8) /   14 /
C     DATA IMACH( 9) /  -64 /
C     DATA IMACH(10) /   63 /
C
C     MACHINE CONSTANTS FOR THE HARRIS 220.
C
C     DATA IMACH( 1) /    2 /
C     DATA IMACH( 2) /   23 /
C     DATA IMACH( 3) / 8388607 /
C     DATA IMACH( 4) /    2 /
C     DATA IMACH( 5) /   23 /
C     DATA IMACH( 6) / -127 /
C     DATA IMACH( 7) /  127 /
C     DATA IMACH( 8) /   38 /
C     DATA IMACH( 9) / -127 /
C     DATA IMACH(10) /  127 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000
C     AND DPS 8/70 SERIES.
C
C     DATA IMACH( 1) /    2 /
C     DATA IMACH( 2) /   35 /
C     DATA IMACH( 3) / 34359738367 /
C     DATA IMACH( 4) /    2 /
C     DATA IMACH( 5) /   27 /
C     DATA IMACH( 6) / -127 /
C     DATA IMACH( 7) /  127 /
C     DATA IMACH( 8) /   63 /
C     DATA IMACH( 9) / -127 /
C     DATA IMACH(10) /  127 /
C
C     MACHINE CONSTANTS FOR THE HP 9000.
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -126 /
C     DATA IMACH( 7) /   128 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1021 /
C     DATA IMACH(10) /  1024 /
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE IBM 3033, THE ICL 2900, THE ITEL AS/6, THE
C     XEROX SIGMA 5/7/9, AND THE SEL SYSTEMS 85/86.
C
C     DATA IMACH( 1) /    2 /
C     DATA IMACH( 2) /   31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /   16 /
C     DATA IMACH( 5) /    6 /
C     DATA IMACH( 6) /  -64 /
C     DATA IMACH( 7) /   63 /
C     DATA IMACH( 8) /   14 /
C     DATA IMACH( 9) /  -64 /
C     DATA IMACH(10) /   63 /
C
C     MACHINE CONSTANTS FOR THE IBM PC.
C
      DATA IMACH( 1) /     2 /
      DATA IMACH( 2) /    31 /
      DATA IMACH( 3) / 2147483647 /
      DATA IMACH( 4) /     2 /
      DATA IMACH( 5) /    24 /
      DATA IMACH( 6) /  -125 /
      DATA IMACH( 7) /   128 /
      DATA IMACH( 8) /    53 /
      DATA IMACH( 9) / -1021 /
      DATA IMACH(10) /  1024 /
C
C     MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT
C     MACFORTRAN II.
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -125 /
C     DATA IMACH( 7) /   128 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1021 /
C     DATA IMACH(10) /  1024 /
C
C     MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING
C     32-BIT INTEGER ARITHMETIC.
C
C     DATA IMACH( 1) /    2 /
C     DATA IMACH( 2) /   31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /    2 /
C     DATA IMACH( 5) /   24 /
C     DATA IMACH( 6) / -127 /
C     DATA IMACH( 7) /  127 /
C     DATA IMACH( 8) /   56 /
C     DATA IMACH( 9) / -127 /
C     DATA IMACH(10) /  127 /
C
C     MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000.
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -125 /
C     DATA IMACH( 7) /   128 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1021 /
C     DATA IMACH(10) /  1024 /
C
C     MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D
C     SERIES (MIPS R3000 PROCESSOR).
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -125 /
C     DATA IMACH( 7) /   128 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1021 /
C     DATA IMACH(10) /  1024 /
C
C     MACHINE CONSTANTS FOR THE SUN 3.
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -125 /
C     DATA IMACH( 7) /   128 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1021 /
C     DATA IMACH(10) /  1024 /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    35 /
C     DATA IMACH( 3) / 34359738367 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    27 /
C     DATA IMACH( 6) /  -128 /
C     DATA IMACH( 7) /   127 /
C     DATA IMACH( 8) /    60 /
C     DATA IMACH( 9) / -1024 /
C     DATA IMACH(10) /  1023 /
C
C     MACHINE CONSTANTS FOR THE VAX AND MICROVAX
C     COMPUTERS - F AND D FLOATING ARITHMETICS.
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -127 /
C     DATA IMACH( 7) /   127 /
C     DATA IMACH( 8) /    56 /
C     DATA IMACH( 9) /  -127 /
C     DATA IMACH(10) /   127 /
C
C     MACHINE CONSTANTS FOR THE VAX AND MICROVAX
C     COMPUTERS - F AND G FLOATING ARITHMETICS.
C
C     DATA IMACH( 1) /     2 /
C     DATA IMACH( 2) /    31 /
C     DATA IMACH( 3) / 2147483647 /
C     DATA IMACH( 4) /     2 /
C     DATA IMACH( 5) /    24 /
C     DATA IMACH( 6) /  -127 /
C     DATA IMACH( 7) /   127 /
C     DATA IMACH( 8) /    53 /
C     DATA IMACH( 9) / -1023 /
C     DATA IMACH(10) /  1023 /
C
      IPMPAR = IMACH(I)
      RETURN
      END
C-----------------------------------------------------------------------
      SUBROUTINE MACH (MO, N, IBETA, IMAX, IDMAX, IMACH, RMACH, DMACH)
C-----------------------------------------------------------------------
      REAL RMACH(3)
      DOUBLE PRECISION DMACH(3)
      INTEGER IMACH(10)
C-----------------------------------------------------------------------
C
C          COMPUTATION OF THE ENVIRONMENTAL CONSTANTS FOR THE
C        SINGLE AND DOUBLE PRECISION FLOATING POINT ARITHMETICS
C
C                           -----------
C
C     IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING
C     POINT ARITHMETICS HAVE THE SAME BASE, SAY IBETA, AND THAT
C     THE NONZERO NUMBERS ARE REPRESENTED IN THE FORM
C
C        SIGN (IBETA**K) * (X(1)/IBETA + ... + X(M)/IBETA ** M)
C
C     WHERE EACH X(I) IS AN INTEGER SUCH THAT
C
C        0 .LE. X(I) .LT. IBETA
C
C     AND  X(1) .GE. 1 . THE EXPONENT K IS AN INTEGER SUCH THAT
C
C        MINEXP .LE. K .LE. MAXEXP.
C
C     THE VALUES M, MINEXP, AND MAXEXP ARE NEEDED FOR BOTH THE
C     SINGLE AND DOUBLE PRECISION ARITHMETICS IN ORDER TO DEFINE
C     THE FUNCTION IPMPAR. THIS SUBROUTINE ATTEMPTS TO HELP THE
C     USER IN OBTAINING THIS INFORMATION.
C
C-----------------------------------------------------------------------
C                         INPUT AND OUTPUT
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       MO    - MODE OF OPERATION OF THE ROUTINE.
C
C               MO = 0  OUTPUT UNIT N IS NOT USED. THE SINGLE
C                       AND DOUBLE PRECISION ARITHMETICS ARE
C                       EXAMINED.
C               MO = 1  IT IS ASSUMED THAT UNIT N IS USED.
C                       MACH SEARCHES FOR THE MAXIMUM EXPONENT
C                       MAXEXP FOR THE SINGLE PRECISION ARITH-
C                       METIC. THE DOUBLE PRECISION ARITHMETIC
C                       IS NOT EXAMINED.
C               MO = 2  IT IS ASSUMED THAT UNIT N IS USED.
C                       MACH SEARCHES FOR THE MAXIMUM EXPONENT
C                       MAXEXP FOR THE DOUBLE PRECISION ARITH-
C                       METIC. THE SINGLE PRECISION ARITHMETIC
C                       IS NOT EXAMINED.
C
C       N     - IF N IS POSITIVE THEN N IS THE NUMBER OF AN
C               OUTPUT UNIT, WHERE ANY INFORMATION WRITTEN ON
C               THE UNIT WILL BE AVAILABLE TO THE USER IF MACH
C               TERMINATES BECAUSE OF OVERFLOW. IF N .LE. 0
C               THEN NO SUCH OUTPUT UNIT IS TO BE USED. (IF NO
C               SUCH OUTPUT UNIT IS USED THEN SET MO = 0.)
C
C       IBETA - THE BASE OF THE FLOATING POINT ARITHMETICS. (IT
C               IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION
C               ARITHMETICS HAVE THE SAME BASE.) IF THIS VALUE
C               IS NOT KNOWN THEN
C
C                           CALL RADIX (IBETA)
C
C               WILL (HOPEFULLY) PROVIDE THE CORRECT VALUE. AS
C               FAR AS IS KNOWN, THE SUBROUTINE RADIX OPERATES
C               PROPERLY ON ALL COMPUTERS. NEVERTHELESS, THE
C               VALUE OBTAINED FOR IBETA SHOULD BE CHECKED.
C
C       IMAX  - IF IMAX IS POSITIVE THEN IMAX IS ASSUMED TO BE
C               AN APPROXIMATION OF THE MAXIMUM EXPONENT MAXEXP
C               FOR THE SINGLE PRECISION NUMBERS. OTHERWISE, IF
C               IMAX .LE. 0, THEN THE ROUTINE DEFINES ITS OWN
C               INITIAL APPROXIMATION FOR MAXEXP.
C
C       IDMAX - IF IDMAX IS POSITIVE THEN IDMAX IS ASSUMED TO BE
C               AN APPROXIMATION OF THE MAXIMUM EXPONENT MAXEXP
C               FOR THE DOUBLE PRECISION NUMBERS. OTHERWISE, IF
C               IDMAX .LE. 0, THEN THE ROUTINE DEFINES ITS OWN
C               INITIAL APPROXIMATION FOR MAXEXP.
C
C
C     OUTPUT (WHEN MO = 0) ...
C
C       IMACH - INTEGER ARRAY OF DIMENSION 10 APPEARING IN THE
C               DEFINITION OF THE FUNCTION IPMPAR.
C               IPMPAR(I) = IMACH(I)  I = 4,...,10
C
C       RMACH - REAL ARRAY OF DIMENSION 3 GIVING THE FOLLOWING
C               CONSTANTS FOR THE SINGLE PRECISION ARITHMETIC.
C               RMACH(1) = B**(1-M), THE MACHINE PRECISION
C               RMACH(2) = THE SMALLEST POSITIVE NUMBER
C               RMACH(3) = THE LARGEST POSITIVE NUMBER
C
C       DMACH - DOUBLE PRECISION ARRAY OF DIMENSION 3 GIVING THE
C               FOLLOWING CONSTANTS FOR THE DOUBLE PRECISION
C               ARITHMETIC.
C               DMACH(1) = B**(1-M), THE MACHINE PRECISION
C               DMACH(2) = THE SMALLEST POSITIVE NUMBER
C               DMACH(3) = THE LARGEST POSITIVE NUMBER
C
C-----------------------------------------------------------------------
C                              USAGE
C-----------------------------------------------------------------------
C
C     THE FOLLOWING PROCEDURE IS RECOMMENDED FOR OBTAINING THE
C     DATA NEEDED FOR DEFINING IPMPAR.
C
C
C     STEP (1). IN THIS STEP WE SEARCH FOR THE MAXIMUM EXPONENT
C     MAXEXP FOR THE SINGLE PRECISION ARITHMETIC. THE DOUBLE
C     PRECISION ARITHMETIC IS NOT CONSIDERED. IT IS ASSUMED THAT
C     AN OUTPUT UNIT N IS BEING USED. GIVEN N AND IBETA. SET
C     IMAX = 0 AND COMPUTE ...
C
C        CALL MACH (1, N, IBETA, IMAX, IDMAX, IMACH, RMACH, DMACH)
C
C     WHEN THIS CODE IS RUN, INFORMATION IS GIVEN ON UNIT N FOR
C     RESETTING IMAX. IF THE MAXIMUM EXPONENT HAS BEEN FOUND
C     (IN THIS CASE, THE LAST INTEGER WRITTEN ON UNIT N WILL NOT
C     BE FOLLOWED BY ANY STATEMENT EXCEPT POSSIBLY AN OVERFLOW
C     STATEMENT), THEN SET IMAX TO THE LAST INTEGER WRITTEN ON
C     UNIT N AND GO TO STEP (2). OTHERWISE, IF THE MAXIMUM
C     EXPONENT HAS NOT BEEN FOUND, THEN RESET IMAX ACCORDING TO
C     THE INSTRUCTIONS GIVEN ON UNIT N AND RERUN THE CODE. THE
C     CODE MAY BE RERUN WITH DIFFERENT VALUES OF IMAX UNTIL THE
C     THE MAXIMUM EXPONENT HAS BEEN FOUND OR A SATISFACTORY
C     APPROXIMATION FOR THE MAXIMUM EXPONENT HAS BEEN OBTAINED.
C     THEN SET IMAX TO THE MAXIMUM EXPONENT (OR THE APPROXIMATION)
C     AND GO TO STEP (2).
C
C
C     STEP (2). IN THIS STEP WE SEARCH FOR THE MAXIMUM EXPONENT
C     MAXEXP FOR THE DOUBLE PRECISION ARITHMETIC. THE SINGLE
C     PRECISION ARITHMETIC IS NOT CONSIDERED. IT IS ASSUMED THAT
C     AN OUTPUT UNIT N IS BEING USED. GIVEN N AND IBETA. SET
C     IDMAX = 0 AND COMPUTE ...
C
C        CALL MACH (2, N, IBETA, IMAX, IDMAX, IMACH, RMACH, DMACH)
C
C     THE PROCEDURE USED IN THIS STEP FOR FINDING THE MAXIMUM
C     EXPONENT OR OBTAINING A SUITABLE APPROXIMATION FOR THE
C     MAXIMUM EXPONENT IS THE SAME AS IN STEP (1), THE ONLY
C     DIFFERENCE BEING THAT NOW ONE WORKS WITH IDMAX INSTEAD
C     OF IMAX. WHEN THE MAXIMUM EXPONENT IS FOUND OR A SUITABLE
C     APPROXIMATION IS OBTAINED, THEN RESET IDMAX TO THE MAXIMUM
C     EXPONENT (OR THE APPROXIMATION) AND GO TO STEP (3).
C
C
C     STEP (3). GIVEN THE VALUES OBTAINED FOR IBETA, IMAX, AND
C     IDMAX. THEN COMPUTE ...
C
C        CALL MACH (0, 0, IBETA, IMAX, IDMAX, IMACH, RMACH, DMACH)
C
C     WHEN THIS CODE TERMINATES, ALL THE DATA NEEDED FOR DEFINING
C     IPMPAR(4),...,IPMPAR(10) IS GIVEN IN THE ARRAY IMACH. THE
C     DATA GIVEN IN THE ARRAYS RMACH AND DMACH ARE PROVIDED SO THAT
C     THE USER CAN CHECK THE INFORMATION IN IMACH.
C
C             RMACH(1)  DEPENDS ON IMACH(4) AND IMACH(5)
C             RMACH(2)  DEPENDS ON IMACH(4) AND IMACH(6)
C             RMACH(3)  DEPENDS ON IMACH(4) AND IMACH(7)
C             DMACH(1)  DEPENDS ON IMACH(4) AND IMACH(8)
C             DMACH(2)  DEPENDS ON IMACH(4) AND IMACH(9)
C             DMACH(3)  DEPENDS ON IMACH(4) AND IMACH(10)
C
C     THE VALUES IN RMACH AND DMACH SHOULD BE CHECKED TO SEE IF
C     THEY MAKE SENSE. (FOR EXAMPLE, RMACH(2) AND DMACH(2) SHOULD
C     NEVER BE 0.)
C
C-----------------------------------------------------------------------
C                       GENERAL INFORMATION
C-----------------------------------------------------------------------
C
C     THE VALUES IN IMACH(6) AND IMACH(9) ARE THE MINIMUM EXPONENTS
C     FOR THE NUMBERS IN THE SINGLE AND DOUBLE PRECISION ARITHMETICS
C     WHICH HAVE FULL ACCURACY. ON SOME COMPUTERS, ACCURACY IS LOST
C     IN THE STORAGE OF SOME SMALL NUMBERS. THIS OCCURS IN THE DOUBLE
C     PRECISION ARITHMETICS OF THE CDC 6000-7000 SERIES COMPUTES. ON
C     THESE MACHINES, THE DOUBLE PRECISION NUMBERS LESS THAT 2**(-927)
C     NORMALLY HAVE ONLY SINGLE PRECISION ACCURACY. CONSEQUENTLY,
C     IMACH(9) WILL HAVE THE COMPUTED VALUE -926 INSTEAD OF -974
C     (WHICH ONE WOULD NORMALLY EXPECT). IN THIS CASE, -926 IS THE
C     VALUE THAT IS CONSIDERED TO BE CORRECT.
C
C     THIS PACKAGE OF SUBROUTINES INCLUDES MACH, RADIX, MACH1, STORE2,
C     MACH2, DSTOR2. THE PACKAGE IS EXPERIMENTAL. IT IS PROVIDED AS
C     AN AID IN DEFINING THE FUNCTION IPMPAR. THE SUBROUTINES IN THE
C     PACKAGE ARE NOT USED BY ANY OF THE FUNCTIONS OR SUBROUTINES IN
C     THE NSWC LIBRARY.
C
C     THE PURPOSE OF THE SUBROUTINES STORE2 AND DSTOR2 IS TO FORCE
C     DATA TO BE STORED IN MEMORY. THESE ROUTINES ARE NEEDED WHEN
C     DATA ARE STORED IN OVERSIZED REGISTERS.
C
C     THE ALGORITHM FOR THE SUBROUTINE RADIX WAS DEVELOPED BY M.A.
C     MALCOLM (STANFORD UNIVERSITY). SEE REFERENCES (1) AND (2).
C
C-----------------
C
C     WRITTEN BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN VIRGINIA
C
C-----------------
C
C     REVISED ... MARCH 1992
C
C-----------------
C
C     REFERENCES ...
C
C     (1) MALCOLM, M.A., ALGORITHMS TO REVEAL PROPERTIES OF FLOATING
C         POINT ARITHMETIC, COMM. ACM (15), 1972, PP. 949-951.
C
C     (2) GENTLEMEN, W.M. AND MAROVICH, S.B., MORE ON ALGORITHMS THAT
C         REVEAL PROPERTIES OF FLOATING POINT ARITHMETIC UNITS,
C         COMM. ACM (17), 1974, PP. 276-277.
C
C     (3) CODY, W.J. AND WAITE, W., SOFTWARE MANUAL FOR THE ELEMENTARY
C         FUNCTIONS, PRENTICE-HALL, 1980, PP. 258-264.
C
C     (4) CODY, W.J., ALGORITHM 665. MACHAR, A SUBROUTINE TO DYNAMICALLY
C         DETERMINE MACHINE PARAMETERS, ACM TRANS. MATH SOFTWARE (14),
C         1988, PP. 303-311.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION DEPS, DINT, DMIN, DMAX
C-----------------
      IMACH(1) = 0
      IMACH(2) = 0
      IMACH(3) = 0
C
      N0 = N
      IF (MO .LE. 0) N0 = 0
      IF (MO .GE. 2) GO TO 10
C-----------------------------------------------------------------------
C     OBTAIN THE SINGLE PRECISION INFORMATION
C-----------------------------------------------------------------------
      MAXEXP = IMAX
      CALL MACH1 (N0, IBETA, M, MINEXP, MAXEXP, EPS, XINT, XMIN, XMAX)
      IF (MO .EQ. 1) STOP
      RMACH(1) = EPS
      RMACH(2) = XMIN
      RMACH(3) = XMAX
      IMACH(4) = IBETA
      IMACH(5) = M
      IMACH(6) = MINEXP
      IMACH(7) = MAXEXP
C-----------------------------------------------------------------------
C     OBTAIN THE DOUBLE PRECISION INFORMATION
C-----------------------------------------------------------------------
   10 MAXEXP = IDMAX
      CALL MACH2 (N0, IBETA, M, MINEXP, MAXEXP, DEPS, DINT, DMIN, DMAX)
      IF (MO .GE. 2) STOP
      DMACH(1) = DEPS
      DMACH(2) = DMIN
      DMACH(3) = DMAX
      IMACH(8) = M
      IMACH(9) = MINEXP
      IMACH(10)= MAXEXP
      RETURN
      END
      SUBROUTINE RADIX (IBETA)
C-----------------------------------------------------------------------
C     SET  IBETA = THE RADIX OF THE FLOATING POINT ARITHMETIC
C-----------------------------------------------------------------------
      COMMON /SPDATA/ D1, D2
C
      ONE  = FLOAT(1)
C
      A = ONE
   10 A = A + A
      CALL STORE2 (A + ONE, A)
      Y = D1 - D2
      IF (Y .EQ. ONE) GO TO 10
C
      B = ONE
   20 B = B + B
      CALL STORE2 (A + B, A)
      IF (D1 .EQ. D2) GO TO 20
C
      IBETA = INT(D1 - D2)
      RETURN
      END
      SUBROUTINE MACH1 (N, IBETA, M, MINEXP, MAXEXP, EPS, XINT,
     *                  XMIN, XMAX)
      REAL EPS, XINT, XMIN, XMAX
C-----------------------------------------------------------------------
C
C                 COMPUTATION OF THE ENVIRONMENTAL CONSTANTS
C             FOR THE SINGLE PRECISION FLOATING POINT ARITHMETIC
C
C                            -----------
C
C     INPUT ...
C
C       N       - IF N IS POSITIVE THEN N IS THE NUMBER OF AN
C                 OUTPUT UNIT. IN THIS CASE IT IS ASSUMED THAT
C                 ANY INFORMATION THAT IS WRITTEN ON THE UNIT
C                 WILL BE AVAILABLE TO THE USER IF THE ROUTINE
C                 TERMINATES BECAUSE OF OVERFLOW. UNIT N IS
C                 USED ONLY FOR COMPUTING THE EXACT MAXIMUM
C                 BASE IBETA EXPONENT FOR THE FLOATING POINT
C                 NUMBERS (THIS EXPONENT IS STORED IN MAXEXP).
C                 IF THE EXACT MAXIMUM EXPONENT IS NOT NEEDED
C                 (OR HAS ALREADY BEEN OBTAINED) THEN SET N
C                 TO 0 OR A NEGATIVE VALUE.
C
C       IBETA   - THE BASE OF THE FLOATING POINT ARITHMETIC.
C
C       MAXEXP  - IF MAXEXP IS POSITIVE THEN MAXEXP IS ASSUMED TO
C                 BE AN APPROXIMATION OF THE MAXIMUM (BASE IBETA)
C                 EXPONENT FOR THE FLOATING POINT NUMBERS. OTHER-
C                 WISE, IF MAXEXP .LE. 0, THEN AN APPROXIMATION
C                 FOR THE MAXIMUM EXPONENT IS OBTAINED.
C
C     OUTPUT ...
C
C       M       - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING
C                 POINT REPRESENTATION.
C
C       MINEXP  - THE LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH
C                 THAT FLOAT(IBETA)**(MINEXP - 1) IS A POSITIVE
C                 NUMBER.
C
C       MAXEXP  - IF MAXEXP IS POSITIVE ON INPUT AND N .LE. 0
C                 THEN MAXEXP IS NOT MODIFIED.
C
C                 IF MAXEXP .LE. 0 ON INPUT AND N .LE. 0 THEN
C                 ON OUTPUT MAXEXP = AN APPROXIMATION OF THE
C                 MAXIMUM (BASE IBETA) EXPONENT FOR THE FLOATING
C                 POINT NUMBERS.
C
C                 IF N IS POSITIVE THEN THE ROUTINE SEARCHES FOR
C                 THE EXACT MAXIMUM EXPONENT FOR THE FLOATING
C                 POINT NUMBERS. IF MAXEXP IS POSITIVE ON INPUT
C                 THEN THE SEARCH BEGINS WITH MAXEXP. IF
C                 MAXEXP .LE. 0 ON INPUT THEN THE ROUTINE BEGINS
C                 THE SEARCH WITH ITS OWN INITIAL APPROXIMATION
C                 FOR MAXEXP. THE FOLLOWING LOOP IS PERFORMED.
C                     (1) CHECK THE CURRENT VALUE OF MAXEXP
C                         FOR OVERFLOW. IF OVERFLOW OCCURS
C                         THEN THE ROUTINE WILL (HOPEFULLY)
C                         ABORT. OTHERWISE, IF OVERFLOW DOES
C                         NOT OCCUR THEN GO TO (2).
C                     (2) WRITE ON UNIT N THE CURRENT VALUE
C                         OF MAXEXP AND GO TO (3).
C                     (3) INCREASE THE VALUE OF MAXEXP BY 1
C                         AND RETURN TO (1).
C                 IF THE OVERFLOW TEST IN (1) FAILS THEN THE
C                 ROUTINE ABORTS AFTER 500 PASSES THROUGH THE
C                 LOOP. IF THE OVERFLOW TEST WORKS PROPERLY
C                 THEN THE LAST INTEGER WRITTEN ON UNIT N IS
C                 THE DESIRED MAXIMUM EXPONENT FOR THE FLOAT-
C                 ING POINT NUMBERS. RESET MAXEXP TO THIS
C                 INTEGER, SET N = 0, AND RERUN THE ROUTINE.
C
C       EPS     - THE RELATIVE PRECISION OF THE FLOATING ARITHMETIC.
C                 EPS = FLOAT(IBETA)**(1 - M)
C
C       XINT    - THE LARGEST POSITIVE INTEGER THAT CAN
C                 BE EXACTLY REPRESENTED AS A FLOATING
C                 POINT NUMBER. XINT = B**M - 1  WHERE
C                 B = FLOAT(IBETA).
C
C       XMIN    - THE SMALLEST NONZERO POWER OF THE BASE.
C                 XMIN = FLOAT(IBETA)**(MINEXP - 1)
C
C       XMAX    - THE LARGEST FOATING POINT NUMBER THAT CAN
C                 BE OBTAINED HAVING THE EXPONENT MAXEXP.
C                 XMAX = (1 - B**(-M)) * B**MAXEXP  WHERE
C                 B = FLOAT(IBETA). IF MAXEXP IS THE MAXIMUM
C                 EXPONENT FOR THE FLOATING POINT NUMBERS
C                 THEN XMAX IS THE LARGEST FLOATING POINT
C                 NUMBER THAT EXISTS. THE VALUE OBTAINED
C                 FOR XMAX MAY BE AFFECTED SLIGHTLY BY
C                 ROUNDOFF ERROR.
C
C-----------------------------------------------------------------------
      REAL B, B2, BINV, BM1, D1, D2, ONE, P, Q, T, X, Z, ZERO
C----------------
      COMMON /SPDATA/ D1, D2
C
      ZERO = FLOAT(0)
      ONE = FLOAT(1)
      B = FLOAT(IBETA)
      B2 = B*B
      BM1 = FLOAT(IBETA - 1)
      BINV = ONE/B
C-----------------------------------------------------------------------
C     COMPUTE M AND EPS
C-----------------------------------------------------------------------
      M = 1
      T = B
   10    M = M + 1
         Z = T
         T = B*T
         CALL STORE2 (T + ONE, T)
         X = D1*BINV - Z
         IF (X .EQ. BINV) GO TO 10
C
      XINT = (Z - ONE)*B + BM1
      XMAX = XINT/T
      IF (XMAX .LT. ONE) GO TO 20
         M = M - 1
         T = Z
         Z = Z*BINV
         XINT = (Z - ONE)*B + BM1
         XMAX = XINT/T
   20 EPS = ONE/Z
C-----------------------------------------------------------------------
C     COMPUTE MINEXP AND XMIN
C-----------------------------------------------------------------------
      P = ONE + EPS
      Q = ONE + EPS*B2
C
C     MINEXP MUST BE FOUND. THIS LOOP OBTAINS THE LARGEST
C     K = 2**I SUCH THAT B**(-K) DOES NOT UNDERFLOW.
C
      K = 1
      Z = BINV
   30    X = Z
         Z = (X*X)*ONE
         CALL STORE2 (Z*XINT, Z*T)
         IF (D1 .EQ. D2) GO TO 40
         IF (Z + Z .EQ. ZERO .OR. ABS(Z) .GE. X) GO TO 40
         CALL STORE2 (Z, P*Z)
         IF (T*D2 .EQ. T*Z) GO TO 40
         K = K + K
         GO TO 30
C
   40 KM = K + K
      J = 0
C
C     LOOP TO DETERMINE MINEXP AND XMIN.
C
   50    XMIN = X
         X = (X*BINV)*ONE
         CALL STORE2 (X*XINT, X*T)
         IF (D1 .EQ. D2) GO TO 90
         IF (X + X .EQ. ZERO .OR. ABS(X) .GE. XMIN) GO TO 90
         CALL STORE2 (X, P*X)
         IF (T*D2 .EQ. T*X) GO TO 80
         K = K + 1
         GO TO 50
C
C     IF THERE IS LOSS OF ACCURACY NOT DUE TO UNDERFLOW
C     THEN SET J = NUMBER OF DIGITS POSSIBLY LOST DUE TO
C     THIS LOSS OF ACCURACY.
C
   80 CALL STORE2 (X, Q*X)
      IF (T*D2 .NE. T*X) GO TO 90
   81    Z = X
         J = J + 1
         X = (X*BINV)*ONE
         CALL STORE2 (X*XINT, X*T)
         IF (D1 .EQ. D2) GO TO 90
         IF (X + X .NE. ZERO .AND. ABS(X) .LT. Z) GO TO 81
C
   90 MINEXP = 1 - K
C-----------------------------------------------------------------------
C     DEFINE AN INITIAL APPROXIMATION FOR MAXEXP AND XMAX
C     WHEN MAXEXP .LE. 0 ON INPUT
C-----------------------------------------------------------------------
      IF (MAXEXP .GT. 0) GO TO 101
      IF (IBETA .EQ. 2 .OR. IBETA .EQ. 8 .OR.
     *    IBETA .EQ. 16) GO TO 100
C
         MAXEXP = K - 3
         IF (N .GT. 0) WRITE (N,200) MAXEXP
         T = ONE/(B2*B2*XMIN)
         XMAX = (XMAX*T)*B
         GO TO 110
C
  100 K = K + J
      IF (K + K .GT. KM + 2) KM = KM + KM
      MAXEXP = KM - K - 3
  101 IF (N .GT. 0) WRITE (N,200) MAXEXP
      T = B**(MAXEXP - 2)
      XMAX = ((XMAX*T)*B)*B
C-----------------------------------------------------------------------
C     CHECK THE APPROXIMATION FOR MAXEXP
C-----------------------------------------------------------------------
  110 CALL STORE2 (T, T*P)
      IF (D1 .EQ. D2) GO TO 150
      IF (N .LE. 0) RETURN
C-----------------------------------------------------------------------
C     LOOP TO FIND THE EXACT LARGEST VALUE FOR MAXEXP
C-----------------------------------------------------------------------
      WRITE (N,210) MAXEXP
      DO 120 L = 1,500
         T = T*B
         XMAX = XMAX*B
         MAXEXP = MAXEXP + 1
         CALL STORE2 (T, T*P)
         IF (D1 .EQ. D2) GO TO 150
         WRITE (N,220) MAXEXP
  120 CONTINUE
      WRITE (N,240)
      STOP
C-----------------------------------------------------------------------
C     REPORTING OVERFLOW ON UNIT N
C-----------------------------------------------------------------------
  150 IF (N .GT. 0) WRITE (N,230)
      STOP
C-----------------------------------------------------------------------
C     FORMAT STATEMENTS
C-----------------------------------------------------------------------
  200 FORMAT (50H THE INITIAL APPROXIMATION FOR IMAX (OR MAXEXP) IS//
     *        I25//
     *        47H IF NO FURTHER INFORMATION APPEARS ON THIS FILE/
     *        50H THEN SET IMAX (OR MAXEXP) TO A SMALLER VALUE THAN/
     *        39H THIS APPROXIMATION AND RERUN THE CODE.//)
  210 FORMAT (51H THE LOOP TO FIND THE LARGEST POSSIBLE EXPONENT HAS/
     *        48H BEGUN. SET IMAX (OR MAXEXP) TO THE LAST INTEGER/
     *        14H THAT FOLLOWS.//I25)
  220 FORMAT (I25)
  230 FORMAT(/32H   ****** OVERFLOW OCCURS ******)
  240 FORMAT(/46H ****** 500 PASSES WERE MADE THROUGH THE LOOP./
     *        45H        THE MAXIMUM EXPONENT CANNOT BE FOUND./
     *        43H        IF ONE WISHES, SET IMAX (OR MAXEXP)/
     *        45H        TO A LARGER VALUE AND RERUN THE CODE./)
C-----------------------------------------------------------------------
      END
      SUBROUTINE STORE2 (A, B)
C-----------------------------------------------------------------------
C     STORAGE OF SINGLE PRECISION INFORMATION INTO MEMORY
C-----------------------------------------------------------------------
      COMMON /SPDATA/ D1, D2
      D1 = A
      D2 = B
      RETURN
      END
      SUBROUTINE MACH2 (N, IBETA, M, MINEXP, MAXEXP, EPS, XINT,
     *                  XMIN, XMAX)
      DOUBLE PRECISION EPS, XINT, XMIN, XMAX
C-----------------------------------------------------------------------
C
C                 COMPUTATION OF THE ENVIRONMENTAL CONSTANTS
C             FOR THE DOUBLE PRECISION FLOATING POINT ARITHMETIC
C
C                            -----------
C
C     INPUT ...
C
C       N       - IF N IS POSITIVE THEN N IS THE NUMBER OF AN
C                 OUTPUT UNIT. IN THIS CASE IT IS ASSUMED THAT
C                 ANY INFORMATION THAT IS WRITTEN ON THE UNIT
C                 WILL BE AVAILABLE TO THE USER IF THE ROUTINE
C                 TERMINATES BECAUSE OF OVERFLOW. UNIT N IS
C                 USED ONLY FOR COMPUTING THE EXACT MAXIMUM
C                 BASE IBETA EXPONENT FOR THE FLOATING POINT
C                 NUMBERS (THIS EXPONENT IS STORED IN MAXEXP).
C                 IF THE EXACT MAXIMUM EXPONENT IS NOT NEEDED
C                 (OR HAS ALREADY BEEN OBTAINED) THEN SET N
C                 TO 0 OR A NEGATIVE VALUE.
C
C       IBETA   - THE BASE OF THE FLOATING POINT ARITHMETIC.
C
C       MAXEXP  - IF MAXEXP IS POSITIVE THEN MAXEXP IS ASSUMED TO
C                 BE AN APPROXIMATION OF THE MAXIMUM (BASE IBETA)
C                 EXPONENT FOR THE FLOATING POINT NUMBERS. OTHER-
C                 WISE, IF MAXEXP .LE. 0, THEN AN APPROXIMATION
C                 FOR THE MAXIMUM EXPONENT IS OBTAINED.
C
C     OUTPUT ...
C
C       M       - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING
C                 POINT REPRESENTATION.
C
C       MINEXP  - LET B = DBLE(FLOAT(IBETA)). THEN MINEXP IS THE
C                 LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH THAT
C                 B**(MINEXP - 1) IS A POSITIVE NUMBER.
C
C       MAXEXP  - IF MAXEXP IS POSITIVE ON INPUT AND N .LE. 0
C                 THEN MAXEXP IS NOT MODIFIED.
C
C                 IF MAXEXP .LE. 0 ON INPUT AND N .LE. 0 THEN
C                 ON OUTPUT MAXEXP = AN APPROXIMATION OF THE
C                 MAXIMUM (BASE IBETA) EXPONENT FOR THE FLOATING
C                 POINT NUMBERS.
C
C                 IF N IS POSITIVE THEN THE ROUTINE SEARCHES FOR
C                 THE EXACT MAXIMUM EXPONENT FOR THE FLOATING
C                 POINT NUMBERS. IF MAXEXP IS POSITIVE ON INPUT
C                 THEN THE SEARCH BEGINS WITH MAXEXP. IF
C                 MAXEXP .LE. 0 ON INPUT THEN THE ROUTINE BEGINS
C                 THE SEARCH WITH ITS OWN INITIAL APPROXIMATION
C                 FOR MAXEXP. THE FOLLOWING LOOP IS PERFORMED.
C                     (1) CHECK THE CURRENT VALUE OF MAXEXP
C                         FOR OVERFLOW. IF OVERFLOW OCCURS
C                         THEN THE ROUTINE WILL (HOPEFULLY)
C                         ABORT. OTHERWISE, IF OVERFLOW DOES
C                         NOT OCCUR THEN GO TO (2).
C                     (2) WRITE ON UNIT N THE CURRENT VALUE
C                         OF MAXEXP AND GO TO (3).
C                     (3) INCREASE THE VALUE OF MAXEXP BY 1
C                         AND RETURN TO (1).
C                 IF THE OVERFLOW TEST IN (1) FAILS THEN THE
C                 ROUTINE ABORTS AFTER 500 PASSES THROUGH THE
C                 LOOP. IF THE OVERFLOW TEST WORKS PROPERLY
C                 THEN THE LAST INTEGER WRITTEN ON UNIT N IS
C                 THE DESIRED MAXIMUM EXPONENT FOR THE FLOAT-
C                 ING POINT NUMBERS. RESET MAXEXP TO THIS
C                 INTEGER, SET N = 0, AND RERUN THE ROUTINE.
C
C       EPS     - THE RELATIVE PRECISION OF THE FLOATING ARITHMETIC.
C                 EPS = B**(1 - M) WHERE B = DBLE(FLOAT(IBETA)).
C
C       XINT    - THE LARGEST POSITIVE INTEGER THAT CAN
C                 BE EXACTLY REPRESENTED AS A FLOATING
C                 POINT NUMBER. XINT = B**M - 1  WHERE
C                 B = DBLE(FLOAT(IBETA)).
C
C       XMIN    - THE SMALLEST NONZERO POWER OF THE BASE.
C                 XMIN = B**(MINEXP-1) WHERE B=DBLE(FLOAT(IBETA)).
C
C       XMAX    - THE LARGEST FOATING POINT NUMBER THAT CAN
C                 BE OBTAINED HAVING THE EXPONENT MAXEXP.
C                 XMAX = (1 - B**(-M)) * B**MAXEXP  WHERE
C                 B = DBLE(FLOAT(IBETA)). IF MAXEXP IS THE
C                 MAXIMUM EXPONENT FOR THE FLOATING POINT
C                 NUMBERS THEN XMAX IS THE LARGEST FLOATING
C                 POINT NUMBER THAT EXISTS. THE VALUE
C                 OBTAINED FOR XMAX MAY BE AFFECTED SLIGHTLY
C                 BY ROUNDOFF ERROR.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION B,B2, BINV, BM1, D1, D2, ONE, P, Q, T, X, Z, ZERO
C----------------
      COMMON /DPDATA/ D1, D2
C
      ZERO = DBLE(FLOAT(0))
      ONE = DBLE(FLOAT(1))
      B = DBLE(FLOAT(IBETA))
      B2 = B*B
      BM1 = DBLE(FLOAT(IBETA - 1))
      BINV = ONE/B
C-----------------------------------------------------------------------
C     COMPUTE M AND EPS
C-----------------------------------------------------------------------
      M = 1
      T = B
   10    M = M + 1
         Z = T
         T = B*T
         CALL DSTOR2 (T + ONE, T)
         X = D1*BINV - Z
         IF (X .EQ. BINV) GO TO 10
C
      XINT = (Z - ONE)*B + BM1
      XMAX = XINT/T
      IF (XMAX .LT. ONE) GO TO 20
         M = M - 1
         T = Z
         Z = Z*BINV
         XINT = (Z - ONE)*B + BM1
         XMAX = XINT/T
   20 EPS = ONE/Z
C-----------------------------------------------------------------------
C     COMPUTE MINEXP AND XMIN
C-----------------------------------------------------------------------
      P = ONE + EPS
      Q = ONE + EPS*B2
C
C     MINEXP MUST BE FOUND. THIS LOOP OBTAINS THE LARGEST
C     K = 2**I SUCH THAT B**(-K) DOES NOT UNDERFLOW.
C
      K = 1
      Z = BINV
   30    X = Z
         Z = (X*X)*ONE
         CALL DSTOR2 (Z*XINT, Z*T)
         IF (D1 .EQ. D2) GO TO 40
         IF (Z + Z .EQ. ZERO .OR. DABS(Z) .GE. X) GO TO 40
         CALL DSTOR2 (Z, P*Z)
         IF (T*D2 .EQ. T*Z) GO TO 40
         K = K + K
         GO TO 30
C
   40 KM = K + K
      J = 0
C
C     LOOP TO DETERMINE MINEXP AND XMIN
C
   50    XMIN = X
         X = (X*BINV)*ONE
         CALL DSTOR2 (X*XINT, X*T)
         IF (D1 .EQ. D2) GO TO 90
         IF (X + X .EQ. ZERO .OR. DABS(X) .GE. XMIN) GO TO 90
         CALL DSTOR2 (X, P*X)
         IF (T*D2 .EQ. T*X) GO TO 80
         K = K + 1
         GO TO 50
C
C     IF THERE IS LOSS OF ACCURACY NOT DUE TO UNDERFLOW
C     THEN SET J = NUMBER OF DIGITS POSSIBLY LOST DUE TO
C     THIS LOSS OF ACCURACY.
C
   80 CALL DSTOR2 (X, Q*X)
      IF (T*D2 .NE. T*X) GO TO 90
   81    Z = X
         J = J + 1
         X = (X*BINV)*ONE
         CALL DSTOR2 (X*XINT, X*T)
         IF (D1 .EQ. D2) GO TO 90
         IF (X + X .NE. ZERO .AND. DABS(X) .LT. Z) GO TO 81
C
   90 MINEXP = 1 - K
C-----------------------------------------------------------------------
C     DEFINE AN INITIAL APPROXIMATION FOR MAXEXP AND XMIN
C     WHEN MAXEXP .LE. 0 ON INPUT
C-----------------------------------------------------------------------
      IF (MAXEXP .GT. 0) GO TO 101
      IF (IBETA .EQ. 2 .OR. IBETA .EQ. 8 .OR.
     *    IBETA .EQ. 16) GO TO 100
C
         MAXEXP = K - 3
         IF (N .GT. 0) WRITE (N,200) MAXEXP
         T = ONE/(B2*B2*XMIN)
         XMAX = (XMAX*T)*B
         GO TO 110
C
  100 K = K + J
      IF (K + K .GT. KM + 2) KM = KM + KM
      MAXEXP = KM - K - 3
  101 IF (N .GT. 0) WRITE (N,200) MAXEXP
      T = B**(MAXEXP - 2)
      XMAX = ((XMAX*T)*B)*B
C-----------------------------------------------------------------------
C     CHECK THE APPROXIMATION FOR MAXEXP
C-----------------------------------------------------------------------
  110 CALL DSTOR2 (T, T*P)
      IF (D1 .EQ. D2) GO TO 150
      IF (N .LE. 0) RETURN
C-----------------------------------------------------------------------
C     LOOP TO FIND THE EXACT LARGEST VALUE FOR MAXEXP
C-----------------------------------------------------------------------
      WRITE (N,210) MAXEXP
      DO 120 L = 1,500
         T = T*B
         XMAX = XMAX*B
         MAXEXP = MAXEXP + 1
         CALL DSTOR2 (T, T*P)
         IF (D1 .EQ. D2) GO TO 150
         WRITE (N,220) MAXEXP
  120 CONTINUE
      WRITE (N,240)
      STOP
C-----------------------------------------------------------------------
C     REPORTING OVERFLOW ON UNIT N
C-----------------------------------------------------------------------
  150 IF (N .GT. 0) WRITE (N,230)
      STOP
C-----------------------------------------------------------------------
C     FORMAT STATEMENTS
C-----------------------------------------------------------------------
  200 FORMAT (51H THE INITIAL APPROXIMATION FOR IDMAX (OR MAXEXP) IS//
     *        I25//
     *        47H IF NO FURTHER INFORMATION APPEARS ON THIS FILE/
     *        51H THEN SET IDMAX (OR MAXEXP) TO A SMALLER VALUE THAN/
     *        39H THIS APPROXIMATION AND RERUN THE CODE.//)
  210 FORMAT (51H THE LOOP TO FIND THE LARGEST POSSIBLE EXPONENT HAS/
     *        49H BEGUN. SET IDMAX (OR MAXEXP) TO THE LAST INTEGER/
     *        14H THAT FOLLOWS.//I25)
  220 FORMAT (I25)
  230 FORMAT (32H0  ****** OVERFLOW OCCURS ******)
  240 FORMAT(/46H ****** 500 PASSES WERE MADE THROUGH THE LOOP./
     *        45H        THE MAXIMUM EXPONENT CANNOT BE FOUND./
     *        44H        IF ONE WISHES, SET IDMAX (OR MAXEXP)/
     *        45H        TO A LARGER VALUE AND RERUN THE CODE./)
C-----------------------------------------------------------------------
      END
      SUBROUTINE DSTOR2 (A, B)
C-----------------------------------------------------------------------
C     STORAGE OF DOUBLE PRECISION INFORMATION INTO MEMORY
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, B, D1, D2
      COMMON /DPDATA/ D1, D2
      D1 = A
      D2 = B
      RETURN
      END
      REAL FUNCTION SPMPAR (I)
C-----------------------------------------------------------------------
C
C     SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR
C     THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
C     I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
C     SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
C     ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN
C
C        SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,
C
C        SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
C
C        SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
C
C-----------------------------------------------------------------------
C     WRITTEN BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN VIRGINIA
C-----------------------------------------------------------------------
      INTEGER EMIN, EMAX
C
      IF (I .GT. 1) GO TO 10
         B = IPMPAR(4)
         M = IPMPAR(5)
         SPMPAR = B**(1 - M)
         RETURN
C
   10 IF (I .GT. 2) GO TO 20
         B = IPMPAR(4)
         EMIN = IPMPAR(6)
         ONE = FLOAT(1)
         BINV = ONE/B
         W = B**(EMIN + 2)
         SPMPAR = ((W * BINV) * BINV) * BINV
         RETURN
C
   20 IBETA = IPMPAR(4)
      M = IPMPAR(5)
      EMAX = IPMPAR(7)
C
      B = IBETA
      BM1 = IBETA - 1
      ONE = FLOAT(1)
      Z = B**(M - 1)
      W = ((Z - ONE)*B + BM1)/(B*Z)
C
      Z = B**(EMAX - 2)
      SPMPAR = ((W * Z) * B) * B
      RETURN
      END
      DOUBLE PRECISION FUNCTION DPMPAR (I)
C-----------------------------------------------------------------------
C
C     DPMPAR PROVIDES THE DOUBLE PRECISION MACHINE CONSTANTS FOR
C     THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
C     I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
C     DOUBLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
C     ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN
C
C        DPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,
C
C        DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
C
C        DPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
C
C-----------------------------------------------------------------------
C     WRITTEN BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN VIRGINIA
C-----------------------------------------------------------------------
      INTEGER EMIN, EMAX
      DOUBLE PRECISION B, BINV, BM1, ONE, W, Z
C
      IF (I .GT. 1) GO TO 10
         B = IPMPAR(4)
         M = IPMPAR(8)
         DPMPAR = B**(1 - M)
         RETURN
C
   10 IF (I .GT. 2) GO TO 20
         B = IPMPAR(4)
         EMIN = IPMPAR(9)
         ONE = FLOAT(1)
         BINV = ONE/B
         W = B**(EMIN + 2)
         DPMPAR = ((W * BINV) * BINV) * BINV
         RETURN
C
   20 IBETA = IPMPAR(4)
      M = IPMPAR(8)
      EMAX = IPMPAR(10)
C
      B = IBETA
      BM1 = IBETA - 1
      ONE = FLOAT(1)
      Z = B**(M - 1)
      W = ((Z - ONE)*B + BM1)/(B*Z)
C
      Z = B**(EMAX - 2)
      DPMPAR = ((W * Z) * B) * B
      RETURN
      END
      REAL FUNCTION EPSLN (L)
C--------------------------------------------------------------------
C     THE EVALUATION OF LN(EPS) WHERE EPS IS THE SMALLEST NUMBER
C     SUCH THAT 1.0 + EPS .GT. 1.0 .  L IS A DUMMY ARGUMENT.
C--------------------------------------------------------------------
      INTEGER B
      REAL LNB
C
      B = IPMPAR(4)
      IF (B .NE. 2) GO TO 10
         LNB = .69314718055995
         GO TO 50
   10 IF (B .NE. 8) GO TO 20
         LNB = 2.0794415416798
         GO TO 50
   20 IF (B .NE. 16) GO TO 30
         LNB = 2.7725887222398
         GO TO 50
   30 LNB = ALOG(FLOAT(B))
C
   50 M = 1 - IPMPAR(5)
      EPSLN = M * LNB
      RETURN
      END
      DOUBLE PRECISION FUNCTION DEPSLN (L)
C--------------------------------------------------------------------
C     THE EVALUATION OF LN(EPS) WHERE EPS IS THE SMALLEST NUMBER
C     SUCH THAT 1.D0 + EPS .GT. 1.D0 .  L IS A DUMMY ARGUMENT.
C--------------------------------------------------------------------
      INTEGER B
      DOUBLE PRECISION DB, LNB, M
C
      B = IPMPAR(4)
      IF (B .NE. 2) GO TO 10
         LNB = .693147180559945309417232121458D+00
         GO TO 50
   10 IF (B .NE. 8) GO TO 20
         LNB = 2.07944154167983592825169636437D+00
         GO TO 50
   20 IF (B .NE. 16) GO TO 30
         LNB = 2.77258872223978123766892848583D+00
         GO TO 50
   30 DB = B
      LNB = DLOG(DB)
C
   50 M = 1 - IPMPAR(8)
      DEPSLN = M * LNB
      RETURN
      END
      REAL FUNCTION EXPARG (L)
C--------------------------------------------------------------------
C     IF L = 0 THEN  EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
C     EXP(W) CAN BE COMPUTED.
C
C     IF L IS NONZERO THEN  EXPARG(L) = THE LARGEST NEGATIVE W FOR
C     WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO.
C
C     NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED.
C--------------------------------------------------------------------
      INTEGER B
      REAL LNB
C
      B = IPMPAR(4)
      IF (B .NE. 2) GO TO 10
         LNB = .69314718055995
         GO TO 50
   10 IF (B .NE. 8) GO TO 20
         LNB = 2.0794415416798
         GO TO 50
   20 IF (B .NE. 16) GO TO 30
         LNB = 2.7725887222398
         GO TO 50
   30 LNB = ALOG(FLOAT(B))
C
   50 IF (L .EQ. 0) GO TO 60
         M = IPMPAR(6) - 1
         EXPARG = 0.99999 * (M * LNB)
         RETURN
   60 M = IPMPAR(7)
      EXPARG = 0.99999 * (M * LNB)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DXPARG (L)
C--------------------------------------------------------------------
C     IF L = 0 THEN  DXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
C     DEXP(W) CAN BE COMPUTED.
C
C     IF L IS NONZERO THEN  DXPARG(L) = THE LARGEST NEGATIVE W FOR
C     WHICH THE COMPUTED VALUE OF DEXP(W) IS NONZERO.
C
C     NOTE... ONLY AN APPROXIMATE VALUE FOR DXPARG(L) IS NEEDED.
C--------------------------------------------------------------------
      INTEGER B
      DOUBLE PRECISION DB, LNB
C
      B = IPMPAR(4)
      IF (B .NE. 2) GO TO 10
         LNB = .693147180559945309417232121458D+00
         GO TO 50
   10 IF (B .NE. 8) GO TO 20
         LNB = 2.07944154167983592825169636437D+00
         GO TO 50
   20 IF (B .NE. 16) GO TO 30
         LNB = 2.77258872223978123766892848583D+00
         GO TO 50
   30 DB = B
      LNB = DLOG(DB)
C
   50 IF (L .EQ. 0) GO TO 60
         M = IPMPAR(9) - 1
         DXPARG = 0.999999999999D+00 * (M * LNB)
         RETURN
   60 M = IPMPAR(10)
      DXPARG = 0.999999999999D+00 * (M * LNB)
      RETURN
      END
      SUBROUTINE ISHELL (A, N)
C-----------------------------------------------------------------------
C     THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A
C     SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. IT IS ASSUMED THAT N.GE.1.
C-----------------------------------------------------------------------
      INTEGER A(N), K(10), S
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     1     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI
C
         JMAX = N - KI
         DO 31 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
   30          IF (S .GE. A(L)) GO TO 31
               A(LL) = A(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31    A(LL) = S
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE SHELL (A, N)
C-----------------------------------------------------------------------
C     THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A
C     SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. IT IS ASSUMED THAT N.GE.1.
C-----------------------------------------------------------------------
      REAL A(N)
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     1     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI
C
         JMAX = N - KI
         DO 31 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
   30          IF (S .GE. A(L)) GO TO 31
               A(LL) = A(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31    A(LL) = S
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE SHELL2 (A, B, N)
C-----------------------------------------------------------------------
C     THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A
C     SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE
C     PERFORMED ON B THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1.
C-----------------------------------------------------------------------
      REAL A(N), B(N)
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     1     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI
C
         JMAX = N - KI
         DO 32 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
            T = B(LL)
   30          IF (S .GE. A(L)) GO TO 31
               A(LL) = A(L)
               B(LL) = B(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31       A(LL) = S
            B(LL) = T
   32    CONTINUE
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE RSORT (A, N)
C-----------------------------------------------------------------------
C     THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A
C     SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. IT IS ASSUMED THAT N.GE.1.
C-----------------------------------------------------------------------
      REAL A(N)
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     1     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI
C
         JMAX = N - KI
         DO 31 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
   30          IF (S .GE. A(L)) GO TO 31
               A(LL) = A(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31    A(LL) = S
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE RISORT (A, M, N)
C-----------------------------------------------------------------------
C     THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A
C     SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE
C     PERFORMED ON M THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1.
C-----------------------------------------------------------------------
      REAL A(N)
      INTEGER M(N), T
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     1     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI
C
         JMAX = N - KI
         DO 32 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
            T = M(LL)
   30          IF (S .GE. A(L)) GO TO 31
               A(LL) = A(L)
               M(LL) = M(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31       A(LL) = S
            M(LL) = T
   32    CONTINUE
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE RRSORT (A, B, N)
C-----------------------------------------------------------------------
C     THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A
C     SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE
C     PERFORMED ON B THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1.
C-----------------------------------------------------------------------
      REAL A(N), B(N)
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     1     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI
C
         JMAX = N - KI
         DO 32 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
            T = B(LL)
   30          IF (S .GE. A(L)) GO TO 31
               A(LL) = A(L)
               B(LL) = B(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31       A(LL) = S
            B(LL) = T
   32    CONTINUE
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE DSORT (A, N)
C-----------------------------------------------------------------------
C     THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A
C     SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. IT IS ASSUMED THAT N.GE.1.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(N), S
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     1     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI
C
         JMAX = N - KI
         DO 31 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
   30          IF (S .GE. A(L)) GO TO 31
               A(LL) = A(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31    A(LL) = S
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE DISORT (A, M, N)
C-----------------------------------------------------------------------
C     THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A
C     SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE
C     PERFORMED ON M THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(N), S
      INTEGER M(N), T
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     1     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI
C
         JMAX = N - KI
         DO 32 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
            T = M(LL)
   30          IF (S .GE. A(L)) GO TO 31
               A(LL) = A(L)
               M(LL) = M(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31       A(LL) = S
            M(LL) = T
   32    CONTINUE
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE DDSORT (A, B, N)
C-----------------------------------------------------------------------
C     THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A
C     SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE
C     PERFORMED ON B THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(N), B(N), S, T
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     1     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI
C
         JMAX = N - KI
         DO 32 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
            T = B(LL)
   30          IF (S .GE. A(L)) GO TO 31
               A(LL) = A(L)
               B(LL) = B(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31       A(LL) = S
            B(LL) = T
   32    CONTINUE
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE AORD (A, N)
C-----------------------------------------------------------------------
C     THE AORD SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF
C     A SO THAT ABS(A(I)) .LE. ABS(A(I+1)) FOR I = 1,...,N-1. IT IS
C     ASSUMED THAT N .GE. 1.
C-----------------------------------------------------------------------
      REAL A(N)
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     *     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C                 SO THAT ABS(A(J)) .LE. ABS(A(J+KI))
C
         JMAX = N - KI
         DO 31 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
   30          IF (ABS(S) .GE. ABS(A(L))) GO TO 31
               A(LL) = A(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31    A(LL) = S
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE DAORD (A, N)
C-----------------------------------------------------------------------
C     DAORD IS USED TO REORDER THE ELEMENTS OF THE DOUBLE PRECISION
C     ARRAY A SO THAT DABS(A(I)) .LE. DABS(A(I+1)) FOR I = 1,...,N-1.
C     IT IS ASSUMED THAT N .GE. 1.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(N), S
      INTEGER K(10)
C------------------------
      DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/,
     *     K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/
C------------------------
C
C             SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2
C
      IF (N .LT. 2) RETURN
      IMAX = 1
      DO 10 I = 3,10
         IF (N .LE. K(I)) GO TO 20
         IMAX = IMAX + 1
   10 CONTINUE
C
C            STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1)
C
   20 I = IMAX
      DO 40 II = 1,IMAX
         KI = K(I)
C
C             SORTING ELEMENTS THAT ARE KI POSITIONS APART
C               SO THAT DABS(A(J)) .LE. DABS(A(J+KI))
C
         JMAX = N - KI
         DO 31 J = 1,JMAX
            L = J
            LL = J + KI
            S = A(LL)
   30          IF (DABS(S) .GE. DABS(A(L))) GO TO 31
               A(LL) = A(L)
               LL = L
               L = L - KI
               IF (L .GT. 0) GO TO 30
   31    A(LL) = S
C
   40 I = I - 1
      RETURN
      END
      SUBROUTINE QSORTI (X, IND, N)
      INTEGER N, X(N), IND(N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C
C   THIS SUBROUTINE USES AN ORDER N*LOG(N) QUICK SORT TO
C SORT AN INTEGER ARRAY X INTO INCREASING ORDER.  THE ALGOR-
C ITHM IS AS FOLLOWS.  IND IS INITIALIZED TO THE ORDERED
C SEQUENCE OF INDICES 1,...,N, AND ALL INTERCHANGES ARE
C APPLIED TO IND.  X IS DIVIDED INTO TWO PORTIONS BY PICKING
C A CENTRAL ELEMENT T.  THE FIRST AND LAST ELEMENTS ARE COM-
C PARED WITH T, AND INTERCHANGES ARE APPLIED AS NECESSARY SO
C THAT THE THREE VALUES ARE IN ASCENDING ORDER.  INTER-
C CHANGES ARE THEN APPLIED SO THAT ALL ELEMENTS GREATER THAN
C T ARE IN THE UPPER PORTION OF THE ARRAY AND ALL ELEMENTS
C LESS THAN T ARE IN THE LOWER PORTION.  THE UPPER AND LOWER
C INDICES OF ONE OF THE PORTIONS ARE SAVED IN LOCAL ARRAYS,
C AND THE PROCESS IS REPEATED ITERATIVELY ON THE OTHER
C PORTION.  WHEN A PORTION IS COMPLETELY SORTED, THE PROCESS
C BEGINS AGAIN BY RETRIEVING THE INDICES BOUNDING ANOTHER
C UNSORTED PORTION.
C
C INPUT PARAMETERS -   N - LENGTH OF THE ARRAY X.
C
C                      X - VECTOR OF LENGTH N TO BE SORTED.
C
C                    IND - VECTOR OF LENGTH .GE. N.
C
C N AND X ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER - IND - SEQUENCE OF INDICES 1,...,N
C                          PERMUTED IN THE SAME FASHION AS X
C                          WOULD BE.  THUS, THE ORDERING ON
C                          X IS DEFINED BY Y(I) = X(IND(I)).
C
C INTRINSIC FUNCTIONS CALLED BY QSORTI - IFIX, FLOAT
C
C***********************************************************
C
C NOTE -- IU AND IL MUST BE DIMENSIONED .GE. LOG(N) WHERE
C         LOG HAS BASE 2.
C
C***********************************************************
C
      INTEGER IU(21), IL(21)
      INTEGER M, I, J, K, L, IJ, IT, ITT, INDX, T
      REAL    R
C
C LOCAL PARAMETERS -
C
C IU,IL =  TEMPORARY STORAGE FOR THE UPPER AND LOWER
C            INDICES OF PORTIONS OF THE ARRAY X
C M =      INDEX FOR IU AND IL
C I,J =    LOWER AND UPPER INDICES OF A PORTION OF X
C K,L =    INDICES IN THE RANGE I,...,J
C IJ =     RANDOMLY CHOSEN INDEX BETWEEN I AND J
C IT,ITT = TEMPORARY STORAGE FOR INTERCHANGES IN IND
C INDX =   TEMPORARY INDEX FOR X
C R =      PSEUDO RANDOM NUMBER FOR GENERATING IJ
C T =      CENTRAL ELEMENT OF X
C
      IF (N .LE. 0) RETURN
C
C INITIALIZE IND, M, I, J, AND R
C
      DO 1 I = 1,N
    1   IND(I) = I
      M = 1
      I = 1
      J = N
      R = .375
C
C TOP OF LOOP
C
    2 IF (I .GE. J) GO TO 10
      IF (R .GT. .5898437) GO TO 3
      R = R + .0390625
      GO TO 4
    3 R = R - .21875
C
C INITIALIZE K
C
    4 K = I
C
C SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T
C
      IJ = I + IFIX(R*FLOAT(J-I))
      IT = IND(IJ)
      T = X(IT)
C
C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
C   INTERCHANGE IT WITH T
C
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 5
      IND(IJ) = INDX
      IND(I) = IT
      IT = INDX
      T = X(IT)
C
C INITIALIZE L
C
    5 L = J
C
C IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T,
C   INTERCHANGE IT WITH T
C
      INDX = IND(J)
      IF (X(INDX) .GE. T) GO TO 7
      IND(IJ) = INDX
      IND(J) = IT
      IT = INDX
      T = X(IT)
C
C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
C   INTERCHANGE IT WITH T
C
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 7
      IND(IJ) = INDX
      IND(I) = IT
      IT = INDX
      T = X(IT)
      GO TO 7
C
C INTERCHANGE ELEMENTS K AND L
C
    6 ITT = IND(L)
      IND(L) = IND(K)
      IND(K) = ITT
C
C FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS
C   NOT LARGER THAN T
C
    7 L = L - 1
      INDX = IND(L)
      IF (X(INDX) .GT. T) GO TO 7
C
C FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS
C   NOT SMALLER THAN T
C
    8 K = K + 1
      INDX = IND(K)
      IF (X(INDX) .LT. T) GO TO 8
C
C IF K .LE. L, INTERCHANGE ELEMENTS K AND L
C
      IF (K .LE. L) GO TO 6
C
C SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE
C   ARRAY YET TO BE SORTED
C
      IF (L-I .LE. J-K) GO TO 9
      IL(M) = I
      IU(M) = L
      I = K
      M = M + 1
      GO TO 11
C
    9 IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 11
C
C BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY
C
   10 M = M - 1
      IF (M .EQ. 0) RETURN
      I = IL(M)
      J = IU(M)
C
   11 IF (J-I .GE. 11) GO TO 4
      IF (I .EQ. 1) GO TO 2
      I = I - 1
C
C SORT ELEMENTS I+1,...,J.  NOTE THAT 1 .LE. I .LT. J AND
C   J-I .LT. 11.
C
   12 I = I + 1
      IF (I .EQ. J) GO TO 10
      INDX = IND(I+1)
      T = X(INDX)
      IT = INDX
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 12
      K = I
C
   13 IND(K+1) = IND(K)
      K = K - 1
      INDX = IND(K)
      IF (T .LT. X(INDX)) GO TO 13
      IND(K+1) = IT
      GO TO 12
      END
      SUBROUTINE QSORTR (X, IND, N)
      INTEGER N, IND(N)
      REAL    X(N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C
C   THIS SUBROUTINE USES AN ORDER N*LOG(N) QUICK SORT TO
C SORT THE REAL ARRAY X INTO INCREASING ORDER.  THE ALGOR-
C ITHM IS AS FOLLOWS.  IND IS INITIALIZED TO THE ORDERED
C SEQUENCE OF INDICES 1,...,N, AND ALL INTERCHANGES ARE
C APPLIED TO IND.  X IS DIVIDED INTO TWO PORTIONS BY PICKING
C A CENTRAL ELEMENT T.  THE FIRST AND LAST ELEMENTS ARE COM-
C PARED WITH T, AND INTERCHANGES ARE APPLIED AS NECESSARY SO
C THAT THE THREE VALUES ARE IN ASCENDING ORDER.  INTER-
C CHANGES ARE THEN APPLIED SO THAT ALL ELEMENTS GREATER THAN
C T ARE IN THE UPPER PORTION OF THE ARRAY AND ALL ELEMENTS
C LESS THAN T ARE IN THE LOWER PORTION.  THE UPPER AND LOWER
C INDICES OF ONE OF THE PORTIONS ARE SAVED IN LOCAL ARRAYS,
C AND THE PROCESS IS REPEATED ITERATIVELY ON THE OTHER
C PORTION.  WHEN A PORTION IS COMPLETELY SORTED, THE PROCESS
C BEGINS AGAIN BY RETRIEVING THE INDICES BOUNDING ANOTHER
C UNSORTED PORTION.
C
C INPUT PARAMETERS -   N - LENGTH OF THE ARRAY X.
C
C                      X - VECTOR OF LENGTH N TO BE SORTED.
C
C                    IND - VECTOR OF LENGTH .GE. N.
C
C N AND X ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER - IND - SEQUENCE OF INDICES 1,...,N
C                          PERMUTED IN THE SAME FASHION AS X
C                          WOULD BE.  THUS, THE ORDERING ON
C                          X IS DEFINED BY Y(I) = X(IND(I)).
C
C INTRINSIC FUNCTIONS CALLED BY QSORTR - IFIX, FLOAT
C
C***********************************************************
C
C NOTE -- IU AND IL MUST BE DIMENSIONED .GE. LOG(N) WHERE
C         LOG HAS BASE 2.
C
C***********************************************************
C
      INTEGER IU(21), IL(21)
      INTEGER M, I, J, K, L, IJ, IT, ITT, INDX
      REAL    R, T
C
C LOCAL PARAMETERS -
C
C IU,IL =  TEMPORARY STORAGE FOR THE UPPER AND LOWER
C            INDICES OF PORTIONS OF THE ARRAY X
C M =      INDEX FOR IU AND IL
C I,J =    LOWER AND UPPER INDICES OF A PORTION OF X
C K,L =    INDICES IN THE RANGE I,...,J
C IJ =     RANDOMLY CHOSEN INDEX BETWEEN I AND J
C IT,ITT = TEMPORARY STORAGE FOR INTERCHANGES IN IND
C INDX =   TEMPORARY INDEX FOR X
C R =      PSEUDO RANDOM NUMBER FOR GENERATING IJ
C T =      CENTRAL ELEMENT OF X
C
      IF (N .LE. 0) RETURN
C
C INITIALIZE IND, M, I, J, AND R
C
      DO 1 I = 1,N
    1   IND(I) = I
      M = 1
      I = 1
      J = N
      R = .375
C
C TOP OF LOOP
C
    2 IF (I .GE. J) GO TO 10
      IF (R .GT. .5898437) GO TO 3
      R = R + .0390625
      GO TO 4
    3 R = R - .21875
C
C INITIALIZE K
C
    4 K = I
C
C SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T
C
      IJ = I + IFIX(R*FLOAT(J-I))
      IT = IND(IJ)
      T = X(IT)
C
C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
C   INTERCHANGE IT WITH T
C
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 5
      IND(IJ) = INDX
      IND(I) = IT
      IT = INDX
      T = X(IT)
C
C INITIALIZE L
C
    5 L = J
C
C IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T,
C   INTERCHANGE IT WITH T
C
      INDX = IND(J)
      IF (X(INDX) .GE. T) GO TO 7
      IND(IJ) = INDX
      IND(J) = IT
      IT = INDX
      T = X(IT)
C
C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
C   INTERCHANGE IT WITH T
C
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 7
      IND(IJ) = INDX
      IND(I) = IT
      IT = INDX
      T = X(IT)
      GO TO 7
C
C INTERCHANGE ELEMENTS K AND L
C
    6 ITT = IND(L)
      IND(L) = IND(K)
      IND(K) = ITT
C
C FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS
C   NOT LARGER THAN T
C
    7 L = L - 1
      INDX = IND(L)
      IF (X(INDX) .GT. T) GO TO 7
C
C FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS
C   NOT SMALLER THAN T
C
    8 K = K + 1
      INDX = IND(K)
      IF (X(INDX) .LT. T) GO TO 8
C
C IF K .LE. L, INTERCHANGE ELEMENTS K AND L
C
      IF (K .LE. L) GO TO 6
C
C SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE
C   ARRAY YET TO BE SORTED
C
      IF (L-I .LE. J-K) GO TO 9
      IL(M) = I
      IU(M) = L
      I = K
      M = M + 1
      GO TO 11
C
    9 IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 11
C
C BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY
C
   10 M = M - 1
      IF (M .EQ. 0) RETURN
      I = IL(M)
      J = IU(M)
C
   11 IF (J-I .GE. 11) GO TO 4
      IF (I .EQ. 1) GO TO 2
      I = I - 1
C
C SORT ELEMENTS I+1,...,J.  NOTE THAT 1 .LE. I .LT. J AND
C   J-I .LT. 11.
C
   12 I = I + 1
      IF (I .EQ. J) GO TO 10
      INDX = IND(I+1)
      T = X(INDX)
      IT = INDX
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 12
      K = I
C
   13 IND(K+1) = IND(K)
      K = K - 1
      INDX = IND(K)
      IF (T .LT. X(INDX)) GO TO 13
      IND(K+1) = IT
      GO TO 12
      END
      SUBROUTINE QSORTD (X, IND, N)
      INTEGER N, IND(N)
      DOUBLE PRECISION X(N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C
C   THIS SUBROUTINE USES AN ORDER N*LOG(N) QUICK SORT TO
C SORT A DOUBLE PRECISION ARRAY X INTO INCREASING ORDER. THE
C ALGORITHM IS AS FOLLOWS. IND IS INITIALIZED TO THE ORDERED
C SEQUENCE OF INDICES 1,...,N, AND ALL INTERCHANGES ARE
C APPLIED TO IND.  X IS DIVIDED INTO TWO PORTIONS BY PICKING
C A CENTRAL ELEMENT T.  THE FIRST AND LAST ELEMENTS ARE COM-
C PARED WITH T, AND INTERCHANGES ARE APPLIED AS NECESSARY SO
C THAT THE THREE VALUES ARE IN ASCENDING ORDER.  INTER-
C CHANGES ARE THEN APPLIED SO THAT ALL ELEMENTS GREATER THAN
C T ARE IN THE UPPER PORTION OF THE ARRAY AND ALL ELEMENTS
C LESS THAN T ARE IN THE LOWER PORTION.  THE UPPER AND LOWER
C INDICES OF ONE OF THE PORTIONS ARE SAVED IN LOCAL ARRAYS,
C AND THE PROCESS IS REPEATED ITERATIVELY ON THE OTHER
C PORTION.  WHEN A PORTION IS COMPLETELY SORTED, THE PROCESS
C BEGINS AGAIN BY RETRIEVING THE INDICES BOUNDING ANOTHER
C UNSORTED PORTION.
C
C INPUT PARAMETERS -   N - LENGTH OF THE ARRAY X.
C
C                      X - VECTOR OF LENGTH N TO BE SORTED.
C
C                    IND - VECTOR OF LENGTH .GE. N.
C
C N AND X ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER - IND - SEQUENCE OF INDICES 1,...,N
C                          PERMUTED IN THE SAME FASHION AS X
C                          WOULD BE.  THUS, THE ORDERING ON
C                          X IS DEFINED BY Y(I) = X(IND(I)).
C
C INTRINSIC FUNCTIONS CALLED BY QSORTD - IFIX, FLOAT
C
C***********************************************************
C
C NOTE -- IU AND IL MUST BE DIMENSIONED .GE. LOG(N) WHERE
C         LOG HAS BASE 2.
C
C***********************************************************
C
      INTEGER IU(21), IL(21)
      INTEGER M, I, J, K, L, IJ, IT, ITT, INDX
      REAL    R
      DOUBLE PRECISION T
C
C LOCAL PARAMETERS -
C
C IU,IL =  TEMPORARY STORAGE FOR THE UPPER AND LOWER
C            INDICES OF PORTIONS OF THE ARRAY X
C M =      INDEX FOR IU AND IL
C I,J =    LOWER AND UPPER INDICES OF A PORTION OF X
C K,L =    INDICES IN THE RANGE I,...,J
C IJ =     RANDOMLY CHOSEN INDEX BETWEEN I AND J
C IT,ITT = TEMPORARY STORAGE FOR INTERCHANGES IN IND
C INDX =   TEMPORARY INDEX FOR X
C R =      PSEUDO RANDOM NUMBER FOR GENERATING IJ
C T =      CENTRAL ELEMENT OF X
C
      IF (N .LE. 0) RETURN
C
C INITIALIZE IND, M, I, J, AND R
C
      DO 1 I = 1,N
    1   IND(I) = I
      M = 1
      I = 1
      J = N
      R = .375
C
C TOP OF LOOP
C
    2 IF (I .GE. J) GO TO 10
      IF (R .GT. .5898437) GO TO 3
      R = R + .0390625
      GO TO 4
    3 R = R - .21875
C
C INITIALIZE K
C
    4 K = I
C
C SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T
C
      IJ = I + IFIX(R*FLOAT(J-I))
      IT = IND(IJ)
      T = X(IT)
C
C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
C   INTERCHANGE IT WITH T
C
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 5
      IND(IJ) = INDX
      IND(I) = IT
      IT = INDX
      T = X(IT)
C
C INITIALIZE L
C
    5 L = J
C
C IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T,
C   INTERCHANGE IT WITH T
C
      INDX = IND(J)
      IF (X(INDX) .GE. T) GO TO 7
      IND(IJ) = INDX
      IND(J) = IT
      IT = INDX
      T = X(IT)
C
C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T,
C   INTERCHANGE IT WITH T
C
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 7
      IND(IJ) = INDX
      IND(I) = IT
      IT = INDX
      T = X(IT)
      GO TO 7
C
C INTERCHANGE ELEMENTS K AND L
C
    6 ITT = IND(L)
      IND(L) = IND(K)
      IND(K) = ITT
C
C FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS
C   NOT LARGER THAN T
C
    7 L = L - 1
      INDX = IND(L)
      IF (X(INDX) .GT. T) GO TO 7
C
C FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS
C   NOT SMALLER THAN T
C
    8 K = K + 1
      INDX = IND(K)
      IF (X(INDX) .LT. T) GO TO 8
C
C IF K .LE. L, INTERCHANGE ELEMENTS K AND L
C
      IF (K .LE. L) GO TO 6
C
C SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE
C   ARRAY YET TO BE SORTED
C
      IF (L-I .LE. J-K) GO TO 9
      IL(M) = I
      IU(M) = L
      I = K
      M = M + 1
      GO TO 11
C
    9 IL(M) = K
      IU(M) = J
      J = L
      M = M + 1
      GO TO 11
C
C BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY
C
   10 M = M - 1
      IF (M .EQ. 0) RETURN
      I = IL(M)
      J = IU(M)
C
   11 IF (J-I .GE. 11) GO TO 4
      IF (I .EQ. 1) GO TO 2
      I = I - 1
C
C SORT ELEMENTS I+1,...,J.  NOTE THAT 1 .LE. I .LT. J AND
C   J-I .LT. 11.
C
   12 I = I + 1
      IF (I .EQ. J) GO TO 10
      INDX = IND(I+1)
      T = X(INDX)
      IT = INDX
      INDX = IND(I)
      IF (X(INDX) .LE. T) GO TO 12
      K = I
C
   13 IND(K+1) = IND(K)
      K = K - 1
      INDX = IND(K)
      IF (T .LT. X(INDX)) GO TO 13
      IND(K+1) = IT
      GO TO 12
      END
      SUBROUTINE IORDER (A, IP, N)
      INTEGER N, A(N), IP(N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C
C   THIS ROUTINE APPLIES A SET OF PERMUTATIONS TO A VECTOR.
C
C INPUT PARAMETERS -  N - LENGTH OF A AND IP.
C
C                    IP - VECTOR CONTAINING THE SEQUENCE OF
C                         INTEGERS 1,...,N PERMUTED IN THE
C                         SAME FASHION THAT A IS TO BE PER-
C                         MUTED.
C
C                     A - VECTOR TO BE PERMUTED.
C
C N AND IP ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER -  A - REORDERED VECTOR REFLECTING THE
C                         PERMUTATIONS DEFINED BY IP.
C
C***********************************************************
C
      INTEGER NN, K, J, IPJ, TEMP
C
C LOCAL PARAMETERS -
C
C NN =   LOCAL COPY OF N
C K =    INDEX FOR IP AND FOR THE FIRST ELEMENT OF A IN A
C          PERMUTATION
C J =    INDEX FOR IP AND A, J .GE. K
C IPJ =  IP(J)
C TEMP = TEMPORARY STORAGE FOR A(K)
C
      NN = N
      IF (NN .LT. 2) RETURN
      K = 1
C
C LOOP ON PERMUTATIONS
C
    1 J = K
      TEMP = A(K)
C
C APPLY PERMUTATION TO A.  IP(J) IS MARKED (MADE NEGATIVE)
C   AS BEING INCLUDED IN THE PERMUTATION.
C
    2 IPJ = IP(J)
      IP(J) = -IPJ
      IF (IPJ .EQ. K) GO TO 3
      A(J) = A(IPJ)
      J = IPJ
      GO TO 2
    3 A(J) = TEMP
C
C SEARCH FOR AN UNMARKED ELEMENT OF IP
C
    4 K = K + 1
      IF (K .GT. NN) GO TO 5
      IF (IP(K) .GT. 0) GO TO 1
      GO TO 4
C
C ALL PERMUTATIONS HAVE BEEN APPLIED.  UNMARK IP.
C
    5 DO 6 K = 1,NN
    6   IP(K) = -IP(K)
      RETURN
      END
      SUBROUTINE RORDER (A, IP, N)
      INTEGER N, IP(N)
      REAL    A(N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C
C   THIS ROUTINE APPLIES A SET OF PERMUTATIONS TO A VECTOR.
C
C INPUT PARAMETERS -  N - LENGTH OF A AND IP.
C
C                    IP - VECTOR CONTAINING THE SEQUENCE OF
C                         INTEGERS 1,...,N PERMUTED IN THE
C                         SAME FASHION THAT A IS TO BE PER-
C                         MUTED.
C
C                     A - VECTOR TO BE PERMUTED.
C
C N AND IP ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER -  A - REORDERED VECTOR REFLECTING THE
C                         PERMUTATIONS DEFINED BY IP.
C
C***********************************************************
C
      INTEGER NN, K, J, IPJ
      REAL    TEMP
C
C LOCAL PARAMETERS -
C
C NN =   LOCAL COPY OF N
C K =    INDEX FOR IP AND FOR THE FIRST ELEMENT OF A IN A
C          PERMUTATION
C J =    INDEX FOR IP AND A, J .GE. K
C IPJ =  IP(J)
C TEMP = TEMPORARY STORAGE FOR A(K)
C
      NN = N
      IF (NN .LT. 2) RETURN
      K = 1
C
C LOOP ON PERMUTATIONS
C
    1 J = K
      TEMP = A(K)
C
C APPLY PERMUTATION TO A.  IP(J) IS MARKED (MADE NEGATIVE)
C   AS BEING INCLUDED IN THE PERMUTATION.
C
    2 IPJ = IP(J)
      IP(J) = -IPJ
      IF (IPJ .EQ. K) GO TO 3
      A(J) = A(IPJ)
      J = IPJ
      GO TO 2
    3 A(J) = TEMP
C
C SEARCH FOR AN UNMARKED ELEMENT OF IP
C
    4 K = K + 1
      IF (K .GT. NN) GO TO 5
      IF (IP(K) .GT. 0) GO TO 1
      GO TO 4
C
C ALL PERMUTATIONS HAVE BEEN APPLIED.  UNMARK IP.
C
    5 DO 6 K = 1,NN
    6   IP(K) = -IP(K)
      RETURN
      END
      SUBROUTINE DORDER (A, IP, N)
      INTEGER N, IP(N)
      DOUBLE PRECISION A(N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C
C   THIS ROUTINE APPLIES A SET OF PERMUTATIONS TO A VECTOR.
C
C INPUT PARAMETERS -  N - LENGTH OF A AND IP.
C
C                    IP - VECTOR CONTAINING THE SEQUENCE OF
C                         INTEGERS 1,...,N PERMUTED IN THE
C                         SAME FASHION THAT A IS TO BE PER-
C                         MUTED.
C
C                     A - VECTOR TO BE PERMUTED.
C
C N AND IP ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER -  A - REORDERED VECTOR REFLECTING THE
C                         PERMUTATIONS DEFINED BY IP.
C
C***********************************************************
C
      INTEGER NN, K, J, IPJ
      DOUBLE PRECISION TEMP
C
C LOCAL PARAMETERS -
C
C NN =   LOCAL COPY OF N
C K =    INDEX FOR IP AND FOR THE FIRST ELEMENT OF A IN A
C          PERMUTATION
C J =    INDEX FOR IP AND A, J .GE. K
C IPJ =  IP(J)
C TEMP = TEMPORARY STORAGE FOR A(K)
C
      NN = N
      IF (NN .LT. 2) RETURN
      K = 1
C
C LOOP ON PERMUTATIONS
C
    1 J = K
      TEMP = A(K)
C
C APPLY PERMUTATION TO A.  IP(J) IS MARKED (MADE NEGATIVE)
C   AS BEING INCLUDED IN THE PERMUTATION.
C
    2 IPJ = IP(J)
      IP(J) = -IPJ
      IF (IPJ .EQ. K) GO TO 3
      A(J) = A(IPJ)
      J = IPJ
      GO TO 2
    3 A(J) = TEMP
C
C SEARCH FOR AN UNMARKED ELEMENT OF IP
C
    4 K = K + 1
      IF (K .GT. NN) GO TO 5
      IF (IP(K) .GT. 0) GO TO 1
      GO TO 4
C
C ALL PERMUTATIONS HAVE BEEN APPLIED.  UNMARK IP.
C
    5 DO 6 K = 1,NN
    6   IP(K) = -IP(K)
      RETURN
      END
      REAL FUNCTION CBRT (X)
C-----------------------------------------------------------------------
C                   CUBE ROOT OF A REAL NUMBER
C-----------------------------------------------------------------------
      IF (X) 30, 10, 20
   10 CBRT = 0.0
      RETURN
   20 R = ALOG(X)/3.0
      CBRT = EXP(R)
      RETURN
   30 R = ALOG(-X)/3.0
      CBRT = -EXP(R)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DCBRT (X)
C-----------------------------------------------------------------------
C                   CUBE ROOT OF A REAL NUMBER
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, R
C
      IF (X) 30, 10, 20
   10 DCBRT = 0.D0
      RETURN
   20 R = DLOG(X)/3.D0
      DCBRT = DEXP(R)
      RETURN
   30 R = DLOG(-X)/3.D0
      DCBRT = -DEXP(R)
      RETURN
      END
      FUNCTION ARTNQ(Y,X)
      IF (X) 1,2,5
    1 ARTNQ=ATAN(Y/X)+3.1415926535898
      RETURN
    2 IF (Y) 3,8,4
    3 ARTNQ=4.7123889803847
      RETURN
    4 ARTNQ=1.5707963267949
      RETURN
    5 IF (Y) 6,8,7
    6 ARTNQ=ATAN(Y/X)+6.2831853071795
      RETURN
    7 ARTNQ=ATAN(Y/X)
      RETURN
    8 ARTNQ=0.
      RETURN
      END
      DOUBLE PRECISION FUNCTION DARTNQ(Y,X)
      DOUBLE PRECISION X,Y
      IF (X) 1,2,5
    1 DARTNQ=DATAN(Y/X)+3.14159265358979323846264338328D0
      RETURN
    2 IF (Y) 3,8,4
    3 DARTNQ=4.71238898038468985769396507492D0
      RETURN
    4 DARTNQ=1.57079632679489661923132169164D0
      RETURN
    5 IF (Y) 6,8,7
    6 DARTNQ=DATAN(Y/X)+6.28318530717958647692528676656D0
      RETURN
    7 DARTNQ=DATAN(Y/X)
      RETURN
    8 DARTNQ=0.D0
      RETURN
      END
      REAL FUNCTION CPABS(X, Y)
C     --------------------------------------
C     EVALUATION OF SQRT(X*X + Y*Y)
C     --------------------------------------
      IF (ABS(X) .LE. ABS(Y)) GO TO 10
         A = Y/X
         CPABS = ABS(X)*SQRT(1.0 + A*A)
         RETURN
   10 IF (Y .EQ. 0.0) GO TO 20
         A = X/Y
         CPABS = ABS(Y)*SQRT(1.0 + A*A)
         RETURN
   20 CPABS = 0.0
      RETURN
      END
      DOUBLE PRECISION FUNCTION DCPABS(X, Y)
      DOUBLE PRECISION X, Y
C     --------------------------------------
C     EVALUATION OF SQRT(X*X + Y*Y)
C     --------------------------------------
      DOUBLE PRECISION A
C
      IF (DABS(X) .LE. DABS(Y)) GO TO 10
         A = Y/X
         DCPABS = DABS(X)*DSQRT(1.D0 + A*A)
         RETURN
   10 IF (Y .EQ. 0.D0) GO TO 20
         A = X/Y
         DCPABS = DABS(Y)*DSQRT(1.D0 + A*A)
         RETURN
   20 DCPABS = 0.D0
      RETURN
      END
      SUBROUTINE CREC (X, Y, U, V)
C-----------------------------------------------------------------------
C             COMPLEX RECIPROCAL U + I*V = 1/(X + I*Y)
C-----------------------------------------------------------------------
      IF (ABS(X) .GT. ABS(Y)) GO TO 10
         T = X/Y
         D = Y + T*X
         U = T/D
         V = -1.0/D
         RETURN
   10 T = Y/X
      D = X + T*Y
      U = 1.0/D
      V = -T/D
      RETURN
      END
      SUBROUTINE DCREC (X, Y, U, V)
C-----------------------------------------------------------------------
C             COMPLEX RECIPROCAL U + I*V = 1/(X + I*Y)
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, Y, U, V
      DOUBLE PRECISION D, T
C
      IF (DABS(X) .GT. DABS(Y)) GO TO 10
         T = X/Y
         D = Y + T*X
         U = T/D
         V = -1.D0/D
         RETURN
   10 T = Y/X
      D = X + T*Y
      U = 1.D0/D
      V = -T/D
      RETURN
      END
      COMPLEX FUNCTION CDIV (A, B)
C-----------------------------------------------------------------------
C              COMPLEX DIVISION A/B WHERE B IS NONZERO
C-----------------------------------------------------------------------
      COMPLEX A, B
C
      AR = REAL(A)
      AI = AIMAG(A)
      BR = REAL(B)
      BI = AIMAG(B)
C
      IF (ABS(BR) .LT. ABS(BI)) GO TO 10
         T = BI/BR
         D = BR + T*BI
         U = (AR + AI*T)/D
         V = (AI - AR*T)/D
         CDIV = CMPLX(U,V)
         RETURN
   10 T = BR/BI
      D = BI + T*BR
      U = (AR*T + AI)/D
      V = (AI*T - AR)/D
      CDIV = CMPLX(U,V)
      RETURN
      END
      SUBROUTINE CDIVID (AR,AI,BR,BI,CR,CI)
C-----------------------------------------------------------------------
C     DOUBLE PRECISION COMPLEX DIVISION C = A/B AVOIDING OVERFLOW
C-----------------------------------------------------------------------
      DOUBLE PRECISION AR, AI, BR, BI, CR, CI
      DOUBLE PRECISION D, T, U, V
      DOUBLE PRECISION DPMPAR
C
      IF (DABS(BR) .LE. DABS(BI)) GO TO 10
      T = BI/BR
      D = BR + T*BI
      U = (AR + AI*T)/D
      V = (AI - AR*T)/D
      CR = U
      CI = V
      RETURN
C
   10 IF (BI .EQ. 0.D0) GO TO 20
      T = BR/BI
      D = BI + T*BR
      U = (AR*T + AI)/D
      V = (AI*T - AR)/D
      CR = U
      CI = V
      RETURN
C
C     DIVISION BY ZERO. C = INFINITY
C
   20 CR = DPMPAR(3)
      CI = CR
      RETURN
      END
      SUBROUTINE DCSQRT (Z, W)
      DOUBLE PRECISION Z(2), W(2)
C ----------------------------------------------------------------------
C        W = SQRT(Z) FOR THE DOUBLE PRECISION COMPLEX NUMBER Z
C
C                         -----------
C
C     Z AND W ARE INTERPRETED AS DOUBLE PRECISION COMPLEX NUMBERS.
C     IT IS ASSUMED THAT Z(1) AND Z(2) ARE THE REAL AND IMAGINARY
C     PARTS OF THE COMPLEX NUMBER Z, AND THAT W(1) AND W(2) ARE
C     THE REAL AND IMAGINARY PARTS OF W.
C ----------------------------------------------------------------------
      DOUBLE PRECISION X, Y, R
      DOUBLE PRECISION DCPABS
C
      X = Z(1)
      Y = Z(2)
      IF (X) 30,10,20
C
   10 IF (Y .NE. 0.D0) GO TO 11
         W(1) = 0.D0
         W(2) = 0.D0
         RETURN
   11 W(1) = DSQRT(0.5D0*DABS(Y))
      W(2) = DSIGN(W(1),Y)
      RETURN
C
   20 IF (Y .NE. 0.D0) GO TO 21
         W(1) = DSQRT(X)
         W(2) = 0.D0
         RETURN
   21 R = DCPABS(X,Y)
      W(1) = DSQRT(0.5D0*(R + X))
      W(2) = 0.5D0*Y/W(1)
      RETURN
C
   30 IF (Y .NE. 0.D0) GO TO 31
         W(1) = 0.D0
         W(2) = DSQRT(DABS(X))
         RETURN
   31 R = DCPABS(X,Y)
      W(2) = DSQRT(0.5D0*(R - X))
      W(2) = DSIGN(W(2),Y)
      W(1) = 0.5D0*Y/W(2)
      RETURN
      END
      SUBROUTINE POCA(R,A,X,Y)
      X=R*COS(A)
      Y=R*SIN(A)
      RETURN
      END
      SUBROUTINE CAPO(X,Y,R,THETA)
      IF (ABS(X).LE.ABS(Y)) GO TO 10
      A=Y/X
      R=ABS(X)*SQRT(1.0+A*A)
      THETA=ATAN2(Y,X)
      RETURN
   10 IF (Y.EQ.0.) GO TO 20
      A=X/Y
      R=ABS(Y)*SQRT(1.0+A*A)
      THETA=ATAN2(Y,X)
      RETURN
   20 R=0.0
      THETA=0.0
      RETURN
      END
      SUBROUTINE ROTA(X1,Y1,A,X2,Y2)
      SINA=SIN(A)
      COSA=COS(A)
      X2= X1*COSA+Y1*SINA
      Y2=-X1*SINA+Y1*COSA
      RETURN
      END
      SUBROUTINE SROTG(SA,SB,SC,SS)
C
C     DESIGNED BY C.L.LAWSON, JPL, 1977 SEPT 08
C
C
C     CONSTRUCT THE GIVENS TRANSFORMATION
C
C         ( SC  SS )
C     G = (        ) ,    SC**2 + SS**2 = 1 ,
C         (-SS  SC )
C
C     WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR  (SA,SB)**T .
C
C     THE QUANTITY R = (+/-)SQRT(SA**2 + SB**2) OVERWRITES SA IN
C     STORAGE.  THE VALUE OF SB IS OVERWRITTEN BY A VALUE Z WHICH
C     ALLOWS SC AND SS TO BE RECOVERED BY THE FOLLOWING ALGORITHM:
C           IF Z=1  SET  SC=0.  AND  SS=1.
C           IF ABS(Z) .LT. 1  SET  SC=SQRT(1-Z**2)  AND  SS=Z
C           IF ABS(Z) .GT. 1  SET  SC=1/Z  AND  SS=SQRT(1-SC**2)
C
C     NORMALLY, THE SUBPROGRAM SROT(N,SX,INCX,SY,INCY,SC,SS) WILL
C     NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX.
C
C ------------------------------------------------------------------
C
      IF (ABS(SA) .LE. ABS(SB)) GO TO 10
C
C *** HERE ABS(SA) .GT. ABS(SB) ***
C
      U = SA + SA
      V = SB / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF SA
C
      R = SQRT(.25 + V**2) * U
C
C     NOTE THAT SC IS POSITIVE
C
      SC = SA / R
      SS = V * (SC + SC)
      SB = SS
      SA = R
      RETURN
C
C *** HERE ABS(SA) .LE. ABS(SB) ***
C
   10 IF (SB .EQ. 0.) GO TO 20
      U = SB + SB
      V = SA / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF SB
C     (R IS IMMEDIATELY STORED IN SA)
C
      SA = SQRT(.25 + V**2) * U
C
C     NOTE THAT SS IS POSITIVE
C
      SS = SB / SA
      SC = V * (SS + SS)
      IF (SC .EQ. 0.) GO TO 15
      SB = 1. / SC
      RETURN
   15 SB = 1.
      RETURN
C
C *** HERE SA = SB = 0. ***
C
   20 SC = 1.
      SS = 0.
      RETURN
C
      END
      SUBROUTINE DROTG(DA,DB,DC,DS)
C
C     DESIGNED BY C.L.LAWSON, JPL, 1977 SEPT 08
C
C
C     CONSTRUCT THE GIVENS TRANSFORMATION
C
C         ( DC  DS )
C     G = (        ) ,    DC**2 + DS**2 = 1 ,
C         (-DS  DC )
C
C     WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR  (DA,DB)**T .
C
C     THE QUANTITY R = (+/-)DSQRT(DA**2 + DB**2) OVERWRITES DA IN
C     STORAGE.  THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH
C     ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM:
C           IF Z=1  SET  DC=0.D0  AND  DS=1.D0
C           IF DABS(Z) .LT. 1  SET  DC=DSQRT(1-Z**2)  AND  DS=Z
C           IF DABS(Z) .GT. 1  SET  DC=1/Z  AND  DS=DSQRT(1-DC**2)
C
C     NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL
C     NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX.
C
C ------------------------------------------------------------------
C
      DOUBLE PRECISION  DA, DB, DC, DS, U, V, R
      IF (DABS(DA) .LE. DABS(DB)) GO TO 10
C
C *** HERE DABS(DA) .GT. DABS(DB) ***
C
      U = DA + DA
      V = DB / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF DA
C
      R = DSQRT(.25D0 + V**2) * U
C
C     NOTE THAT DC IS POSITIVE
C
      DC = DA / R
      DS = V * (DC + DC)
      DB = DS
      DA = R
      RETURN
C
C *** HERE DABS(DA) .LE. DABS(DB) ***
C
   10 IF (DB .EQ. 0.D0) GO TO 20
      U = DB + DB
      V = DA / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF DB
C     (R IS IMMEDIATELY STORED IN DA)
C
      DA = DSQRT(.25D0 + V**2) * U
C
C     NOTE THAT DS IS POSITIVE
C
      DS = DB / DA
      DC = V * (DS + DS)
      IF (DC .EQ. 0.D0) GO TO 15
      DB = 1.D0 / DC
      RETURN
   15 DB = 1.D0
      RETURN
C
C *** HERE DA = DB = 0.D0 ***
C
   20 DC = 1.D0
      DS = 0.D0
      RETURN
C
      END
      SUBROUTINE ROT3 (A, THETA)
      DIMENSION A(3,3), THETA(3)
      DATA PIHALF/1.5707963267949/
C     --------------------
      IF (ABS(A(1,1)) .GT. ABS(A(2,1))) GO TO 10
      IF (A(2,1) .NE. 0.0) GO TO 11
C
C     CASE WHEN A(1,1) = A(2,1) = 0
C
      THETA(3) = 0.0
      THETA(2) = SIGN(PIHALF,A(3,1))
      U = A(2,2)
      V = A(1,2)
      IF (A(3,1) .GT. 0.0) V = -V
      THETA(1) = ATAN2(V,U)
      RETURN
C
C     COMPUTATION OF R = SQRT(A(1,1)**2 + A(2,1)**2)
C
   10 T = A(2,1)/A(1,1)
      R = ABS(A(1,1))*SQRT(1.0 + T*T)
      GO TO 20
   11 T = A(1,1)/A(2,1)
      R = ABS(A(2,1))*SQRT(1.0 + T*T)
C
C     EVALUATION OF THE ANGLES
C
   20 THETA(3) = ATAN2(A(2,1),A(1,1))
      THETA(2) = ATAN2(A(3,1),R)
      U = DBLE(A(1,1))*DBLE(A(2,2)) - DBLE(A(1,2))*DBLE(A(2,1))
      IF (ABS(THETA(2)) .GT. 0.8) GO TO 21
      U = U/R
      V = A(3,2)/COS(THETA(2))
      GO TO 22
   21 V = DBLE(A(1,1))*DBLE(A(1,2)) + DBLE(A(2,1))*DBLE(A(2,2))
      V = -V/SIN(THETA(2))
   22 THETA(1) = ATAN2(V,U)
      RETURN
      END
      SUBROUTINE CONSTR (XK,YK,ZK, CX,SX,CY,SY)
      REAL XK, YK, ZK, CX, SX, CY, SY
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C
C   THIS SUBROUTINE CONSTRUCTS THE ELEMENTS OF A 3 BY 3
C ORTHOGONAL MATRIX R WHICH ROTATES A POINT (XK,YK,ZK) ON
C THE UNIT SPHERE TO THE NORTH POLE, I.E.
C
C      (XK)     (CY  0 -SY)   (1   0   0)   (XK)     (0)
C  R * (YK)  =  ( 0  1   0) * (0  CX -SX) * (YK)  =  (0)
C      (ZK)     (SY  0  CY)   (0  SX  CX)   (ZK)     (1)
C
C INPUT PARAMETERS - XK,YK,ZK - COMPONENTS OF A UNIT VECTOR
C                               TO BE ROTATED TO (0,0,1).
C
C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETERS - CX,SX,CY,SY - ELEMENTS OF R -- CX,SX
C                                   DEFINE A ROTATION ABOUT
C                                   THE X-AXIS AND CY,SY DE-
C                                   FINE A ROTATION ABOUT
C                                   THE Y-AXIS.
C
C INTRINSIC FUNCTION CALLED BY CONSTR - SQRT
C
C***********************************************************
C
      CY = SQRT(YK*YK + ZK*ZK)
      SY = XK
      IF (CY .EQ. 0.) GO TO 1
      CX = ZK/CY
      SX = YK/CY
      RETURN
C
C (XK,YK,ZK) LIES ON THE X-AXIS
C
    1 CX = 1.
      SX = 0.
      RETURN
      END
      REAL FUNCTION ANG (N, X, Y)
C-----------------------------------------------------------------------
C           COMPUTATION OF THE ANGLE BETWEEN TWO VECTORS
C-----------------------------------------------------------------------
      REAL X(N), Y(N)
C
      IF (N .LT. 2) GO TO 30
      RX = SNRM2(N, X, 1)
      IF (RX .EQ. 0.0) GO TO 30
      RY = SNRM2(N, Y, 1)
      IF (RY .EQ. 0.0) GO TO 30
C
      D = 0.0
      DO 10 I = 1,N
         D = D + (X(I)/RX - Y(I)/RY)**2
   10 CONTINUE
      IF (D .GT. 3.0) GO TO 20
      ANG = ACOS(0.5 + (0.5 - 0.5*D))
      RETURN
C
   20 D = 0.0
      DO 21 I = 1,N
         D = D + (X(I)/RX + Y(I)/RY)**2
   21 CONTINUE
      ANG = ACOS((0.5*D - 0.5) - 0.5)
      RETURN
C
C                           ERROR RETURN
C
   30 ANG = -1.0
      RETURN
      END
      REAL FUNCTION SIN0 (X)
C-----------------------------------------------------------------------
C          COMPUTATION OF SIN(X*PI/2) FOR ABS(X) .LE. 0.5
C-----------------------------------------------------------------------
      DATA A0 /.157079632679490E+01/, A1 /-.645964097506244E+00/,
     *     A2 /.796926262460396E-01/, A3 /-.468175413228242E-02/,
     *     A4 /.160441150291651E-03/, A5 /-.359864175444606E-05/,
     *     A6 /.563372101191893E-07/
C------------------------
      T = X*X
      SIN0 = ((((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T
     *                  + A1)*T + A0)*X
      RETURN
      END
      REAL FUNCTION COS0 (X)
C-----------------------------------------------------------------------
C          COMPUTATION OF COS(X*PI/2) FOR ABS(X) .LE. 0.5
C-----------------------------------------------------------------------
      DATA A1 /-.123370055013615E+01/, A2 /.253669507899753E+00/,
     *     A3 /-.208634807330586E-01/, A4 /.919259935580283E-03/,
     *     A5 /-.252000841382533E-04/, A6 /.465461768260405E-06/
C------------------------
      T = X*X
      COS0 = (((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T + A1)*T + 1.0
      RETURN
      END
      REAL FUNCTION SIN1 (X)
C-----------------------------------------------------------------------
C                   EVALUATION  OF SIN(X*PI)
C-----------------------------------------------------------------------
      DATA A0 /.314159265358979E+01/, A1 /-.516771278004995E+01/,
     *     A2 /.255016403987327E+01/, A3 /-.599264528932149E+00/,
     *     A4 /.821458689493251E-01/, A5 /-.737001831310553E-02/,
     *     A6 /.461514425296398E-03/
      DATA B1 /-.493480220054460E+01/, B2 /.405871212639605E+01/,
     *     B3 /-.133526276691575E+01/, B4 /.235330543508553E+00/,
     *     B5 /-.258048861575714E-01/, B6 /.190653140279462E-02/
C------------------------
C
C     ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE
C            LARGEST POSITIVE INTEGER THAT MAY BE USED.
C
                       MAX = IPMPAR(3)
C
C------------------------
      A = ABS(X)
      IF (A .LT. FLOAT(MAX)) GO TO 10
         SIN1 = 0.0
         RETURN
C
   10 N = A
      A = A - FLOAT(N)
      IF (A .GT. 0.75) GO TO 20
      IF (A .LT. 0.25) GO TO 21
C
C                    0.25 .LE. A .LE. 0.75
C
      A = 0.25 + (0.25 - A)
      T = A*A
      SIN1 = ((((((B6*T + B5)*T + B4)*T + B3)*T + B2)*T
     *                  + B1)*T + 0.5) + 0.5
      GO TO 30
C
C                 A .LT. 0.25  OR  A .GT. 0.75
C
   20 A = 0.25 + (0.75 - A)
   21 T = A*A
      SIN1 = ((((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T
     *                  + A1)*T + A0)*A
C
C                        TERMINATION
C
   30 IF (X .LT. 0.0) SIN1 = - SIN1
      IF (MOD(N,2) .NE. 0) SIN1 = - SIN1
      RETURN
      END
      REAL FUNCTION COS1 (X)
C-----------------------------------------------------------------------
C                   EVALUATION  OF COS(X*PI)
C-----------------------------------------------------------------------
      DATA A0 /.314159265358979E+01/, A1 /-.516771278004995E+01/,
     *     A2 /.255016403987327E+01/, A3 /-.599264528932149E+00/,
     *     A4 /.821458689493251E-01/, A5 /-.737001831310553E-02/,
     *     A6 /.461514425296398E-03/
      DATA B1 /-.493480220054460E+01/, B2 /.405871212639605E+01/,
     *     B3 /-.133526276691575E+01/, B4 /.235330543508553E+00/,
     *     B5 /-.258048861575714E-01/, B6 /.190653140279462E-02/
C------------------------
C
C     ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE
C            LARGEST POSITIVE INTEGER THAT MAY BE USED.
C
                       MAX = IPMPAR(3)
C
C------------------------
      A = ABS(X)
      IF (A .LT. FLOAT(MAX)) GO TO 10
         COS1 = 1.0
         RETURN
C
   10 N = A
      A = A - FLOAT(N)
      IF (A .GT. 0.75) GO TO 20
      IF (A .LT. 0.25) GO TO 21
C
C                    0.25 .LE. A .LE. 0.75
C
      A = 0.25 + (0.25 - A)
      T = A*A
      COS1 = ((((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T
     *                  + A1)*T + A0)*A
      GO TO 30
C
C                 A .LT. 0.25  OR  A .GT. 0.75
C
   20 A = 0.25 + (0.75 - A)
      N = N - 1
   21 T = A*A
      COS1 = ((((((B6*T + B5)*T + B4)*T + B3)*T + B2)*T
     *                  + B1)*T + 0.5) + 0.5
C
C                        TERMINATION
C
   30 IF (MOD(N,2) .NE. 0) COS1 = - COS1
      RETURN
      END
      DOUBLE PRECISION FUNCTION DSIN1 (X)
C-----------------------------------------------------------------------
C
C                DOUBLE PRECISION EVALUATION OF SIN(PI*X)
C
C                             --------------
C
C     THE EXPANSION FOR SIN(PI*A) (ABS(A) .LE. PI/4) USING A1,...,A13
C     IS ACCURATE TO WITHIN 2 UNITS OF THE 40-TH SIGNIFICANT DIGIT, AND
C     THE EXPANSION FOR COS(PI*A) (ABS(A) .LE. PI/4) USING B1,...,B13
C     IS ACCURATE TO WITHIN 4 UNITS OF THE 40-TH SIGNIFICANT DIGIT.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X
      DOUBLE PRECISION A, PI, T, W
      DOUBLE PRECISION A1, A2, A3, A4, A5, A6, A7, A8, A9, A10,
     *                 A11, A12, A13
      DOUBLE PRECISION B1, B2, B3, B4, B5, B6, B7, B8, B9, B10,
     *                 B11, B12, B13
C------------------------
      DATA PI /3.141592653589793238462643383279502884197D+00/
C------------------------
      DATA A1  /-.1028083791780141522795259479153765743002D+00/,
     *     A2  / .3170868848763100170457042079710451905600D-02/,
     *     A3  /-.4657026956105571623449026167864697920000D-04/,
     *     A4  / .3989844942879455643410226655783424000000D-06/,
     *     A5  /-.2237397227721999776371894030796800000000D-08/,
     *     A6  / .8847045483056962709715066675200000000000D-11/,
     *     A7  /-.2598715447506450292885585920000000000000D-13/,
     *     A8  / .5893449774331011070033920000000000000000D-16/,
     *     A9  /-.1062975472045522550784000000000000000000D-18/,
     *     A10 / .1561182648301780992000000000000000000000D-21/,
     *     A11 /-.1903193516670976000000000000000000000000D-24/,
     *     A12 / .1956617650176000000000000000000000000000D-27/,
     *     A13 /-.1711276032000000000000000000000000000000D-30/
C------------------------
      DATA B1  /-.3084251375340424568385778437461297229882D+00/,
     *     B2  / .1585434424381550085228521039855226435920D-01/,
     *     B3  /-.3259918869273900136414318317506279360000D-03/,
     *     B4  / .3590860448591510079069203991239232000000D-05/,
     *     B5  /-.2461136950494199754009084061808640000000D-07/,
     *     B6  / .1150115912797405152263195572224000000000D-09/,
     *     B7  /-.3898073171259675439899172864000000000000D-12/,
     *     B8  / .1001886461636271969091584000000000000000D-14/,
     *     B9  /-.2019653396886572027084800000000000000000D-17/,
     *     B10 / .3278483561466560512000000000000000000000D-20/,
     *     B11 /-.4377345082051788800000000000000000000000D-23/,
     *     B12 / .4891532381388800000000000000000000000000D-26/,
     *     B13 /-.4617089843200000000000000000000000000000D-29/
C------------------------
C
C     ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE
C            LARGEST POSITIVE INTEGER THAT MAY BE USED.
C
                       MAX = IPMPAR(3)
C
C------------------------
      A = DABS(X)
      T = MAX
      IF (A .LT. T) GO TO 10
         DSIN1 = 0.D0
         RETURN
C
   10 N = A
      T = N
      A = A - T
      IF (A .GT. 0.75D0) GO TO 20
      IF (A .LT. 0.25D0) GO TO 21
C
C                    0.25 .LE. A .LE. 0.75
C
      A = 0.25D0 + (0.25D0 - A)
      T = 16.D0*A*A
      DSIN1 = (((((((((((((B13*T + B12)*T + B11)*T + B10)*T + B9)*T +
     *                B8)*T + B7)*T + B6)*T + B5)*T + B4)*T + B3)*T +
     *                B2)*T + B1)*T + 0.5D0) + 0.5D0
      GO TO 30
C
C                 A .LT. 0.25  OR  A .GT. 0.75
C
   20 A = 0.25D0 + (0.75D0 - A)
   21 T = 16.D0*A*A
      W = (((((((((((((A13*T + A12)*T + A11)*T + A10)*T + A9)*T +
     *            A8)*T + A7)*T + A6)*T + A5)*T + A4)*T + A3)*T +
     *            A2)*T + A1)*T + 0.5D0) + 0.5D0
      DSIN1 = PI*A*W
C
C                        TERMINATION
C
   30 IF (X .LT. 0.0) DSIN1 = - DSIN1
      IF (MOD(N,2) .NE. 0) DSIN1 = - DSIN1
      RETURN
      END
      DOUBLE PRECISION FUNCTION DCOS1 (X)
C-----------------------------------------------------------------------
C
C                DOUBLE PRECISION EVALUATION OF COS(PI*X)
C
C                             --------------
C
C     THE EXPANSION FOR SIN(PI*A) (ABS(A) .LE. PI/4) USING A1,...,A13
C     IS ACCURATE TO WITHIN 2 UNITS OF THE 40-TH SIGNIFICANT DIGIT, AND
C     THE EXPANSION FOR COS(PI*A) (ABS(A) .LE. PI/4) USING B1,...,B13
C     IS ACCURATE TO WITHIN 4 UNITS OF THE 40-TH SIGNIFICANT DIGIT.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X
      DOUBLE PRECISION A, PI, T, W
      DOUBLE PRECISION A1, A2, A3, A4, A5, A6, A7, A8, A9, A10,
     *                 A11, A12, A13
      DOUBLE PRECISION B1, B2, B3, B4, B5, B6, B7, B8, B9, B10,
     *                 B11, B12, B13
C------------------------
      DATA PI /3.141592653589793238462643383279502884197D+00/
C------------------------
      DATA A1  /-.1028083791780141522795259479153765743002D+00/,
     *     A2  / .3170868848763100170457042079710451905600D-02/,
     *     A3  /-.4657026956105571623449026167864697920000D-04/,
     *     A4  / .3989844942879455643410226655783424000000D-06/,
     *     A5  /-.2237397227721999776371894030796800000000D-08/,
     *     A6  / .8847045483056962709715066675200000000000D-11/,
     *     A7  /-.2598715447506450292885585920000000000000D-13/,
     *     A8  / .5893449774331011070033920000000000000000D-16/,
     *     A9  /-.1062975472045522550784000000000000000000D-18/,
     *     A10 / .1561182648301780992000000000000000000000D-21/,
     *     A11 /-.1903193516670976000000000000000000000000D-24/,
     *     A12 / .1956617650176000000000000000000000000000D-27/,
     *     A13 /-.1711276032000000000000000000000000000000D-30/
C------------------------
      DATA B1  /-.3084251375340424568385778437461297229882D+00/,
     *     B2  / .1585434424381550085228521039855226435920D-01/,
     *     B3  /-.3259918869273900136414318317506279360000D-03/,
     *     B4  / .3590860448591510079069203991239232000000D-05/,
     *     B5  /-.2461136950494199754009084061808640000000D-07/,
     *     B6  / .1150115912797405152263195572224000000000D-09/,
     *     B7  /-.3898073171259675439899172864000000000000D-12/,
     *     B8  / .1001886461636271969091584000000000000000D-14/,
     *     B9  /-.2019653396886572027084800000000000000000D-17/,
     *     B10 / .3278483561466560512000000000000000000000D-20/,
     *     B11 /-.4377345082051788800000000000000000000000D-23/,
     *     B12 / .4891532381388800000000000000000000000000D-26/,
     *     B13 /-.4617089843200000000000000000000000000000D-29/
C------------------------
C
C     ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE
C            LARGEST POSITIVE INTEGER THAT MAY BE USED.
C
                       MAX = IPMPAR(3)
C
C------------------------
      A = DABS(X)
      T = MAX
      IF (A .LT. T) GO TO 10
         DCOS1 = 1.D0
         RETURN
C
   10 N = A
      T = N
      A = A - T
      IF (A .GT. 0.75D0) GO TO 20
      IF (A .LT. 0.25D0) GO TO 21
C
C                    0.25 .LE. A .LE. 0.75
C
      A = 0.25D0 + (0.25D0 - A)
      T = 16.D0*A*A
      W = (((((((((((((A13*T + A12)*T + A11)*T + A10)*T + A9)*T +
     *            A8)*T + A7)*T + A6)*T + A5)*T + A4)*T + A3)*T +
     *            A2)*T + A1)*T + 0.5D0) + 0.5D0
      DCOS1 = PI*A*W
      GO TO 30
C
C                 A .LT. 0.25  OR  A .GT. 0.75
C
   20 A = 0.25D0 + (0.75D0 - A)
      N = N - 1
   21 T = 16.D0*A*A
      DCOS1 = (((((((((((((B13*T + B12)*T + B11)*T + B10)*T + B9)*T +
     *                B8)*T + B7)*T + B6)*T + B5)*T + B4)*T + B3)*T +
     *                B2)*T + B1)*T + 0.5D0) + 0.5D0
C
C                        TERMINATION
C
   30 IF (MOD(N,2) .NE. 0) DCOS1 = - DCOS1
      RETURN
      END
      SUBROUTINE SNHCSH (SINHM,COSHM,X,ISW)
C
      INTEGER ISW
      REAL SINHM,COSHM,X,CUT(5)
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C                          MODIFIED BY A.H. MORRIS (NSWC/DL)
C
C THIS SUBROUTINE RETURNS APPROXIMATIONS TO
C       SINHM(X) = SINH(X)-X
C       COSHM(X) = COSH(X)-1
C AND
C       COSHMM(X) = COSH(X)-1-X*X/2
C
C ON INPUT--
C
C   X CONTAINS THE VALUE OF THE INDEPENDENT VARIABLE.
C
C   ISW INDICATES THE FUNCTION DESIRED
C           = -1 IF ONLY SINHM IS DESIRED,
C           =  0 IF BOTH SINHM AND COSHM ARE DESIRED,
C           =  1 IF ONLY COSHM IS DESIRED,
C           =  2 IF ONLY COSHMM IS DESIRED,
C           =  3 IF BOTH SINHM AND COSHMM ARE DESIRED.
C
C ON OUTPUT--
C
C   SINHM CONTAINS THE VALUE OF SINHM(X) IF ISW .LE. 0 OR
C   ISW .EQ. 3 (SINHM IS UNALTERED IF ISW .EQ.1 OR ISW .EQ.
C   2).
C
C   COSHM CONTAINS THE VALUE OF COSHM(X) IF ISW .EQ. 0 OR
C   ISW .EQ. 1 AND CONTAINS THE VALUE OF COSHMM(X) IF ISW
C   .GE. 2 (COSHM IS UNALTERED IF ISW .EQ. -1).
C
C AND
C
C   X AND ISW ARE UNALTERED.
C
C-----------------------------------------------------------
C
      DATA SP5/.255251817302048E-09/,
     *     SP4/.723809046696880E-07/,
     *     SP3/.109233297700241E-04/,
     *     SP2/.954811583154274E-03/,
     *     SP1/.452867078563929E-01/,
     *     SQ1/-.471329214363072E-02/
      DATA CP5/.116744361560051E-08/,
     *     CP4/.280407224259429E-06/,
     *     CP3/.344417983443219E-04/,
     *     CP2/.232293648552398E-02/,
     *     CP1/.778752378267155E-01/,
     *     CQ1/-.545809550662099E-02/
      DATA ZP3/5.59297116264720E-07/,
     *     ZP2/1.77943488030894E-04/,
     *     ZP1/1.69800461894792E-02/,
     *     ZQ4/1.33412535492375E-09/,
     *     ZQ3/-5.80858944138663E-07/,
     *     ZQ2/1.27814964403863E-04/,
     *     ZQ1/-1.63532871439181E-02/
      DATA CUT(1)/1.65/, CUT(2)/1.2/, CUT(3)/1.2/, CUT(4)/2.7/,
     *     CUT(5)/1.65/
C
      XX = X
      AX = ABS(XX)
      XS = XX*XX
      IF (AX .GE. CUT(ISW+2)) EXPX = EXP(AX)
C
C SINHM APPROXIMATION
C
      IF (ISW .EQ. 1 .OR. ISW .EQ. 2) GO TO 2
      IF (AX .GE. 1.65) GO TO 1
      SINHM = ((((((SP5*XS+SP4)*XS+SP3)*XS+SP2)*XS+SP1)*XS+1.)
     *        *XS*XX)/((SQ1*XS+1.)*6.)
      GO TO 2
    1 SINHM = -(((AX+AX)+1./EXPX)-EXPX)/2.
      IF (XX .LT. 0.) SINHM = -SINHM
C
C COSHM APPROXIMATION
C
    2 IF (ISW .NE. 0 .AND. ISW .NE. 1) GO TO 4
      IF (AX .GE. 1.2) GO TO 3
      COSHM = ((((((CP5*XS+CP4)*XS+CP3)*XS+CP2)*XS+CP1)*XS+1.)
     *        *XS)/((CQ1*XS+1.)*2.)
      GO TO 4
    3 COSHM = ((1./EXPX-2.)+EXPX)/2.
C
C COSHMM APPROXIMATION
C
    4 IF (ISW .LE. 1) RETURN
      IF (AX .GE. 2.70) GO TO 5
      COSHM = ((((ZP3*XS+ZP2)*XS+ZP1)*XS+1.)*XS*XS)/(((((ZQ4
     *        *XS+ZQ3)*XS+ZQ2)*XS+ZQ1)*XS+1.)*24.)
      RETURN
    5 COSHM = (((1./EXPX-2.)-XS)+EXPX)/2.
      RETURN
      END
      REAL FUNCTION ESUM (MU, X)
C-----------------------------------------------------------------------
C                    EVALUATION OF EXP(MU + X)
C-----------------------------------------------------------------------
      IF (X .GT. 0.0) GO TO 10
C
      IF (MU .LT. 0) GO TO 20
         W = MU + X
         IF (W .GT. 0.0) GO TO 20
         ESUM = EXP(W)
         RETURN
C
   10 IF (MU .GT. 0) GO TO 20
         W = MU + X
         IF (W .LT. 0.0) GO TO 20
         ESUM = EXP(W)
         RETURN
C
   20 W = MU
      ESUM = EXP(W)*EXP(X)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DESUM (MU, X)
C-----------------------------------------------------------------------
C                    EVALUATION OF EXP(MU + X)
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, W
C
      IF (X .GT. 0.D0) GO TO 10
C
      IF (MU .LT. 0) GO TO 20
         W = MU + X
         IF (W .GT. 0.D0) GO TO 20
         DESUM = DEXP(W)
         RETURN
C
   10 IF (MU .GT. 0) GO TO 20
         W = MU + X
         IF (W .LT. 0.D0) GO TO 20
         DESUM = DEXP(W)
         RETURN
C
   20 W = MU
      DESUM = DEXP(W)*DEXP(X)
      RETURN
      END
      REAL FUNCTION REXP (X)
C-----------------------------------------------------------------------
C            EVALUATION OF THE FUNCTION EXP(X) - 1
C-----------------------------------------------------------------------
      DATA P1/ .914041914819518E-09/, P2/ .238082361044469E-01/,
     *     Q1/-.499999999085958E+00/, Q2/ .107141568980644E+00/,
     *     Q3/-.119041179760821E-01/, Q4/ .595130811860248E-03/
C-----------------------
      IF (ABS(X) .GT. 0.15) GO TO 10
      REXP = X*(((P2*X + P1)*X + 1.0)/((((Q4*X + Q3)*X + Q2)*X
     *                 + Q1)*X + 1.0))
      RETURN
C
   10 IF (X .LT. 0.0) GO TO 20
         E = EXP(X)
         REXP = E*(0.5 + (0.5 - 1.0/E))
         RETURN
   20 IF (X .LT. -37.0) GO TO 30
         REXP = (EXP(X) - 0.5) - 0.5
         RETURN
   30 REXP = -1.0
      RETURN
      END
      DOUBLE PRECISION FUNCTION DREXP (X)
C-----------------------------------------------------------------------
C            EVALUATION OF THE FUNCTION EXP(X) - 1
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, E, W, Z
      DOUBLE PRECISION A0, A1, A2, A3, A4, B1, B2, B3, B4
      DOUBLE PRECISION C1, C2, C3, C4, C5
C---------------------------
      DATA A0/ .248015873015873015873016D-04/,
     *     A1/-.344452080605731005808147D-05/,
     *     A2/ .206664230430046597475413D-06/,
     *     A3/-.447300111094328162971036D-08/,
     *     A4/ .114734027080634968083920D-11/
      DATA B1/-.249994190011341852652396D+00/,
     *     B2/ .249987228833107957725728D-01/,
     *     B3/-.119037506846942249362528D-02/,
     *     B4/ .228908693387350391768682D-04/
C---------------------------
C     CI = 1/FACTORIAL(I + 2)
C---------------------------
      DATA C1 / .1666666666666666666666666666666667D+00/,
     *     C2 / .4166666666666666666666666666666667D-01/,
     *     C3 / .8333333333333333333333333333333333D-02/,
     *     C4 / .1388888888888888888888888888888889D-02/,
     *     C5 / .1984126984126984126984126984126984D-03/
C---------------------------
      IF (DABS(X) .GT. 0.15D0) GO TO 10
C
C        Z IS A MINIMAX APPROXIMATION OF THE SERIES
C
C                C6 + C7*X + C8*X**2 + ....
C
C        THIS APPROXIMATION IS ACCURATE TO WITHIN
C        1 UNIT OF THE 23-RD SIGNIFICANT DIGIT.
C        THE RESULTING VALUE FOR W IS ACCURATE TO
C        WITHIN 1 UNIT OF THE 33-RD SIGNIFICANT
C        DIGIT.
C
      Z = ((((A4*X + A3)*X + A2)*X + A1)*X + A0) /
     *    ((((B4*X + B3)*X + B2)*X + B1)*X + 1.D0)
      W = ((((((Z*X + C5)*X + C4)*X + C3)*X + C2)*X +
     *          C1)*X + 0.5D0)*X + 1.D0
      DREXP = X*W
      RETURN
C
   10 IF (X .LT. 0.D0) GO TO 20
         E = DEXP(X)
         DREXP = E*(0.5D0 + (0.5D0 - 1.D0/E))
         RETURN
   20 IF (X .LT. -77.D0) GO TO 30
         DREXP = (DEXP(X) - 0.5D0) - 0.5D0
         RETURN
   30 DREXP = -1.D0
      RETURN
      END
      SUBROUTINE REXP1 (X, E, W)
C-----------------------------------------------------------------------
C
C                  EVALUATION OF W = (EXP(X) - 1)/X
C
C     E IS AN INPUT/OUTPUT VARIABLE. IF E .GE. 0 THEN IT IS ASSUMED
C     THAT E = EXP(X). IN THIS CASE E IS NOT MODIFIED. IF E .LT. 0
C     THEN E IS SET TO EXP(X) WHEN THIS VALUE IS NEEDED.
C
C-----------------------------------------------------------------------
      DATA P1/ .914041914819518E-09/, P2/ .238082361044469E-01/,
     *     Q1/-.499999999085958E+00/, Q2/ .107141568980644E+00/,
     *     Q3/-.119041179760821E-01/, Q4/ .595130811860248E-03/
C-----------------------
      IF (ABS(X) .GT. 0.15) GO TO 10
      W = ((P2*X + P1)*X + 1.0)/((((Q4*X + Q3)*X + Q2)*X
     *           + Q1)*X + 1.0)
      RETURN
C
   10 IF (X .LT. 0.0) GO TO 20
         IF (E .LT. 0.0) E = EXP(X)
         W = (E*(0.5 + (0.5 - 1.0/E)))/X
         RETURN
   20 IF (X .LT. -37.0) GO TO 30
         IF (E .LT. 0.0) E = EXP(X)
         W = ((E - 0.5) - 0.5)/X
         RETURN
   30 W = -1.0/X
      RETURN
      END
      SUBROUTINE DREXP1 (X, E, W)
C-----------------------------------------------------------------------
C
C                  EVALUATION OF W = (EXP(X) - 1)/X
C
C     E IS AN INPUT/OUTPUT VARIABLE. IF E .GE. 0 THEN IT IS ASSUMED
C     THAT E = EXP(X). IN THIS CASE E IS NOT MODIFIED. IF E .LT. 0
C     THEN E IS SET TO EXP(X) WHEN THIS VALUE IS NEEDED.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, E, W, Z
      DOUBLE PRECISION A0, A1, A2, A3, A4, B1, B2, B3, B4
      DOUBLE PRECISION C1, C2, C3, C4, C5
C---------------------------
      DATA A0/ .248015873015873015873016D-04/,
     *     A1/-.344452080605731005808147D-05/,
     *     A2/ .206664230430046597475413D-06/,
     *     A3/-.447300111094328162971036D-08/,
     *     A4/ .114734027080634968083920D-11/
      DATA B1/-.249994190011341852652396D+00/,
     *     B2/ .249987228833107957725728D-01/,
     *     B3/-.119037506846942249362528D-02/,
     *     B4/ .228908693387350391768682D-04/
C---------------------------
C     CI = 1/FACTORIAL(I + 2)
C---------------------------
      DATA C1 / .1666666666666666666666666666666667D+00/,
     *     C2 / .4166666666666666666666666666666667D-01/,
     *     C3 / .8333333333333333333333333333333333D-02/,
     *     C4 / .1388888888888888888888888888888889D-02/,
     *     C5 / .1984126984126984126984126984126984D-03/
C---------------------------
      W = 1.D0
      IF (DABS(X) .LT. 1.D-33) RETURN
      IF (DABS(X) .GT. 0.15D0) GO TO 10
C
C        Z IS A MINIMAX APPROXIMATION OF THE SERIES
C
C                C6 + C7*X + C8*X**2 + ....
C
C        THIS APPROXIMATION IS ACCURATE TO WITHIN
C        1 UNIT OF THE 23-RD SIGNIFICANT DIGIT.
C        THE RESULTING VALUE FOR W IS ACCURATE TO
C        WITHIN 1 UNIT OF THE 33-RD SIGNIFICANT
C        DIGIT.
C
      Z = ((((A4*X + A3)*X + A2)*X + A1)*X + A0) /
     *    ((((B4*X + B3)*X + B2)*X + B1)*X + 1.D0)
      W = ((((((Z*X + C5)*X + C4)*X + C3)*X + C2)*X +
     *          C1)*X + 0.5D0)*X + 1.D0
      RETURN
C
   10 IF (X .LT. 0.D0) GO TO 20
         IF (E .LT. 0.D0) E = DEXP(X)
         W = (E*(0.5D0 + (0.5D0 - 1.D0/E)))/X
         RETURN
   20 IF (X .LT. -77.D0) GO TO 30
         IF (E .LT. 0.D0) E = DEXP(X)
         W = ((E - 0.5D0) - 0.5D0)/X
         RETURN
   30 W = -1.D0/X
      RETURN
      END
      REAL FUNCTION ALNREL(A)
C-----------------------------------------------------------------------
C            EVALUATION OF THE FUNCTION LN(1 + A)
C-----------------------------------------------------------------------
      DATA P1/-.129418923021993E+01/, P2/.405303492862024E+00/,
     *     P3/-.178874546012214E-01/
      DATA Q1/-.162752256355323E+01/, Q2/.747811014037616E+00/,
     *     Q3/-.845104217945565E-01/
C--------------------------
      IF (ABS(A) .GT. 0.375) GO TO 10
      T = A/(A + 2.0)
      T2 = T*T
      W = (((P3*T2 + P2)*T2 + P1)*T2 + 1.0)/
     *    (((Q3*T2 + Q2)*T2 + Q1)*T2 + 1.0)
      ALNREL = 2.0*T*W
      RETURN
C
   10 X = 1.0 + A
      IF (A .LT. 0.0) X = (A + 0.5) + 0.5
      ALNREL = ALOG(X)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DLNREL (A)
C-----------------------------------------------------------------------
C            EVALUATION OF THE FUNCTION LN(1 + A)
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, T, T2, W, Z
      DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4
      DOUBLE PRECISION C1, C2, C3, C4, C5
C-------------------------
      DATA P0 / .7692307692307692307680D-01/,
     *     P1 /-.1505958055914600184836D+00/,
     *     P2 / .9302355725278521726994D-01/,
     *     P3 /-.1787900022182327735804D-01/
      DATA Q1 /-.2824412139355646910683D+01/,
     *     Q2 / .2892424216041495392509D+01/,
     *     Q3 /-.1263560605948009364422D+01/,
     *     Q4 / .1966769435894561313526D+00/
C-------------------------
C     CI = 1/(2I + 1)
C-------------------------
      DATA C1 /.3333333333333333333333333333333D+00/,
     *     C2 /.2000000000000000000000000000000D+00/,
     *     C3 /.1428571428571428571428571428571D+00/,
     *     C4 /.1111111111111111111111111111111D+00/,
     *     C5 /.9090909090909090909090909090909D-01/
C-------------------------
      IF (DABS(A) .LT. 0.375D0) GO TO 10
      T = 1.D0 + A
      IF (A .LT. 0.D0) T = 0.5D0 + (0.5D0 + A)
      DLNREL = DLOG(T)
      RETURN
C
C        W IS A MINIMAX APPROXIMATION OF THE SERIES
C
C               C6 + C7*T**2 + C8*T**4 + ...
C
C        THIS APPROXIMATION IS ACCURATE TO WITHIN
C        1.6 UNITS OF THE 21-ST SIGNIFICANT DIGIT.
C        THE RESULTING VALUE FOR 1.D0 + T2*Z IS
C        ACCURATE TO WITHIN 1 UNIT OF THE 30-TH
C        SIGNIFICANT DIGIT.
C
   10 T = A/(A + 2.D0)
      T2 = T*T
      W = (((P3*T2 + P2)*T2 + P1)*T2 + P0)/
     *    ((((Q4*T2 + Q3)*T2 + Q2)*T2 + Q1)*T2 + 1.D0)
C
      Z = ((((W*T2 + C5)*T2 + C4)*T2 + C3)*T2 + C2)*T2 + C1
      DLNREL = 2.D0*T*(1.D0 + T2*Z)
      RETURN
      END
      REAL FUNCTION RLOG(X)
C-----------------------------------------------------------------------
C             EVALUATION OF THE FUNCTION X - 1 - LN(X)
C-----------------------------------------------------------------------
C     A = RLOG (0.7)
C     B = RLOG (4/3)
C------------------------
      DATA A/.566749439387324E-01/
      DATA B/.456512608815524E-01/
C------------------------
      DATA P0/ .333333333333333E+00/, P1/-.224696413112536E+00/,
     *     P2/ .620886815375787E-02/
      DATA Q1/-.127408923933623E+01/, Q2/ .354508718369557E+00/
C------------------------
      IF (X .LT. 0.61 .OR. X .GT. 1.57) GO TO 100
      IF (X .LT. 0.82) GO TO 10
      IF (X .GT. 1.18) GO TO 20
C
C                 ARGUMENT REDUCTION
C
      U = (X - 0.5) - 0.5
      UP2 = U + 2.0
      W1 = 0.0
      GO TO 30
C
   10 U = (X - 0.7)/0.7
      UP2 = U + 2.0
      W1 = A - U*0.3
      GO TO 30
C
   20 T = 0.75*(X - 1.0)
      U = T - 0.25
      UP2 = T + 1.75
      W1 = B + U/3.0
C
C                  SERIES EXPANSION
C
   30 R = U/UP2
      T = R*R
      W = ((P2*T + P1)*T + P0)/((Q2*T + Q1)*T + 1.0)
      RLOG = R*(U - 2.0*T*W) + W1
      RETURN
C
C
  100 R = (X - 0.5) - 0.5
      RLOG = R - ALOG(X)
      RETURN
      END
      REAL FUNCTION RLOG1(X)
C-----------------------------------------------------------------------
C             EVALUATION OF THE FUNCTION X - LN(1 + X)
C-----------------------------------------------------------------------
C     A = RLOG (0.7)
C     B = RLOG (4/3)
C------------------------
      DATA A/.566749439387324E-01/
      DATA B/.456512608815524E-01/
C------------------------
      DATA P0/ .333333333333333E+00/, P1/-.224696413112536E+00/,
     *     P2/ .620886815375787E-02/
      DATA Q1/-.127408923933623E+01/, Q2/ .354508718369557E+00/
C------------------------
      IF (X .LT. -0.39 .OR. X .GT. 0.57) GO TO 100
      IF (X .LT. -0.18) GO TO 10
      IF (X .GT.  0.18) GO TO 20
C
C                 ARGUMENT REDUCTION
C
      U = X
      UP2 = U + 2.0
      W1 = 0.0
      GO TO 30
C
   10 U = (X + 0.3)/0.7
      UP2 = U + 2.0
      W1 = A - U*0.3
      GO TO 30
C
   20 T = 0.75*X
      U = T - 0.25
      UP2 = T + 1.75
      W1 = B + U/3.0
C
C                  SERIES EXPANSION
C
   30 R = U/UP2
      T = R*R
      W = ((P2*T + P1)*T + P0)/((Q2*T + Q1)*T + 1.0)
      RLOG1 = R*(U - 2.0*T*W) + W1
      RETURN
C
C
  100 W = (X + 0.5) + 0.5
      RLOG1 = X - ALOG(W)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DRLOG (X)
C-----------------------------------------------------------------------
C             EVALUATION OF THE FUNCTION X - 1 - LN(X)
C-----------------------------------------------------------------------
      DOUBLE PRECISION X
      DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z
      DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4
      DOUBLE PRECISION C1, C2, C3, C4, C5
C-------------------------
C     A = DRLOG (0.7)
C     B = DRLOG (4/3)
C-------------------------
      DATA A /.566749439387323789126387112411845D-01/
      DATA B /.456512608815524058941143273395059D-01/
C-------------------------
      DATA P0 / .7692307692307692307680D-01/,
     *     P1 /-.1505958055914600184836D+00/,
     *     P2 / .9302355725278521726994D-01/,
     *     P3 /-.1787900022182327735804D-01/
      DATA Q1 /-.2824412139355646910683D+01/,
     *     Q2 / .2892424216041495392509D+01/,
     *     Q3 /-.1263560605948009364422D+01/,
     *     Q4 / .1966769435894561313526D+00/
C-------------------------
C     CI = 1/(2I + 1)
C-------------------------
      DATA C1 /.333333333333333333333333333333333D+00/,
     *     C2 /.200000000000000000000000000000000D+00/,
     *     C3 /.142857142857142857142857142857143D+00/,
     *     C4 /.111111111111111111111111111111111D+00/,
     *     C5 /.909090909090909090909090909090909D-01/
C-------------------------
      IF (X .LT. 0.61D0 .OR. X .GT. 1.57D0) GO TO 100
      IF (X .LT. 0.82D0) GO TO 10
      IF (X .GT. 1.18D0) GO TO 20
C
C                 ARGUMENT REDUCTION
C
      U = (X - 0.5D0) - 0.5D0
      UP2 = U + 2.D0
      W1 = 0.D0
      GO TO 30
C
   10 U = (X - 0.7D0)/0.7D0
      UP2 = U + 2.D0
      W1 = A - U*0.3D0
      GO TO 30
C
   20 T = 0.75D0*(X - 1.D0)
      U = T - 0.25D0
      UP2 = T + 1.75D0
      W1 = B + U/3.D0
C
C                  SERIES EXPANSION
C
   30 R = U/UP2
      T = R*R
C
C        Z IS A MINIMAX APPROXIMATION OF THE SERIES
C
C               C6 + C7*R**2 + C8*R**4 + ...
C
C        FOR THE INTERVAL (0.0, 0.375). THE APPROX-
C        IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF
C        THE 21-ST SIGNIFICANT DIGIT.
C
      Z = (((P3*T + P2)*T + P1)*T + P0)/
     *    ((((Q4*T + Q3)*T + Q2)*T + Q1)*T + 1.D0)
C
      W = ((((Z*T + C5)*T + C4)*T + C3)*T + C2)*T + C1
      DRLOG = R*(U - 2.D0*T*W) + W1
      RETURN
C
C
  100 R = (X - 0.5D0) - 0.5D0
      DRLOG = R - DLOG(X)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DRLOG1 (X)
C-----------------------------------------------------------------------
C             EVALUATION OF THE FUNCTION X - LN(1 + X)
C-----------------------------------------------------------------------
      DOUBLE PRECISION X
      DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z
      DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4
      DOUBLE PRECISION C1, C2, C3, C4, C5
C-------------------------
C     A = DRLOG (0.7)
C     B = DRLOG (4/3)
C-------------------------
      DATA A /.566749439387323789126387112411845D-01/
      DATA B /.456512608815524058941143273395059D-01/
C-------------------------
      DATA P0 / .7692307692307692307680D-01/,
     *     P1 /-.1505958055914600184836D+00/,
     *     P2 / .9302355725278521726994D-01/,
     *     P3 /-.1787900022182327735804D-01/
      DATA Q1 /-.2824412139355646910683D+01/,
     *     Q2 / .2892424216041495392509D+01/,
     *     Q3 /-.1263560605948009364422D+01/,
     *     Q4 / .1966769435894561313526D+00/
C-------------------------
C     CI = 1/(2I + 1)
C-------------------------
      DATA C1 /.333333333333333333333333333333333D+00/,
     *     C2 /.200000000000000000000000000000000D+00/,
     *     C3 /.142857142857142857142857142857143D+00/,
     *     C4 /.111111111111111111111111111111111D+00/,
     *     C5 /.909090909090909090909090909090909D-01/
C-------------------------
      IF (X .LT. -0.39D0 .OR. X .GT. 0.57D0) GO TO 100
      IF (X .LT. -0.18D0) GO TO 10
      IF (X .GT.  0.18D0) GO TO 20
C
C                 ARGUMENT REDUCTION
C
      U = X
      UP2 = U + 2.D0
      W1 = 0.D0
      GO TO 30
C
   10 U = (X + 0.3D0)/0.7D0
      UP2 = U + 2.D0
      W1 = A - U*0.3D0
      GO TO 30
C
   20 T = 0.75D0*X
      U = T - 0.25D0
      UP2 = T + 1.75D0
      W1 = B + U/3.D0
C
C                  SERIES EXPANSION
C
   30 R = U/UP2
      T = R*R
C
C        Z IS A MINIMAX APPROXIMATION OF THE SERIES
C
C               C6 + C7*R**2 + C8*R**4 + ...
C
C        FOR THE INTERVAL (0.0, 0.375). THE APPROX-
C        IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF
C        THE 21-ST SIGNIFICANT DIGIT.
C
      Z = (((P3*T + P2)*T + P1)*T + P0)/
     *    ((((Q4*T + Q3)*T + Q2)*T + Q1)*T + 1.D0)
C
      W = ((((Z*T + C5)*T + C4)*T + C3)*T + C2)*T + C1
      DRLOG1 = R*(U - 2.D0*T*W) + W1
      RETURN
C
C
  100 W = (X + 0.5D0) + 0.5D0
      DRLOG1 = X - DLOG(W)
      RETURN
      END
      SUBROUTINE LOCPT (X0, Y0, X, Y, N, L, M)
      REAL X(N), Y(N)
C-----------------------------------------------------------------------
C     GIVEN A POLYGONAL LINE CONNECTING THE VERTICES (X(I),Y(I))
C     (I = 1,...,N) TAKEN IN THIS ORDER. IT IS ASSUMED THAT THE
C     POLYGONAL PATH IS A LOOP, WHERE (X(N),Y(N)) = (X(1),Y(1))
C     OR THERE IS AN ARC FROM (X(N),Y(N)) TO (X(1),Y(1)).
C
C     (X0,Y0) IS AN ARBITRARY POINT AND L AND M ARE VARIABLES.
C     L AND M ARE ASSIGNED THE FOLLOWING VALUES ...
C
C        L = -1   IF (X0,Y0) IS OUTSIDE THE POLYGONAL PATH
C        L =  0   IF (X0,Y0) LIES ON THE POLYGONAL PATH
C        L =  1   IF (X0,Y0) IS INSIDE THE POLYGONAL PATH
C
C     M = 0 IF (X0,Y0) IS ON OR OUTSIDE THE PATH. IF (X0,Y0)
C     IS INSIDE THE PATH THEN M IS THE WINDING NUMBER OF THE
C     PATH AROUND THE POINT (X0,Y0).
C
C-----------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0
C
                     EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      N0 = N
      IF (X(1) .EQ. X(N) .AND. Y(1) .EQ. Y(N)) N0 = N - 1
      PI = ATAN2(0.0, -1.0)
      PI2 = 2.0*PI
      TOL = 4.0*EPS*PI
      L = -1
      M = 0
C
      U = X(1) - X0
      V = Y(1) - Y0
      IF (U .EQ. 0.0 .AND. V .EQ. 0.0) GO TO 20
      IF (N0 .LT. 2) RETURN
      THETA1 = ATAN2(V, U)
C
      SUM = 0.0
      THETA = THETA1
      DO 10 I = 2,N0
         U = X(I) - X0
         V = Y(I) - Y0
         IF (U .EQ. 0.0 .AND. V .EQ. 0.0) GO TO 20
         THETAI = ATAN2(V, U)
C
         ANGLE = ABS(THETAI - THETA)
         IF (ABS(ANGLE - PI) .LT. TOL) GO TO 20
         IF (ANGLE .GT. PI) ANGLE = ANGLE - PI2
         IF (THETA .GT. THETAI) ANGLE = -ANGLE
         SUM = SUM + ANGLE
         THETA = THETAI
   10 CONTINUE
C
      ANGLE = ABS(THETA1 - THETA)
      IF (ABS(ANGLE - PI) .LT. TOL) GO TO 20
      IF (ANGLE .GT. PI) ANGLE = ANGLE - PI2
      IF (THETA .GT. THETA1) ANGLE = -ANGLE
      SUM = SUM + ANGLE
C
C     SUM = 2*PI*M WHERE M IS THE WINDING NUMBER
C
      M = ABS(SUM)/PI2 + 0.2
      IF (M .EQ. 0) RETURN
      L = 1
      IF (SUM .LT. 0.0) M = -M
      RETURN
C
C     (X0, Y0) IS ON THE BOUNDARY OF THE PATH
C
   20 L = 0
      RETURN
      END
      SUBROUTINE PFIND (A, B, X, Y, N, U, V, M, NUM, IERR)
C-----------------------------------------------------------------------
C
C                 INTERSECTION OF A STRIGHT LINE
C                       AND POLYGONAL PATH
C
C-----------------------------------------------------------------------
      REAL A(2), B(2), X(N), Y(N), U(M), V(M)
      REAL K, KI
C----------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 .
C
                      EPS = SPMPAR(1)
C
C----------------------
      NUM = 0
      IF (N .LT. 2) GO TO 200
      H = B(1) - A(1)
      K = B(2) - A(2)
      IF (H .EQ. 0.0 .AND. K .EQ. 0.0) GO TO 200
C
      IERR = 0
      NM1 = N - 1
      TOL = 4.0*EPS
      TOL0 = 2.0*EPS
      ONEP = 1.0 + TOL
      ONEM = 0.5 + (0.5 - TOL0)
C
      IND = 0
      DO 100 I = 1, NM1
         HI = X(I + 1) - X(I)
         KI = Y(I + 1) - Y(I)
         IF (HI .EQ. 0.0 .AND. KI .EQ. 0.0) GO TO 100
         IND = 1
C
C           CHECK IF THE LINE FROM A TO B AND THE I-TH
C                 LINE IN THE PATH ARE PARALLEL
C
         S = HI*K
         T = H*KI
         D = S - T
         IF (ABS(D) .LE. TOL*AMAX1(ABS(S),ABS(T))) GO TO 40
C-----------------------------------------------------------------------
C                   THE LINES ARE NOT PARALLEL
C-----------------------------------------------------------------------
         P = X(I) - A(1)
         Q = Y(I) - A(2)
         S = HI*Q
         T = KI*P
         DIFF = S - T
         IF (ABS(DIFF) .LE. TOL*AMAX1(ABS(S),ABS(T))) DIFF = 0.0
         S = H*Q
         T = K*P
         DIFF1 = S - T
         IF (ABS(DIFF1) .LE. TOL*AMAX1(ABS(S),ABS(T))) DIFF1 = 0.0
C
         S = DIFF/D
         T = DIFF1/D
         IF (S .LT. 0.0 .OR. S .GT. ONEP) GO TO 100
         IF (T .LT. 0.0 .OR. T .GT. ONEP) GO TO 100
         IF (NUM .GT. 0 .AND. T .EQ. 0.0) GO TO 100
         IF (S .GT. 0.0) GO TO 20
C
C                   POINT A IS ON THE I-TH LINE
C
   10    NUM = NUM + 1
         IF (NUM .GT. M) GO TO 210
         U(NUM) = A(1)
         V(NUM) = A(2)
         GO TO 100
C
C                   POINT B IS ON THE I-TH LINE
C
   20    IF (S .LT. ONEM) GO TO 30
   21    NUM = NUM + 1
         IF (NUM .GT. M) GO TO 210
         U(NUM) = B(1)
         V(NUM) = B(2)
         GO TO 100
C
C              THE INTERIOR OF THE LINE FROM A TO B
C                 INTERSECTS WITH THE I-TH LINE
C
   30    NUM = NUM + 1
         IF (NUM .GT. M) GO TO 210
         U(NUM) = A(1) + S*H
         V(NUM) = A(2) + S*K
         GO TO 100
C-----------------------------------------------------------------------
C                     THE LINES ARE PARALLEL
C-----------------------------------------------------------------------
   40    IF (ABS(HI) .GT. ABS(KI)) GO TO 50
C
            D = A(2) - Y(I)
            IF (ABS(D) .LE. TOL0*AMAX1(ABS(A(2)),ABS(Y(I)))) D = 0.0
            S = D/KI
C
            P = X(I) + S*HI
            IF (ABS(A(1) - P) .GT. TOL*AMAX1(ABS(A(1)),ABS(P)))
     *          GO TO 100
C
            D = B(2) - Y(I)
            IF (ABS(D) .LE. TOL0*AMAX1(ABS(B(2)),ABS(Y(I)))) D = 0.0
            T = D/KI
            GO TO 60
C
   50    D = A(1) - X(I)
         IF (ABS(D) .LE. TOL0*AMAX1(ABS(A(1)),ABS(X(I)))) D = 0.0
         S = D/HI
C
         P = Y(I) + S*KI
         IF (ABS(P - A(2)) .GT. TOL*AMAX1(ABS(P),ABS(A(2))))
     *       GO TO 100
C
         D = B(1) - X(I)
         IF (ABS(D) .LE. TOL0*AMAX1(ABS(B(1)),ABS(X(I)))) D = 0.0
         T = D/HI
C
C              THE 2 LINES ARE PORTIONS OF THE SAME
C                     STRAIGHT INFINITE LINE
C
   60    IF (S .GT. 0.0 .AND. S .LT. ONEM) GO TO 220
         IF (T .GT. 0.0 .AND. T .LT. ONEM) GO TO 220
         TMIN = AMIN1(S,T)
         TMAX = AMAX1(S,T)
         IF (TMAX .LE. 0.0) GO TO 70
         IF (TMIN .GE. ONEM) GO TO 80
         GO TO 220
C
   70    IF (TMAX .LT. 0.0) GO TO 100
         IF (NUM .GT. 0) GO TO 100
         IF (TMAX .EQ. S) GO TO 10
         GO TO 21
C
   80    IF (TMIN .GT. 1.0) GO TO 100
         IF (TMIN .EQ. S) GO TO 10
         GO TO 21
C
  100 CONTINUE
      IF (IND .EQ. 0) GO TO 200
C
      IF (NUM .LT. 2) RETURN
      IF (U(NUM) .EQ. X(1) .AND. V(NUM) .EQ. Y(1))
     *    NUM = NUM - 1
      RETURN
C
C                          ERROR RETURN
C
  200 IERR = 1
      RETURN
  210 IERR = 2
      NUM = NUM - 1
      RETURN
  220 IERR = -I
      RETURN
      END
      SUBROUTINE HULL (X, Y, M, BX, BY, K, VX, VY, N)
C-----------------------------------------------------------------------
C           OBTAINING THE CONVEX HULL FOR A FINITE PLANAR SET
C-----------------------------------------------------------------------
      REAL X(M), Y(M)
      REAL BX(*), BY(*), VX(*), VY(*)
      LOGICAL IBEG
C---------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0.
C
                        EPS = SPMPAR(1)
C
C---------------------
      MP1 = M + 1
      ONEP = 1.0 + 4.0*EPS
C
C                       REORDER X AND Y
C
      CALL RRSORT (Y, X, M)
      YMIN = Y(1)
      YMAX = Y(M)
      IF (YMIN .EQ. YMAX) GO TO 500
C
      L = 1
   10    L = L + 1
         IF (Y(L) .EQ. YMIN) GO TO 10
      LMIN = L
      L = L - 1
      CALL RRSORT (X, Y, L)
      X1 = X(1)
C
      I = M
   20    I = I - 1
         IF (Y(I) .EQ. YMAX) GO TO 20
      LMAX = I
      I = I + 1
      CALL RRSORT (X(I), Y(I), M - LMAX)
      XM = X(M)
C
C                      FIND XMIN AND XMAX
C
      XMIN = X1
      XMAX = X(L)
      DO 31 I = LMIN,M
         IF (X(I) .GT. XMIN) GO TO 30
            XMIN = X(I)
            GO TO 31
   30    IF (X(I) .GT. XMAX) XMAX = X(I)
   31 CONTINUE
C
C                   GOING ALONG THE YMIN AXIS
C
      K = L
      DO 50 I = 1,L
         BX(I) = X(I)
         BY(I) = Y(I)
   50 CONTINUE
C
      N = 1
      VX(1) = X(1)
      VY(1) = Y(1)
      IF (L .EQ. 1) GO TO 100
      N = 2
      VX(2) = X(L)
      VY(2) = Y(L)
C
C           GOING FROM THE YMIN AXIS TO THE XMAX AXIS
C
  100 H = XMAX - BX(K)
      IF (H .EQ. 0.0) GO TO 150
      K0 = K
      IBEG = .TRUE.
C
  110 CONTINUE
         L = L + 1
         IF (L .GT. LMAX) L = M
         H = X(L) - BX(K)
         IF (H .LE. 0.0) GO TO 110
         DX = X(L) - BX(K0)
         DY = Y(L) - BY(K0)
         IF (IBEG) GO TO 120
         R = (DX0/DX)*DY
         IF (R .GT. ONEP*DY0) GO TO 130
         IF (DY0 .GT. ONEP*R) GO TO 120
         IF (DY0 .EQ. 0.0 .AND. DY .GT. 0.0) GO TO 140
            K = K + 1
            GO TO 121
  120    IBEG = .FALSE.
         DX0 = DX
         DY0 = DY
         K = K0 + 1
  121    BX(K) = X(L)
         BY(K) = Y(L)
         LSAV = L
  130 H = XMAX - X(L)
      IF (H .GT. 0.0) GO TO 110
C
  140 L = LSAV
      N = N + 1
      VX(N) = BX(K)
      VY(N) = BY(K)
      GO TO 100
C
C                   GOING ALONG THE XMAX AXIS
C
  150 IF (L .EQ. M) GO TO 250
      KSAV = K
      I = L
  151    IF (I .EQ. LMAX) GO TO 160
         I = I + 1
         IF (X(I) .NE. XMAX) GO TO 151
         L = I
         K = K + 1
         BX(K) = X(I)
         BY(K) = Y(I)
         GO TO 151
C
  160 XMAX = X(L)
      H = XMAX - XM
      IF (H .LE. 0.0) GO TO 170
      IF (L .NE. LMAX) GO TO 200
         IF (K .EQ. KSAV) GO TO 170
         N = N + 1
         VX(N) = BX(K)
         VY(N) = BY(K)
C
  170 L = M
      K = K + 1
      BX(K) = XM
      BY(K) = Y(M)
      N = N + 1
      VX(N) = XM
      VY(N) = Y(M)
      GO TO 250
C
C           GOING FROM THE YMAX AXIS TO THE XMAX AXIS
C        (HERE WE ARE TRAVERSING THE BOUNDARY CLOCKWISE)
C
  200 J = MP1
      NN = MP1
      BX(MP1) = XM
      VX(MP1) = XM
      BY(MP1) = Y(M)
      VY(MP1) = Y(M)
      I = LMAX + 1
  201 J0 = J
      IBEG = .TRUE.
C
  210 CONTINUE
         I = I - 1
         H = X(I) - BX(J)
         IF (H .LE. 0.0) GO TO 210
         DX = X(I) - BX(J0)
         DY = ABS(Y(I) - BY(J0))
         IF (IBEG) GO TO 220
         R = (DX0/DX)*DY
         IF (R .GT. ONEP*DY0) GO TO 230
         IF (DY0 .GT. ONEP*R) GO TO 220
         IF (DY0 .EQ. 0.0 .AND. DY .GT. 0.0) GO TO 235
            J = J - 1
            GO TO 221
  220    IBEG = .FALSE.
         DX0 = DX
         DY0 = DY
         J = J0 - 1
  221    BX(J) = X(I)
         BY(J) = Y(I)
         ISAV = I
  230 H = XMAX - X(I)
      IF (H .GT. 0.0) GO TO 210
C
  235 I = ISAV
      NN = NN - 1
      VX(NN) = BX(J)
      VY(NN) = BY(J)
      H = XMAX - BX(J)
      IF (H .GT. 0.0) GO TO 201
C
C          UPDATE BX,BY AND VX,VY SO THAT THE BOUNDARY
C           IS AGAIN BEING TRAVERSED COUNTERCLOCKWISE
C
      IF (I .EQ. L .AND. K .EQ. KSAV) NN = NN + 1
      DO 240 II = NN,MP1
         N = N + 1
         VX(N) = VX(II)
         VY(N) = VY(II)
  240 CONTINUE
C
      IF (I .EQ. L) J = J + 1
      DO 245 II = J,MP1
         K = K + 1
         BX(K) = BX(II)
         BY(K) = BY(II)
  245 CONTINUE
      L = M
C
C                   GOING ALONG THE YMAX AXIS
C
  250 LBEG = LMAX + 1
      IF (LBEG .EQ. M) GO TO 260
      MM1 = M - 1
      DO 251 I = LBEG,MM1
         L = L - 1
         K = K + 1
         BX(K) = X(L)
         BY(K) = Y(L)
  251 CONTINUE
      N = N + 1
      VX(N) = BX(K)
      VY(N) = BY(K)
C
  260 IF (K .EQ. M) GO TO 370
      H = XMAX - BX(K)
      IF (H .GT. 0.0) GO TO 300
      H = BX(K) - XMIN
      IF (H .GT. 0.0) GO TO 301
      GO TO 370
C
C           GOING FROM THE YMAX AXIS TO THE XMIN AXIS
C
  300 H = BX(K) - XMIN
      IF (H .EQ. 0.0) GO TO 350
  301 K0 = K
      IBEG = .TRUE.
C
  310 CONTINUE
         L = L - 1
         IF (L .LT. LMIN) L = 1
         H = X(L) - BX(K)
         IF (H .GE. 0.0) GO TO 310
         DX = ABS(X(L) - BX(K0))
         DY = ABS(Y(L) - BY(K0))
         IF (IBEG) GO TO 320
         R = (DX0/DX)*DY
         IF (R .GT. ONEP*DY0) GO TO 330
         IF (DY0 .GT. ONEP*R) GO TO 320
         IF (DY0 .EQ. 0.0 .AND. DY .GT. 0.0) GO TO 340
            IF (K .EQ. MP1) GO TO 330
            K = K + 1
            GO TO 321
  320    IBEG = .FALSE.
         DX0 = DX
         DY0 = DY
         K = K0 + 1
  321    BX(K) = X(L)
         BY(K) = Y(L)
         LSAV = L
  330 H = X(L) - XMIN
      IF (H .GT. 0.0) GO TO 310
C
  340 L = LSAV
      N = N + 1
      VX(N) = BX(K)
      VY(N) = BY(K)
      IF (L .EQ. 1) RETURN
      IF (K .EQ. M) GO TO 370
      GO TO 300
C
C                   GOING ALONG THE XMIN AXIS
C
  350 KSAV = K
      I = L
  351    IF (I .EQ. LMIN) GO TO 360
         I = I - 1
         IF (X(I) .NE. XMIN) GO TO 351
         L = I
         K = K + 1
         BX(K) = X(I)
         BY(K) = Y(I)
         GO TO 351
C
  360 XMIN = X(L)
      H = X1 - XMIN
      IF (H .LE. 0.0) GO TO 370
      IF (K .EQ. KSAV) GO TO 365
         N = N + 1
         VX(N) = BX(K)
         VY(N) = BY(K)
  365 IF (L .NE. LMIN) GO TO 400
C
  370 K = K + 1
      BX(K) = X1
      BY(K) = Y(1)
      N = N + 1
      VX(N) = X1
      VY(N) = Y(1)
      RETURN
C
C           GOING FROM THE YMIN AXIS TO THE XMIN AXIS
C        (HERE WE ARE TRAVERSING THE BOUNDARY CLOCKWISE)
C
  400 IF (K .EQ. M) GO TO 370
      KP1 = K + 1
      J = MP1
      NN = MP1
      BX(MP1) = X1
      VX(MP1) = X1
      BY(MP1) = Y(1)
      VY(MP1) = Y(1)
      I = LMIN - 1
  401 J0 = J
      IBEG = .TRUE.
C
  410 CONTINUE
         I = I + 1
         H = X(I) - BX(J)
         IF (H .GE. 0.0) GO TO 410
         DX = ABS(X(I) - BX(J0))
         DY = Y(I) - BY(J0)
         IF (IBEG) GO TO 420
         R = (DX0/DX)*DY
         IF (R .GT. ONEP*DY0) GO TO 430
         IF (DY0 .GT. ONEP*R) GO TO 420
         IF (DY0 .EQ. 0.0 .AND. DY .GT. 0.0) GO TO 440
            IF (J .EQ. KP1) GO TO 430
            J = J - 1
            GO TO 421
  420    IBEG = .FALSE.
         DX0 = DX
         DY0 = DY
         J = J0 - 1
  421    BX(J) = X(I)
         BY(J) = Y(I)
         ISAV = I
  430 H = X(I) - XMIN
      IF (H .GT. 0.0) GO TO 410
C
  440 I = ISAV
      NN = NN - 1
      VX(NN) = BX(J)
      VY(NN) = BY(J)
      IF (J .EQ. KP1) GO TO 450
      H = BX(J) - XMIN
      IF (H .GT. 0.0) GO TO 401
C
C          UPDATE BX,BY AND VX,VY SO THAT THE BOUNDARY
C           IS AGAIN BEING TRAVERSED COUNTERCLOCKWISE
C
  450 IF (NN .EQ. N) GO TO 470
      IF (I .EQ. L) NN = NN + 1
      DO 451 II = NN,MP1
         N = N + 1
         VX(N) = VX(II)
         VY(N) = VY(II)
  451 CONTINUE
C
      IF (J .EQ. K) GO TO 471
      IF (I .EQ. L) J = J + 1
      DO 460 II = J,MP1
         K = K + 1
         BX(K) = BX(II)
         BY(K) = BY(II)
  460 CONTINUE
      RETURN
C
  470 N = MP1
  471 K = MP1
      RETURN
C
C                     CASE WHEN YMIN = YMAX
C
  500 CALL RRSORT (X, Y, M)
      DO 510 I = 1,M
         BX(I) = X(I)
         BY(I) = Y(I)
  510 CONTINUE
      K = MP1
      BX(K) = BX(1)
      BY(K) = BY(1)
C
      N = 3
      VX(1) = X(1)
      VX(2) = X(M)
      VX(3) = X(1)
      VY(1) = Y(1)
      VY(2) = Y(M)
      VY(3) = Y(1)
      RETURN
      END
      REAL FUNCTION PAREA(X, Y, NB)
      INTEGER NB
      REAL X(NB), Y(NB)
C
C*****************************************************************
C
C   GIVEN A SEQUENCE OF NB POINTS (X(I),Y(I)). PAREA COMPUTES
C THE AREA BOUNDED BY THE CLOSED POLYGONAL CURVE WHICH PASSES
C THROUGH THE POINTS IN THE ORDER THAT THEY ARE INDEXED. THE
C FINAL POINT OF THE CURVE IS ASSUMED TO BE THE FIRST POINT
C GIVEN. THEREFORE, IT NEED NOT BE LISTED AT THE END OF X AND
C Y. THE CURVE IS NOT REQUIRED TO BE SIMPLE.
C
C*****************************************************************
C
      N = NB
      IF (X(1) .EQ. X(N) .AND. Y(1) .EQ. Y(N)) N = N - 1
      IF (N - 3) 10, 20, 30
C
   10 PAREA = 0.0
      RETURN
C
   20 PAREA= 0.5*((X(2) - X(1))*(Y(3) - Y(1))
     *          - (X(3) - X(1))*(Y(2) - Y(1)))
      RETURN
C
   30 NM1 = N - 1
      A = X(1)*(Y(2) - Y(N)) + X(N)*(Y(1) - Y(NM1))
      DO 31 I = 2, NM1
   31    A = A + X(I)*(Y(I+1) - Y(I-1))
      PAREA = 0.5*A
      RETURN
      END
      SUBROUTINE HC (IND, M, N, PR, AR, NB, S, IWK, NUM)
C
C SUBROUTINE TO FIND ONE OR MORE HAMILTONIAN CIRCUITS IN A
C DIRECTED GRAPH OF  N  VERTICES ( N .GT. 1 ) REPRESENTED
C BY THE INTEGERS  1, 2, ..., N  AND  M  ARCS.
C
C INPUT ...
C
C IND   = 0  ON AN INITIAL CALL TO HC.
C       = 1  OBTAIN ANOTHER HAMILTONIAN CIRCUIT.
C       = 2  MORE BACK TRACKS ARE BEING PERMITTED.
C       = 3  RESTORE THE ORGINAL ARRAY AR.
C M     = NUMBER OF ARCS.
C N     = NUMBER OF VERTICES.
C PR(I) = SUM OF THE OUT-DEGREES OF VERTICES  1, ..., I-1
C         (PR(1) = 0 ,  PR(N+1) = M).
C AR    = ADJACENCY LIST. THE ELEMENTS FROM  AR(PR(I)+1) TO
C         AR(PR(I+1))  ARE A RECORD CONTAINING,IN ANY ORDER,
C         ALL THE VERTICES  J  SUCH THAT ARC  (I,J)  EXISTS.
C         THE GRAPH SHOULD NOT CONTAIN ARCS STARTING AND
C         ENDING AT THE SAME VERTEX.
C NB    = UPPER BOUND ON THE NUMBER OF BACK TRACKS TO BE
C         PERFORMED. (NB = -1 IF NO LIMIT IS TO BE PLACED
C         ON THE NUMBER OF BACK TRACKS TAKEN.)
C NUM   = DIMENSION OF THE WORK SPACE IWK. IT IS ASSUMED THAT
C         NUM .GE. M + 8*N + 20.
C
C OUTPUT ...
C
C IND   = 1   A HAMILTONIAN CIRCUIT WAS FOUND. TO FIND ANOTHER
C             CIRCUIT, RESET NB AND RECALL THE ROUTINE.
C             THE ARRAY AR HAS BEEN MODIFIED. IF ONE DOES NOT
C             WISH TO OBTAIN ANOTHER CIRCUIT, SET IND = 3 AND
C             RECALL THE ROUTINE. THIS WILL RESTORE AR.
C       = 2   THE MAXIMUM NUMBER OF BACK TRACKS WERE PERFORMED.
C             TO CONTINUE, RESET NB AND RECALL THE ROUTINE.
C             THE ARRAY AR HAS BEEN MODIFIED. IF ONE DOES NOT
C             WISH TO CONTINUE, SET IND = 3 AND RECALL THE
C             ROUTINE. THIS WILL RESTORE AR.
C       = 4   NO CIRCUITS WERE FOUND. THE ARRAY  AR  HAS BEEN
C             RESTORED (SEE THE REMARK BELOW) AND THE PROCEDURE
C             IS FINISHED.
C       = -1  (INPUT ERROR) IND .LT. 0  OR IND .GT. 3 ON INPUT.
C       = -2  (INPUT ERROR) IND WAS MODIFIED. RESET IND TO ITS
C              PREVIOUS OUTPUT VALUE AND RERUN THE CODE.
C       = -3  (INPUT ERROR) THE INPUT SETTING IND = 3 CAN BE
C              USED ONLY WHEN THE PREVIOUS OUTPUT VALUE FOR
C              IND WAS 1 OR 2. IF THE PREVIOUS OUTPUT VALUE
C              FOR IND WAS 4, THEN THE ARRAY AR HAS ALREADY
C              BEEN RESTORED AND THERE IS NOTHING TO BE DONE.
C       = -4  (INPUT ERROR) NUM .LT. M + 8*N + 20.
C       = -5  (INPUT ERROR) PR(1) .NE. 0  OR  PR(N+1) .NE. M.
C       = -6  (INPUT ERROR) PR(I) .GT. PR(I+1) FOR SOME I.
C NB    = NUMBER OF BACK TRACKS PERFORMED.
C S(I)  = I-TH  VERTEX IN THE HAMILTONIAN CIRCUIT FOUND.
C
C WORK SPACE ... IWK
C
C REMARK. IN AR, THE ORDER OF THE ARCS IN EACH RECORD MAY BE
C ALTERED BY THE ROUTINE.
C
C     INTEGER PR(N + 1), AR(M), S(N), IWK(M + 8*N + 20)
C
      INTEGER PR(*), AR(M), S(N), IWK(NUM)
      INTEGER S0, PC, AC, VR, VC, P, SUBR, RBUS, TOR
C
      NP1 = N + 1
      IF (IND .LT. 0 .OR. IND .GT. 3) GO TO 20
      IF (NUM .LT. M + 8*N + 20) GO TO 30
      IF (PR(1) .NE. 0 .OR. PR(NP1) .NE. M) GO TO 40
C
      S0 = 20
      PC = S0 + N
      AC = PC + NP1
      VR = AC + M
      VC = VR + N
      P  = VC + N
      SUBR = P + N
      RBUS = SUBR + N
      TOR  = RBUS + N
C
      CALL HC1 (IND, M, N, PR, AR, NB, IWK(S0), NP1, IWK(PC),
     *          IWK(AC), IWK(VR), IWK(VC), IWK(P), IWK(SUBR),
     *          IWK(RBUS), IWK(TOR), IWK(1), IWK(2), IWK(3))
      IF (IND .NE. 1) RETURN
C
      II = S0
      DO 10 I = 1,N
         S(I) = IWK(II)
         II = II + 1
   10 CONTINUE
      RETURN
C
C                   ERROR RETURN
C
   20 IND = -1
      RETURN
   30 IND = -4
      RETURN
   40 IND = -5
      RETURN
      END
      SUBROUTINE HC1 (IND, M, N, PR, AR, NB, S, NP1, PC, AC, VR,
     *                VC, P, SUBR, RBUS, TOR, JR, K, IND0)
C
C MEANING OF THE WORK ARRAYS ...
C
C PC(I)   = SUM OF THE IN-DEGREES OF VERTICES  1, ..., I-1
C           ( PC(1) = 0 ).
C AC      = ADJACENCY LIST (BACKWARD). THE ELEMENTS FROM
C           AC(PC(I)+1)  TO  AC(PC(I+1))  CONTAIN, IN ANY
C           ORDER, ALL THE VERTICES  J  SUCH THAT ARC  (J,I)
C           EXISTS.
C WHEN AN ARC IS REMOVED FROM THE GRAPH AT THE  K-TH  LEVEL
C OF THE BRANCH-DECISION TREE, THE CORRESPONDING ELEMENTS
C AR(Q)  AND  AC(T)  ARE SET TO  - (K*(N+1) + AR(Q))  AND
C TO  - (K*(N+1) + AC(T)) , RESPECTIVELY.
C VR(I)   = CURRENT OUT-DEGREE OF VERTEX I .
C VC(I)   = CURRENT IN-DEGREE OF VERTEX I .
C SUBR(I) = - (K*(N+1) + J)  IF ARC  (I,J)  WAS IMPLIED AT
C           THE  K-TH  LEVEL OF THE BRANCH-DECISION TREE.
C         = 0  OTHERWISE.
C RBUS(I) = - J  IF ARC  (J,I)  IS CURRENTLY IMPLIED.
C         = 0  OTHERWISE.
C TOR(K)  = Q*(M+1) + T  IF THE ARC GOING FROM  S(K)  TO THE
C           ROOT, CORRESPONDING TO  AR(Q)  AND TO  AC(T),
C           WAS REMOVED FROM THE GRAPH AT THE  K-TH  LEVEL
C           OF THE BRANCH-DECISION TREE.
C         = 0  OTHERWISE.
C P(I)    = POINTER FOR THE FORWARD STEP. THE NEXT ARC
C           STARTING FROM  I  TO BE CONSIDERED IN THE
C           BRANCH-DECISION TREE IS  (I,AR(PR(I)+P(I)).
C
C MEANING OF THE MAIN SIMPLE VARIABLES ...
C
C JR   = ROOT. THE HAMILTONIAN CIRCUITS ARE DETERMINED AS
C        PATHS STARTING AND ENDING AT  JR .
C K    = CURRENT LEVEL OF THE BRANCH-DECISION TREE.
C IND0 = VALUE OF IND WHEN HC WAS PREVIOUSLY CALLED AND
C        THERE WERE NO INPUT ERRORS.
C
      INTEGER PR(NP1), PC(NP1), AR(M), AC(M), S(N), VR(N), VC(N),
     *        P(N), SUBR(N), RBUS(N), TOR(N)
C
      NBO = NB
      NB = 0
      MP1 = M + 1
      IF (IND .NE. 0) GO TO 500
C
C S T E P   0   (INITIALIZE).
C
      DO 10 I=1,N
        VC(I) = 0
        SUBR(I) = 0
        RBUS(I) = 0
        P(I) = 1
   10 CONTINUE
      DO 30 I=1,N
        J1 = PR(I) + 1
        J2 = PR(I+1)
        VR(I) = J2 - J1 + 1
        IF (VR(I) .EQ. 0) GO TO 440
        IF (VR(I) .LT. 0) GO TO 620
        DO 20 J=J1,J2
          JA = AR(J)
          VC(JA) = VC(JA) + 1
   20   CONTINUE
   30 CONTINUE
      PC(1) = 0
      DO 40 I=1,N
        IF (VC(I) .EQ. 0) GO TO 440
        PC(I+1) = PC(I) + VC(I)
        VC(I) = 0
   40 CONTINUE
      DO 60 I=1,N
        J1 = PR(I) + 1
        J2 = PR(I+1)
        DO 50 J=J1,J2
          JJ = AR(J)
          VC(JJ) = VC(JJ) + 1
          JA = PC(JJ) + VC(JJ)
          AC(JA) = I
   50   CONTINUE
   60 CONTINUE
C SELECT AS ROOT  JR  THE VERTEX  I  WITH MAXIMUM  VC(I)
C (BREAK TIES BY CHOOSING  I  WITH MINIMUM  VR(I) ).
      MAXE = VC(1)
      MINU = VR(1)
      JR = 1
      DO 100 I=2,N
        IF (VC(I)-MAXE) 100, 70, 80
   70   IF (VR(I).GE.MINU) GO TO 100
        GO TO 90
   80   MAXE = VC(I)
   90   MINU = VR(I)
        JR = I
  100 CONTINUE
      K1 = -NP1
      K = 1
      S(1) = JR
C
C S T E P   1   (SEARCH FOR IMPLIED ARCS).
C
  110 DO 120 J=1,N
        IF (VR(J).EQ.1) GO TO 130
        IF (VC(J).EQ.1) GO TO 170
  120 CONTINUE
C NO FURTHER ARC CAN BE IMPLIED.
      GO TO 220
C ARC  (J,JL)  IS IMPLIED BECAUSE  VR(J) = 1 .
  130 L1 = PR(J) + 1
      L2 = PR(J+1)
      DO 140 L=L1,L2
        IF (AR(L).GT.0) GO TO 150
  140 CONTINUE
  150 JL = AR(L)
C FIND THE STARTING VERTEX  IT1  AND THE ENDING VERTEX  IT2
C OF THE LARGEST PATH OF IMPLIED ARCS CONTAINING  (J,JL) .
      CALL IPATH(J, JL, SUBR, RBUS, AR, PR, S, N, NP, IT1, IT2, K, JR,
     * M, NP1)
      IF (NP.EQ.0) GO TO 160
      IF (NP.EQ.(-1)) GO TO 340
C SUBROUTINE IPATH FOUND A HAMILTONIAN CIRCUIT.
      K = K + 1
      GO TO 320
  160 SUBR(J) = K1 - JL
      RBUS(JL) = J
C REMOVE FROM THE GRAPH ALL ARCS TERMINATING AT  JL .
      CALL IUPD(J, JL, L, AC, AR, PC, PR, VC, VR, K1, N, M, NP1)
      IF (J.EQ.0) GO TO 340
      GO TO 210
C ARC  (JL,J)  IS IMPLIED BECAUSE  VC(J) = 1 .
  170 L1 = PC(J) + 1
      L2 = PC(J+1)
      DO 180 L=L1,L2
        IF (AC(L).GT.0) GO TO 190
  180 CONTINUE
  190 JL = AC(L)
C FIND THE STARTING VERTEX  IT1  AND THE ENDING VERTEX  IT2
C OF THE LARGEST PATH OF IMPLIED ARCS CONTAINING  (JL,J) .
      CALL IPATH(JL, J, SUBR, RBUS, AR, PR, S, N, NP, IT1, IT2, K, JR,
     * M, NP1)
      IF (NP.EQ.0) GO TO 200
      IF (NP.EQ.(-1)) GO TO 340
C SUBROUTINE IPATH FOUND A HAMILTONIAN CIRCUIT.
      I = S(K)
      K = K + 1
      GO TO 320
  200 SUBR(JL) = K1 - J
      RBUS(J) = JL
C REMOVE FROM THE GRAPH ALL ARCS EMANATING FROM  JL .
      CALL IUPD(J, JL, L, AR, AC, PR, PC, VR, VC, K1, N, M, NP1)
      IF (J.EQ.0) GO TO 340
C IF ARC  (IT2,IT1)  IS IN THE GRAPH, REMOVE IT.
  210 CALL RARC(IT2, IT1, AR, AC, PR, PC, VR, VC, K1, JJ, LL, N, M, NP1)
      IF (JJ.EQ.(-1)) GO TO 340
      GO TO 110
C
C S T E P   2   (ADD IMPLIED ARCS TO S).
C
  220 I = S(K)
      IF (SUBR(I).EQ.0) GO TO 230
      JSUBR = -SUBR(I) + (SUBR(I)/NP1)*NP1
      IF (JSUBR.EQ.JR) GO TO 340
      K = K + 1
      S(K) = JSUBR
      IF (K.NE.N) GO TO 220
      IF (SUBR(JSUBR).LT.0) GO TO 320
      GO TO 340
C
C S T E P   3   (BRANCH).
C
  230 L1 = PR(I) + P(I)
      L2 = PR(I+1)
      IF (L1.GT.L2) GO TO 340
C FIND THE NEXT ARC  (I,JL)  TO BE ADDED TO  S .
      DENS = N**3
      J1 = 0
      J2 = 0
      DO 310 J=L1,L2
        JL = AR(J)
        IF (JL.LT.0) GO TO 310
        IF (VR(JL).GT.0) GO TO 260
        IF (SUBR(JL).EQ.0) GO TO 310
        IF (JL.EQ.JR) GO TO 310
        IEND = JL
  240   IEND = -SUBR(IEND) + (SUBR(IEND)/NP1)*NP1
        IF (SUBR(IEND).NE.0) GO TO 240
        IF (VC(JL).LT.VR(IEND)) GO TO 250
        SCORE = VR(IEND)*N + VC(JL)
        GO TO 280
  250   SCORE = VC(JL)*N + VR(IEND)
        GO TO 280
  260   IF (VC(JL).LT.VR(JL)) GO TO 270
        SCORE = VR(JL)*N + VC(JL)
        GO TO 280
  270   SCORE = VC(JL)*N + VR(JL)
  280   IF (DENS.LE.SCORE) GO TO 290
        DENS = SCORE
        IPI = J
  290   IF (J1.EQ.0) GO TO 300
        IF (J2.EQ.0) J2 = J
        GO TO 310
  300   J1 = J
  310 CONTINUE
      IF (J1.EQ.0) GO TO 340
      JL = AR(IPI)
      AR(IPI) = AR(J1)
      AR(J1) = JL
      IF (J2.EQ.0) J2 = PR(I+1) + 1
      P(I) = J2 - PR(I)
      K = K + 1
      S(K) = JL
      K1 = -K*NP1
C REMOVE FROM THE GRAPH ALL ARCS EMANATING FROM  I .
      CALL FUPD(AR, AC, PR, PC, VR, VC, I, K1, N, M, NP1)
C REMOVE FROM THE GRAPH ALL ARCS TERMINATING AT JL .
      CALL FUPD(AC, AR, PC, PR, VC, VR, JL, K1, N, M, NP1)
      TOR(K) = 0
C IF ARC  (JL,JR)  IS IN THE GRAPH, REMOVE IT.
      CALL RARC(JL, JR, AR, AC, PR, PC, VR, VC, K1, JJ, LL, N, M, NP1)
      IF (JJ.EQ.0) GO TO 110
      IF (JJ.EQ.(-1)) GO TO 340
      TOR(K) = JJ*MP1 + LL
      GO TO 110
C
C S T E P   4   (HAMILTONIAN CIRCUIT FOUND).
C
  320 IND = 1
      IND0 = 1
      K = K - 1
      RETURN
C
C S T E P   5   (BACKTRACK).
C
  340 IF (K .LE. 1) GO TO 430
      JA = S(K)
      P(JA) = 1
      JA = S(K-1)
      IF (SUBR(JA) .EQ. 0) GO TO 350
C BACKTRACKING FOR AN IMPLIED ARC.
      K = K - 1
      GO TO 340
  350 IF (NB .EQ. NBO) GO TO 450
      NB = NB + 1
      K1 = -K*NP1
      K2 = -(K+1)*NP1
      I = S(K-1)
C BACKTRACKING FOR THE ARCS IMPLIED AT LEVEL  K .
      IFF = 0
      DO 360 J=1,N
        IF (SUBR(J).GT.K1) GO TO 360
        IF (SUBR(J).LT.K2) GO TO 360
        JA = K1 - SUBR(J)
        RBUS(JA) = 0
        SUBR(J) = 0
        IFF = 1
  360 CONTINUE
      IF (IFF.EQ.1) GO TO 370
C NO ARC WAS IMPLIED AT LEVEL  K .
      CALL BUPD(AR, AC, PR, PC, VR, VC, I, K1, K2, N, M, NP1)
      CALL BUPD(AC, AR, PC, PR, VC, VR, S(K), K1, K2, N, M, NP1)
      IF (TOR(K).EQ.0) GO TO 420
      J1 = TOR(K)/MP1
      J2 = TOR(K) - J1*MP1
      AR(J1) = JR
      JA = S(K)
      VR(JA) = VR(JA) + 1
      AC(J2) = S(K)
      VC(JR) = VC(JR) + 1
      GO TO 420
C AT LEAST ONE ARC WAS IMPLIED AT LEVEL  K .
  370 DO 410 J=1,N
        L1 = PR(J) + 1
        L2 = PR(J+1)
        DO 400 L=L1,L2
          JL = AR(L)
          IF (JL.GT.K1) GO TO 400
          IF (JL.LT.K2) GO TO 400
          JL = K1 - JL
          AR(L) = JL
          VR(J) = VR(J) + 1
          LL1 = PC(JL) + 1
          LL2 = PC(JL+1)
          DO 380 LL=LL1,LL2
            IF (K1-AC(LL).EQ.J) GO TO 390
  380     CONTINUE
  390     AC(LL) = J
          VC(JL) = VC(JL) + 1
  400   CONTINUE
  410 CONTINUE
  420 K = K - 1
      GO TO 230
C
C RESTORE THE ORIGINAL VECTOR  AR
C
  430 DO 431 J = 1,M
        IF (AR(J) .GT. 0) GO TO 431
        AR(J) = -AR(J) + (AR(J)/NP1)*NP1
  431 CONTINUE
C
C THE ALGORITHM IS FINISHED
C
  440 IND = 4
      IND0 = 4
      RETURN
C
C THE MAXIMUM NUMBER OF BACK TRACKS WERE PERFORMED
C
  450 IND = 2
      IND0 = 2
      RETURN
C
C CHECK IND WHEN IND = 1, 2, OR 3
C
  500 IF (IND .NE. 3) GO TO 510
         IF (IND0 .EQ. 1 .OR. IND0 .EQ. 2) GO TO 430
         GO TO 610
  510 IF (IND .NE. IND0) GO TO 600
      IF (IND .EQ. 1) GO TO 340
      GO TO 350
C
C ERROR RETURN
C
  600 IND = -2
      RETURN
  610 IND = -3
      RETURN
  620 IND = -6
      RETURN
      END
      SUBROUTINE IPATH (I, J, SUBR, RBUS, AR, PR, S, N, NP, I1, I2, K,
     * JR, M, NP1)
C
C SUBROUTINE TO FIND THE STARTING VERTEX  I1  AND THE ENDING
C VERTEX  I2  OF THE LARGEST PATH OF IMPLIED ARCS CONTAINING
C ARC  (I,J) .
C
C MEANING OF THE OUTPUT PARAMETER  NP ...
C
C NP =  0  IF THE PATH CONTAINS  L .LT. N  VERTICES.
C    =  1  IF THE PATH CONTAINS  N  VERTICES AND ARC (I2,I1)
C          EXISTS (THE HAMILTONIAN CIRCUIT IS STORED IN  S )
C    = -1  IF THE PATH CONTAINS  N  VERTICES BUT ARC (I2,I1)
C          DOES NOT EXIST.
C
      INTEGER SUBR(N), RBUS(N), AR(M), PR(NP1), S(N)
C
      NP = 0
      L = 1
      I1 = I
   10 IF (RBUS(I1).EQ.0) GO TO 20
      I1 = RBUS(I1)
      L = L + 1
      GO TO 10
   20 I2 = J
      L = L + 1
   30 IF (SUBR(I2).EQ.0) GO TO 40
      I2 = -SUBR(I2) + (SUBR(I2)/NP1)*NP1
      L = L + 1
      GO TO 30
   40 CONTINUE
      IF (L.LT.N) RETURN
C THE PATH CONTAINS  N  VERTICES.
      K1 = -K*NP1
      L1 = PR(I2) + 1
      L2 = PR(I2+1)
      DO 60 L=L1,L2
        IF (AR(L).LT.0) GO TO 50
        IF (AR(L).EQ.I1) GO TO 70
        GO TO 60
   50   IF (K1-AR(L).EQ.I1) GO TO 70
   60 CONTINUE
C NO HAMILTONIAN CIRCUIT CAN BE DETERMINED.
      NP = -1
      RETURN
C A HAMILTONIAN CIRCUIT EXISTS. STORE IT IN  S .
   70 NP = 1
      RBUS(J) = I
      RBUS(I1) = I2
      S(N) = RBUS(JR)
      L = N - 1
   80 IF (L.EQ.K) GO TO 90
      JA = S(L+1)
      S(L) = RBUS(JA)
      L = L - 1
      GO TO 80
   90 RBUS(I1) = 0
      RBUS(J) = 0
      RETURN
      END
      SUBROUTINE FUPD (A1, A2, P1, P2, V1, V2, I1, K1, N, M, NP1)
C
C FORWARD STEP UPDATING
C
      INTEGER A1(M), A2(M), P1(NP1), P2(NP1), V1(N), V2(N)
C
      J1 = P1(I1) + 1
      J2 = P1(I1+1)
      DO 30 J=J1,J2
        IF (A1(J).LT.0) GO TO 30
        IA = A1(J)
        L1 = P2(IA) + 1
        L2 = P2(IA+1)
        DO 10 L=L1,L2
          IF (A2(L).EQ.I1) GO TO 20
   10   CONTINUE
   20   V2(IA) = V2(IA) - 1
        A2(L) = K1 - A2(L)
        A1(J) = K1 - IA
   30 CONTINUE
      V1(I1) = 0
      RETURN
      END
      SUBROUTINE BUPD (A1, A2, P1, P2, V1, V2, II, K1, K2, N, M, NP1)
C
C BACKTRACKING STEP UPDATING
C
      INTEGER A1(M), A2(M), P1(NP1), P2(NP1), V1(N), V2(N)
C
      L1 = P1(II) + 1
      L2 = P1(II+1)
      DO 30 L=L1,L2
        IF (A1(L).GT.K1) GO TO 30
        IF (A1(L).LT.K2) GO TO 30
        IA = K1 - A1(L)
        A1(L) = IA
        V1(II) = V1(II) + 1
        LL1 = P2(IA) + 1
        LL2 = P2(IA+1)
        DO 10 LL=LL1,LL2
          IF (K1-A2(LL).EQ.II) GO TO 20
   10   CONTINUE
   20   A2(LL) = II
        V2(IA) = V2(IA) + 1
   30 CONTINUE
      RETURN
      END
      SUBROUTINE IUPD(IA, IB, L, A1, A2, P1, P2, V1, V2, K1, N, M, NP1)
C
C UPDATING FOR IMPLIED ARC
C
      INTEGER A1(M), A2(M), P1(NP1), P2(NP1), V1(N), V2(N)
C
      M1 = P1(IB) + 1
      M2 = P1(IB+1)
      DO 40 MM=M1,M2
        IARC = A1(MM)
        IF (IARC.LT.0) GO TO 40
        IF (V2(IARC).NE.1) GO TO 10
        IF (IARC.NE.IA) GO TO 50
        JJ = L
        GO TO 30
   10   J1 = P2(IARC) + 1
        J2 = P2(IARC+1)
        DO 20 JJ=J1,J2
          IF (A2(JJ).EQ.IB) GO TO 30
   20   CONTINUE
   30   A2(JJ) = K1 - A2(JJ)
        V2(IARC) = V2(IARC) - 1
        A1(MM) = K1 - IARC
        V1(IB) = V1(IB) - 1
   40 CONTINUE
      RETURN
   50 IA = 0
      RETURN
      END
      SUBROUTINE RARC(IA, IB, AR, AC, PR, PC, VR, VC, K1, JJ, LL, N, M,
     * NP1)
C
C SUBROUTINE TO REMOVE ARC  (IA,IB)  FROM THE GRAPH.
C
C MEANING OF THE OUTPUT PARAMETERS  JJ  AND  LL ...
C
C JJ =  LOCATION OF THE ELEMENT OF  AR  CORRESPONDING TO THE
C       REMOVED ARC.
C    =  0  IF ARC  (IA,IB)  IS NOT IN THE GRAPH.
C    = -1  IF, AFTER THE REMOVAL OF ARC  (IA,IB) , THE GRAPH
C          WOULD ADMIT NO HAMILTONIAN CIRCUIT.
C LL =  LOCATION OF THE ELEMENT OF  AC  CORRESPONDING TO THE
C       REMOVED ARC (DEFINED ONLY IF  JJ .GT. 0 ).
C
      INTEGER AR(M), AC(M), PR(NP1), PC(NP1), VR(N), VC(N)
C
      J1 = PR(IA) + 1
      J2 = PR(IA+1)
      DO 20 JJ=J1,J2
        IF (AR(JJ).LT.0) GO TO 20
        IF (AR(JJ).NE.IB) GO TO 20
        L1 = PC(IB) + 1
        L2 = PC(IB+1)
        DO 10 LL=L1,L2
          IF (AC(LL).EQ.IA) GO TO 30
   10   CONTINUE
   20 CONTINUE
C ARC  (IA,IB)  IS NOT IN THE GRAPH.
      JJ = 0
      RETURN
   30 IF (VR(IA).EQ.1) GO TO 40
      IF (VC(IB).EQ.1) GO TO 40
      AR(JJ) = K1 - IB
      VR(IA) = VR(IA) - 1
      AC(LL) = K1 - IA
      VC(IB) = VC(IB) - 1
      RETURN
C ARC  (IA,IB)  CANNOT BE REMOVED FROM THE GRAPH.
   40 JJ = -1
      RETURN
      END
      SUBROUTINE CERF (MO, Z, W)
C-----------------------------------------------------------------------
C
C               COMPUTATION OF THE COMPLEX ERROR FUNCTION
C
C                           ----------------
C
C                        W = ERF(Z)   IF MO = 0
C                        W = ERFC(Z)  OTHERWISE
C
C-----------------------------------------------------------------------
      COMPLEX Z, W
      REAL CD(18), CE(18), EF(2), QF(2), SM(2), SZ(2), TM(2), TS(2)
C------------------------
C     C = 1/SQRT(PI)
C------------------------
      DATA C /.564189583547756/
C------------------------
      DATA CD(1) /0.00000000000000E00/,  CD(2) /2.08605856013476E-2/,
     1     CD(3) /8.29806940495687E-2/,  CD(4) /1.85421653326079E-1/,
     2     CD(5) /3.27963479382361E-1/,  CD(6) /5.12675279912828E-1/,
     3     CD(7) /7.45412958045105E-1/,  CD(8) /1.03695067418297E00/,
     4     CD(9) /1.40378061255437E00/,  CD(10)/1.86891662214001E00/,
     5     CD(11)/2.46314830523929E00/,  CD(12)/3.22719383737352E00/,
     6     CD(13)/4.21534348280013E00/,  CD(14)/5.50178873151549E00/,
     7     CD(15)/7.19258966683102E00/,  CD(16)/9.45170208076408E00/,
     8     CD(17)/1.25710718314784E+1/,  CD(18)/1.72483537216334E+1/
      DATA CE(1) /8.15723083324096E-2/,  CE(2) /1.59285285253437E-1/,
     1     CE(3) /1.48581625614499E-1/,  CE(4) /1.33219670836245E-1/,
     2     CE(5) /1.15690392878957E-1/,  CE(6) /9.78580959447535E-2/,
     3     CE(7) /8.05908834297624E-2/,  CE(8) /6.40204538609872E-2/,
     4     CE(9) /4.81445242767885E-2/,  CE(10)/3.33540658473295E-2/,
     5     CE(11)/2.05548099470193E-2/,  CE(12)/1.07847403887506E-2/,
     6     CE(13)/4.55634892214219E-3/,  CE(14)/1.43984458138925E-3/,
     7     CE(15)/3.07056139834171E-4/,  CE(16)/3.78156541168541E-5/,
     8     CE(17)/2.05173509616121E-6/,  CE(18)/2.63564823682747E-8/
C------------------------
      X = REAL(Z)
      Y = AIMAG(Z)
      SN = 1.0
      IF (X .GE. 0.0) GO TO 10
         X = -X
         Y = -Y
         SN = -1.0
C
   10 R = X*X + Y*Y
      SZ(1) = X*X - Y*Y
      SZ(2) = 2.0*X*Y
C
      IF (R .LE. 1.0) GO TO 20
      IF (R .GE. 38.0) GO TO 60
      IF (SZ(1) + 0.064*SZ(2)*SZ(2) .GT. 0.0) GO TO 50
C
C                       TAYLOR SERIES
C
   20 C2 = C + C
      TM(1) = C2*X
      TM(2) = C2*Y
      SM(1) = TM(1)
      SM(2) = TM(2)
      PM = 0.0
   30    PM = PM + 1.0
         DM = 2.0*PM + 1.0
         TS(1) = TM(1)*SZ(1) - TM(2)*SZ(2)
         TS(2) = TM(1)*SZ(2) + TM(2)*SZ(1)
         TM(1) = -TS(1)/PM
         TM(2) = -TS(2)/PM
         TS(1) = TM(1)/DM
         TS(2) = TM(2)/DM
         IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 31
         IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 40
   31    SM(1) = SM(1) + TS(1)
         SM(2) = SM(2) + TS(2)
         GO TO 30
C
C                       TERMINATION
C
   40 IF (MO .NE. 0) GO TO 41
         W = CMPLX(SN*SM(1), SN*SM(2))
         RETURN
   41 IF (SN .LT. 0.0) GO TO 42
         SM(1) = 0.5 + (0.5 - SM(1))
         SM(2) = -SM(2)
         W = CMPLX(SM(1), SM(2))
         RETURN
   42 W = CMPLX(1.0 + SM(1), SM(2))
      RETURN
C
C              RATIONAL FUNCTION APPROXIMATION
C
   50 SM(1) = 0.0
      SM(2) = 0.0
      QM = C*EXP(-SZ(1))
      TS(1) = QM*COS(-SZ(2))
      TS(2) = QM*SIN(-SZ(2))
      QF(1) = TS(1)*X - TS(2)*Y
      QF(2) = TS(1)*Y + TS(2)*X
      DO 51 I = 1,18
         TS(1) = SZ(1) + CD(I)
         TS(2) = SZ(2)
         SS = TS(1)*TS(1) + TS(2)*TS(2)
         TM(1) =  CE(I)*TS(1)/SS
         TM(2) = -CE(I)*TS(2)/SS
         SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
   51 CONTINUE
      EF(1) = QF(1)*SM(1) - QF(2)*SM(2)
      EF(2) = QF(1)*SM(2) + QF(2)*SM(1)
      GO TO 100
C
C                   ASYMPTOTIC EXPANSION
C
   60 QF(1) =  SZ(1)/(R*R)
      QF(2) = -SZ(2)/(R*R)
      QM = C*EXP(-SZ(1))
      TS(1) = QM*COS(-SZ(2))
      TS(2) = QM*SIN(-SZ(2))
      TM(1) =  (TS(1)*X + TS(2)*Y)/R
      TM(2) = -(TS(1)*Y - TS(2)*X)/R
      SM(1) = TM(1)
      SM(2) = TM(2)
      PM = -0.5
   70    PM = PM + 1.0
         TS(1) = TM(1)*QF(1) - TM(2)*QF(2)
         TS(2) = TM(1)*QF(2) + TM(2)*QF(1)
         TM(1) = -PM*TS(1)
         TM(2) = -PM*TS(2)
         IF (ABS(SM(1)) + ABS(TM(1)) .NE. ABS(SM(1))) GO TO 71
         IF (ABS(SM(2)) + ABS(TM(2)) .EQ. ABS(SM(2))) GO TO 80
   71    SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
         IF (PM .LT. 25.5) GO TO 70
C
   80 IF (X .GE. 0.01) GO TO 81
         SN = -SN
         GO TO 40
   81 EF(1) = SM(1)
      EF(2) = SM(2)
C
C                       TERMINATION
C
  100 IF (MO .EQ. 0) GO TO 101
         W = CMPLX(EF(1), EF(2))
         IF (SN .EQ. 1.0) RETURN
         W = CMPLX(2.0 - EF(1), -EF(2))
         RETURN
  101 EF(1) = SN*(1.0 - EF(1))
      EF(2) = -SN*EF(2)
      W = CMPLX(EF(1),EF(2))
      RETURN
      END
      SUBROUTINE CERFC (MO, Z, W)
C-----------------------------------------------------------------------
C
C              COMPUTATION OF THE COMPLEX COERROR FUNCTION
C
C                           ----------------
C
C           W = ERFC(Z)           IF MO = 0 OR REAL(Z) .LT. 0
C           W = EXP(X*X)*ERFC(Z)  OTHERWISE
C
C-----------------------------------------------------------------------
      COMPLEX Z, W
      REAL CD(18), CE(18), QF(2), SM(2), SZ(2), TM(2), TS(2)
C------------------------
C     C = 1/SQRT(PI)
C------------------------
      DATA C /.564189583547756/
C------------------------
      DATA CD(1) /0.00000000000000E00/,  CD(2) /2.08605856013476E-2/,
     1     CD(3) /8.29806940495687E-2/,  CD(4) /1.85421653326079E-1/,
     2     CD(5) /3.27963479382361E-1/,  CD(6) /5.12675279912828E-1/,
     3     CD(7) /7.45412958045105E-1/,  CD(8) /1.03695067418297E00/,
     4     CD(9) /1.40378061255437E00/,  CD(10)/1.86891662214001E00/,
     5     CD(11)/2.46314830523929E00/,  CD(12)/3.22719383737352E00/,
     6     CD(13)/4.21534348280013E00/,  CD(14)/5.50178873151549E00/,
     7     CD(15)/7.19258966683102E00/,  CD(16)/9.45170208076408E00/,
     8     CD(17)/1.25710718314784E+1/,  CD(18)/1.72483537216334E+1/
      DATA CE(1) /8.15723083324096E-2/,  CE(2) /1.59285285253437E-1/,
     1     CE(3) /1.48581625614499E-1/,  CE(4) /1.33219670836245E-1/,
     2     CE(5) /1.15690392878957E-1/,  CE(6) /9.78580959447535E-2/,
     3     CE(7) /8.05908834297624E-2/,  CE(8) /6.40204538609872E-2/,
     4     CE(9) /4.81445242767885E-2/,  CE(10)/3.33540658473295E-2/,
     5     CE(11)/2.05548099470193E-2/,  CE(12)/1.07847403887506E-2/,
     6     CE(13)/4.55634892214219E-3/,  CE(14)/1.43984458138925E-3/,
     7     CE(15)/3.07056139834171E-4/,  CE(16)/3.78156541168541E-5/,
     8     CE(17)/2.05173509616121E-6/,  CE(18)/2.63564823682747E-8/
C------------------------
      X = REAL(Z)
      Y = AIMAG(Z)
      SN = 1.0
      IF (X .GE. 0.0) GO TO 10
         X = -X
         Y = -Y
         SN = -1.0
C
   10 IF (MO .NE. 0  .AND.  SN .EQ. 1.0  .AND.
     *   AMAX1(X, ABS(Y)) .GE. 100.0) GO TO 60
      R = X*X + Y*Y
      SZ(1) = X*X - Y*Y
      SZ(2) = 2.0*X*Y
C
      IF (R .LE. 1.0) GO TO 20
      IF (R .GE. 38.0) GO TO 60
      IF (SZ(1) + 0.064*SZ(2)*SZ(2) .GT. 0.0) GO TO 50
C
C                       TAYLOR SERIES
C
   20 C2 = C + C
      TM(1) = C2*X
      TM(2) = C2*Y
      SM(1) = TM(1)
      SM(2) = TM(2)
      PM = 0.0
   30    PM = PM + 1.0
         DM = 2.0*PM + 1.0
         TS(1) = TM(1)*SZ(1) - TM(2)*SZ(2)
         TS(2) = TM(1)*SZ(2) + TM(2)*SZ(1)
         TM(1) = -TS(1)/PM
         TM(2) = -TS(2)/PM
         TS(1) = TM(1)/DM
         TS(2) = TM(2)/DM
         IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 31
         IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 40
   31    SM(1) = SM(1) + TS(1)
         SM(2) = SM(2) + TS(2)
         GO TO 30
C
C                       TERMINATION
C
   40 IF (SN .EQ. 1.0) GO TO 41
         W = CMPLX(1.0 + SM(1), SM(2))
         RETURN
   41 SM(1) = 0.5 + (0.5 - SM(1))
      SM(2) = -SM(2)
      IF (MO .EQ. 0) GO TO 110
C
      QM = EXP(SZ(1))
      QF(1) = QM*COS(SZ(2))
      QF(2) = QM*SIN(SZ(2))
      TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      W = CMPLX(TS(1),TS(2))
      RETURN
C
C              RATIONAL FUNCTION APPROXIMATION
C
   50 SM(1) = 0.0
      SM(2) = 0.0
      DO 51 I = 1,18
         TS(1) = SZ(1) + CD(I)
         TS(2) = SZ(2)
         SS = TS(1)*TS(1) + TS(2)*TS(2)
         TM(1) =  CE(I)*TS(1)/SS
         TM(2) = -CE(I)*TS(2)/SS
         SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
   51 CONTINUE
      TS(1) = X*SM(1) - Y*SM(2)
      TS(2) = X*SM(2) + Y*SM(1)
      SM(1) = C*TS(1)
      SM(2) = C*TS(2)
      GO TO 100
C
C                   ASYMPTOTIC EXPANSION
C
   60 CALL CREC (X, Y, TM(1), TM(2))
      SM(1) = TM(1)
      SM(2) = TM(2)
      QF(1) = TM(1)*TM(1) - TM(2)*TM(2)
      QF(2) = 2.0*TM(1)*TM(2)
      PM = -0.5
   70    PM = PM + 1.0
         TS(1) = TM(1)*QF(1) - TM(2)*QF(2)
         TS(2) = TM(1)*QF(2) + TM(2)*QF(1)
         TM(1) = -PM*TS(1)
         TM(2) = -PM*TS(2)
         IF (ABS(SM(1)) + ABS(TM(1)) .NE. ABS(SM(1))) GO TO 71
         IF (ABS(SM(2)) + ABS(TM(2)) .EQ. ABS(SM(2))) GO TO 80
   71    SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
         IF (PM .LT. 25.5) GO TO 70
   80 SM(1) = C*SM(1)
      SM(2) = C*SM(2)
      IF (X .LT. 0.01) GO TO 200
C
C                       TERMINATION
C
  100 IF (MO .NE. 0 .AND. SN .EQ. 1.0) GO TO 110
      QM = EXP(-SZ(1))
      QF(1) = QM*COS(-SZ(2))
      QF(2) = QM*SIN(-SZ(2))
      TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      SM(1) = TS(1)
      SM(2) = TS(2)
C
      IF (SN .EQ. 1.0) GO TO 110
         W = CMPLX(2.0 - SM(1), -SM(2))
         RETURN
  110 W = CMPLX(SM(1), SM(2))
      RETURN
C
C               MODIFIED ASYMPTOTIC EXPANSION
C
  200 IF (MO .NE. 0 .AND. SN .EQ. 1.0) GO TO 210
      QM = EXP(-SZ(1))
      QF(1) = QM*COS(-SZ(2))
      QF(2) = QM*SIN(-SZ(2))
      TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      SM(1) = 1.0 + SN*TS(1)
      SM(2) = SN*TS(2)
      W = CMPLX(SM(1),SM(2))
      RETURN
C
  210 IF (ABS(Y) .GE. 100.0) GO TO 110
      IF (SZ(1) .LE. EXPARG(1)) GO TO 110
      QM = EXP(SZ(1))
      SM(1) = QM*COS(SZ(2)) + SM(1)
      SM(2) = QM*SIN(SZ(2)) + SM(2)
      W = CMPLX(SM(1),SM(2))
      RETURN
      END
      REAL FUNCTION ERF (X)
C-----------------------------------------------------------------------
C             EVALUATION OF THE REAL ERROR FUNCTION
C-----------------------------------------------------------------------
      REAL A(5),B(3),P(8),Q(8),R(5),S(4)
C-------------------------
      DATA C /.564189583547756/
C-------------------------
      DATA A(1) /.771058495001320E-04/, A(2)/-.133733772997339E-02/,
     *     A(3) /.323076579225834E-01/, A(4) /.479137145607681E-01/,
     *     A(5) /.128379167095513E+00/
      DATA B(1) /.301048631703895E-02/, B(2) /.538971687740286E-01/,
     *     B(3) /.375795757275549E+00/
C-------------------------
      DATA P(1)/-1.36864857382717E-07/, P(2) /5.64195517478974E-01/,
     *     P(3) /7.21175825088309E+00/, P(4) /4.31622272220567E+01/,
     *     P(5) /1.52989285046940E+02/, P(6) /3.39320816734344E+02/,
     *     P(7) /4.51918953711873E+02/, P(8) /3.00459261020162E+02/
      DATA Q(1) /1.00000000000000E+00/, Q(2) /1.27827273196294E+01/,
     *     Q(3) /7.70001529352295E+01/, Q(4) /2.77585444743988E+02/,
     *     Q(5) /6.38980264465631E+02/, Q(6) /9.31354094850610E+02/,
     *     Q(7) /7.90950925327898E+02/, Q(8) /3.00459260956983E+02/
C-------------------------
      DATA R(1) /2.10144126479064E+00/, R(2) /2.62370141675169E+01/,
     *     R(3) /2.13688200555087E+01/, R(4) /4.65807828718470E+00/,
     *     R(5) /2.82094791773523E-01/
      DATA S(1) /9.41537750555460E+01/, S(2) /1.87114811799590E+02/,
     *     S(3) /9.90191814623914E+01/, S(4) /1.80124575948747E+01/
C-------------------------
      AX = ABS(X)
      IF (AX .GT. 0.5) GO TO 10
      T = X*X
      TOP = ((((A(1)*T + A(2))*T + A(3))*T + A(4))*T + A(5)) + 1.0
      BOT = ((B(1)*T + B(2))*T + B(3))*T + 1.0
      ERF = X*(TOP/BOT)
      RETURN
C
   10 IF (AX .GT. 4.0) GO TO 20
      TOP = ((((((P(1)*AX + P(2))*AX + P(3))*AX + P(4))*AX + P(5))*AX
     *                    + P(6))*AX + P(7))*AX + P(8)
      BOT = ((((((Q(1)*AX + Q(2))*AX + Q(3))*AX + Q(4))*AX + Q(5))*AX
     *                    + Q(6))*AX + Q(7))*AX + Q(8)
      ERF = 0.5 + (0.5 - EXP(-X*X)*TOP/BOT)
      IF (X .LT. 0.0) ERF = -ERF
      RETURN
C
   20 IF (AX .GE. 5.8) GO TO 30
      X2 = X*X
      T = 1.0/X2
      TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5)
      BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + 1.0
      ERF = (C - TOP/(X2*BOT)) / AX
      ERF = 0.5 + (0.5 - EXP(-X2)*ERF)
      IF (X .LT. 0.0) ERF = -ERF
      RETURN
C
   30 ERF = SIGN(1.0,X)
      RETURN
      END
      REAL FUNCTION ERFC (X)
C-----------------------------------------------------------------------
C         EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION
C-----------------------------------------------------------------------
      REAL A(5),B(3),P(8),Q(8),R(5),S(4)
      DOUBLE PRECISION W
C-------------------------
      DATA C /.564189583547756/
C-------------------------
      DATA A(1) /.771058495001320E-04/, A(2)/-.133733772997339E-02/,
     *     A(3) /.323076579225834E-01/, A(4) /.479137145607681E-01/,
     *     A(5) /.128379167095513E+00/
      DATA B(1) /.301048631703895E-02/, B(2) /.538971687740286E-01/,
     *     B(3) /.375795757275549E+00/
C-------------------------
      DATA P(1)/-1.36864857382717E-07/, P(2) /5.64195517478974E-01/,
     *     P(3) /7.21175825088309E+00/, P(4) /4.31622272220567E+01/,
     *     P(5) /1.52989285046940E+02/, P(6) /3.39320816734344E+02/,
     *     P(7) /4.51918953711873E+02/, P(8) /3.00459261020162E+02/
      DATA Q(1) /1.00000000000000E+00/, Q(2) /1.27827273196294E+01/,
     *     Q(3) /7.70001529352295E+01/, Q(4) /2.77585444743988E+02/,
     *     Q(5) /6.38980264465631E+02/, Q(6) /9.31354094850610E+02/,
     *     Q(7) /7.90950925327898E+02/, Q(8) /3.00459260956983E+02/
C-------------------------
      DATA R(1) /2.10144126479064E+00/, R(2) /2.62370141675169E+01/,
     *     R(3) /2.13688200555087E+01/, R(4) /4.65807828718470E+00/,
     *     R(5) /2.82094791773523E-01/
      DATA S(1) /9.41537750555460E+01/, S(2) /1.87114811799590E+02/,
     *     S(3) /9.90191814623914E+01/, S(4) /1.80124575948747E+01/
C-------------------------
C
C                     ABS(X) .LE. 0.5
C
      AX = ABS(X)
      IF (AX .GT. 0.5) GO TO 10
      T = X*X
      TOP = ((((A(1)*T + A(2))*T + A(3))*T + A(4))*T + A(5)) + 1.0
      BOT = ((B(1)*T + B(2))*T + B(3))*T + 1.0
      ERFC = 0.5 + (0.5 - X*(TOP/BOT))
      RETURN
C
C                  0.5 .LT. ABS(X) .LE. 4
C
   10 IF (AX .GT. 4.0) GO TO 20
      TOP = ((((((P(1)*AX + P(2))*AX + P(3))*AX + P(4))*AX + P(5))*AX
     *                    + P(6))*AX + P(7))*AX + P(8)
      BOT = ((((((Q(1)*AX + Q(2))*AX + Q(3))*AX + Q(4))*AX + Q(5))*AX
     *                    + Q(6))*AX + Q(7))*AX + Q(8)
      ERFC = TOP/BOT
      GO TO 30
C
C                       ABS(X) .GT. 4
C
   20 IF (X .LE. -5.6) GO TO 40
      IF (X .GT. 100.0) GO TO 50
      T = X*X
      IF (T .GT. -EXPARG(1)) GO TO 50
C
      T = 1.0/T
      TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5)
      BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + 1.0
      ERFC = (C - T*TOP/BOT)/AX
C
C                      FINAL ASSEMBLY
C
   30 W = DBLE(X)*DBLE(X)
      T = W
      E = W - DBLE(T)
      ERFC = ((0.5 + (0.5 - E)) * EXP(-T)) * ERFC
      IF (X .LT. 0.0) ERFC = 2.0 - ERFC
      RETURN
C
C             LIMIT VALUE FOR LARGE NEGATIVE X
C
   40 ERFC = 2.0
      RETURN
C
C             LIMIT VALUE FOR LARGE POSITIVE X
C
   50 ERFC = 0.0
      RETURN
      END
      REAL FUNCTION ERFC1 (IND, X)
C-----------------------------------------------------------------------
C         EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION
C
C          ERFC1(IND,X) = ERFC(X)            IF IND = 0
C          ERFC1(IND,X) = EXP(X*X)*ERFC(X)   OTHERWISE
C-----------------------------------------------------------------------
      REAL A(5),B(3),P(8),Q(8),R(5),S(4)
      DOUBLE PRECISION W
C-------------------------
      DATA C /.564189583547756/
C-------------------------
      DATA A(1) /.771058495001320E-04/, A(2)/-.133733772997339E-02/,
     *     A(3) /.323076579225834E-01/, A(4) /.479137145607681E-01/,
     *     A(5) /.128379167095513E+00/
      DATA B(1) /.301048631703895E-02/, B(2) /.538971687740286E-01/,
     *     B(3) /.375795757275549E+00/
C-------------------------
      DATA P(1)/-1.36864857382717E-07/, P(2) /5.64195517478974E-01/,
     *     P(3) /7.21175825088309E+00/, P(4) /4.31622272220567E+01/,
     *     P(5) /1.52989285046940E+02/, P(6) /3.39320816734344E+02/,
     *     P(7) /4.51918953711873E+02/, P(8) /3.00459261020162E+02/
      DATA Q(1) /1.00000000000000E+00/, Q(2) /1.27827273196294E+01/,
     *     Q(3) /7.70001529352295E+01/, Q(4) /2.77585444743988E+02/,
     *     Q(5) /6.38980264465631E+02/, Q(6) /9.31354094850610E+02/,
     *     Q(7) /7.90950925327898E+02/, Q(8) /3.00459260956983E+02/
C-------------------------
      DATA R(1) /2.10144126479064E+00/, R(2) /2.62370141675169E+01/,
     *     R(3) /2.13688200555087E+01/, R(4) /4.65807828718470E+00/,
     *     R(5) /2.82094791773523E-01/
      DATA S(1) /9.41537750555460E+01/, S(2) /1.87114811799590E+02/,
     *     S(3) /9.90191814623914E+01/, S(4) /1.80124575948747E+01/
C-------------------------
C
C                     ABS(X) .LE. 0.5
C
      AX = ABS(X)
      IF (AX .GT. 0.5) GO TO 10
      T = X*X
      TOP = ((((A(1)*T + A(2))*T + A(3))*T + A(4))*T + A(5)) + 1.0
      BOT = ((B(1)*T + B(2))*T + B(3))*T + 1.0
      ERFC1 = 0.5 + (0.5 - X*(TOP/BOT))
      IF (IND .NE. 0) ERFC1 = EXP(T) * ERFC1
      RETURN
C
C                  0.5 .LT. ABS(X) .LE. 4
C
   10 IF (AX .GT. 4.0) GO TO 20
      TOP = ((((((P(1)*AX + P(2))*AX + P(3))*AX + P(4))*AX + P(5))*AX
     *                    + P(6))*AX + P(7))*AX + P(8)
      BOT = ((((((Q(1)*AX + Q(2))*AX + Q(3))*AX + Q(4))*AX + Q(5))*AX
     *                    + Q(6))*AX + Q(7))*AX + Q(8)
      ERFC1 = TOP/BOT
      GO TO 40
C
C                      ABS(X) .GT. 4
C
   20 IF (X .LE. -5.6) GO TO 50
      IF (IND .NE. 0) GO TO 30
      IF (X .GT. 100.0) GO TO 60
      IF (X*X .GT. -EXPARG(1)) GO TO 60
C
   30 T = (1.0/X)**2
      TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5)
      BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + 1.0
      ERFC1 = (C - T*TOP/BOT)/AX
C
C                      FINAL ASSEMBLY
C
   40 IF (IND .EQ. 0) GO TO 41
         IF (X .LT. 0.0) ERFC1 = 2.0*EXP(X*X) - ERFC1
         RETURN
   41 W = DBLE(X)*DBLE(X)
      T = W
      E = W - DBLE(T)
      ERFC1 = ((0.5 + (0.5 - E)) * EXP(-T)) * ERFC1
      IF (X .LT. 0.0) ERFC1 = 2.0 - ERFC1
      RETURN
C
C             LIMIT VALUE FOR LARGE NEGATIVE X
C
   50 ERFC1 = 2.0
      IF (IND .NE. 0) ERFC1 = 2.0*EXP(X*X)
      RETURN
C
C             LIMIT VALUE FOR LARGE POSITIVE X
C                       WHEN IND = 0
C
   60 ERFC1 = 0.0
      RETURN
      END
      SUBROUTINE DCERF (MO, Z, W)
C-----------------------------------------------------------------------
C
C               COMPUTATION OF THE COMPLEX ERROR FUNCTION
C
C                          -----------------
C
C                       W = ERF(Z)    IF MO = 0
C                       W = ERFC(Z)   OTHERWISE
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION Z(2), W(2)
      DOUBLE PRECISION M, N, N2, N4, NP1
      DOUBLE PRECISION C, C2, D, D2, E, EPS, R, SN, TOL, X, Y
      DOUBLE PRECISION A0(2), AN(2), B0(2), BN(2)
      DOUBLE PRECISION G0(2), GN(2), H0(2), HN(2)
      DOUBLE PRECISION QF(2), SM(2), SZ(2), TM(2), TS(2), W0(2), WN(2)
      DOUBLE PRECISION ANORM, DPMPAR
C------------------------
      ANORM(X,Y) = DMAX1(DABS(X),DABS(Y))
C------------------------
C     C = 1/SQRT(PI)
C------------------------
      DATA C /.56418958354775628694807945156077D0/
C------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0.
C
                      EPS = DPMPAR(1)
C
C------------------------
      X = Z(1)
      Y = Z(2)
      SN = 1.D0
      IF (X .GE. 0.D0) GO TO 10
         X = -X
         Y = -Y
         SN = -1.D0
C
   10 R = X*X + Y*Y
      SZ(1) = X*X - Y*Y
      SZ(2) = 2.D0*X*Y
C
      IF (R .LE. 1.D0) GO TO 20
      IF (R .GE. 144.D0) GO TO 100
      IF (DABS(Y) .GT. 31.8D0*X) GO TO 50
      IF (DABS(Y) .GT. 7.0D0*X .AND. R .LT. 64.D0) GO TO 50
      IF (DABS(Y) .GT. 3.2D0*X .AND. R .LT. 49.D0) GO TO 50
      IF (DABS(Y) .GT. 2.0D0*X .AND. R .LT. 36.D0) GO TO 50
      IF (DABS(Y) .GT. 1.2D0*X .AND. R .LT. 25.D0) GO TO 50
      IF (DABS(Y) .GT. 0.9D0*X .AND. R .LT. 16.D0) GO TO 50
      IF (R .GE. 6.25D0) GO TO 80
      IF (DABS(Y) .GT. 0.6D0*X) GO TO 50
      IF (R .GE. 4.0D0) GO TO 40
C
      D = X - 2.D0
      IF (D*D + Y*Y .LT. 1.D0) GO TO 40
      GO TO 50
C
C                          TAYLOR SERIES
C
   20 C2 = C + C
      TM(1) = C2*X
      TM(2) = C2*Y
      SM(1) = TM(1)
      SM(2) = TM(2)
      TOL = 2.D0*EPS
      M = 0.D0
   21    M = M + 1.D0
         D = M + M + 1.D0
         TS(1) = TM(1)*SZ(1) - TM(2)*SZ(2)
         TS(2) = TM(1)*SZ(2) + TM(2)*SZ(1)
         TM(1) = -TS(1)/M
         TM(2) = -TS(2)/M
         TS(1) = TM(1)/D
         TS(2) = TM(2)/D
         SM(1) = SM(1) + TS(1)
         SM(2) = SM(2) + TS(2)
         IF (ANORM(TS(1),TS(2)) .GT. TOL*ANORM(SM(1),SM(2))) GO TO 21
C
      IF (MO .NE. 0) GO TO 30
         W(1) = SN*SM(1)
         W(2) = SN*SM(2)
         RETURN
   30 IF (SN .EQ. 1.D0) GO TO 31
         W(1) = 1.D0 + SM(1)
         W(2) = SM(2)
         RETURN
   31 W(1) = 0.5D0 + (0.5D0 - SM(1))
      W(2) = -SM(2)
      RETURN
C
C                  TAYLOR SERIES AROUND Z0 = 2
C
   40 TM(1) = X
      TM(2) = Y
      CALL ERFCM2 (0, TM, W)
      IF (MO .NE. 0) GO TO 41
         W(1) = SN*(0.5D0 + (0.5D0 - W(1)))
         W(2) = - SN*W(2)
         RETURN
   41 IF (SN .GT. 0.D0) RETURN
      W(1) = 2.D0 - W(1)
      W(2) = - W(2)
      RETURN
C
C            PADE APPROXIMATION FOR THE TAYLOR SERIES
C                    FOR  (EXP(Z*Z)/Z)*ERF(Z)
C
   50 D = 4.D0
      IF (R .GT. 16.D0) D = 16.D0
      IF (R .GT. 64.D0) D = 64.D0
      D2 = D*D
      CALL DCREC (SZ(1), SZ(2), W(1), W(2))
      A0(1) = 1.D0
      A0(2) = 0.D0
      AN(1) = (W(1) + 4.D0/15.D0)*D
      AN(2) = W(2)*D
      B0(1) = 1.D0
      B0(2) = 0.D0
      BN(1) = (W(1) - 0.4D0)*D
      BN(2) = W(2)*D
      CALL CDIVID (AN(1), AN(2), BN(1), BN(2), WN(1), WN(2))
      TOL = 10.D0*EPS
      N4 = 0.D0
C
   60    N4 = N4 + 4.D0
         E = (N4 + 1.D0)*(N4 + 5.D0)
         TM(1) = D*(W(1) - 2.D0/E)
         TM(2) = D*W(2)
         E = D2*(N4*(N4 + 2.0))/((N4 - 1.0)*(N4 + 3.0)*(N4 + 1.0)**2)
C
         QF(1) = (TM(1)*AN(1) - TM(2)*AN(2)) + E*A0(1)
         QF(2) = (TM(1)*AN(2) + TM(2)*AN(1)) + E*A0(2)
         A0(1) = AN(1)
         A0(2) = AN(2)
         AN(1) = QF(1)
         AN(2) = QF(2)
         QF(1) = (TM(1)*BN(1) - TM(2)*BN(2)) + E*B0(1)
         QF(2) = (TM(1)*BN(2) + TM(2)*BN(1)) + E*B0(2)
         B0(1) = BN(1)
         B0(2) = BN(2)
         BN(1) = QF(1)
         BN(2) = QF(2)
C
         W0(1) = WN(1)
         W0(2) = WN(2)
         CALL CDIVID (AN(1), AN(2), BN(1), BN(2), WN(1), WN(2))
         IF (ANORM(WN(1) - W0(1), WN(2) - W0(2)) .GT.
     *          TOL*ANORM(WN(1), WN(2))) GO TO 60
C
      C2 = C + C
      SM(1) = C2*(X*WN(1) - Y*WN(2))
      SM(2) = C2*(X*WN(2) + Y*WN(1))
      E = DEXP(-SZ(1))
      QF(1) = E*DCOS(-SZ(2))
      QF(2) = E*DSIN(-SZ(2))
      TM(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TM(2) = QF(1)*SM(2) + QF(2)*SM(1)
C
      W(1) = SN*TM(1)
      W(2) = SN*TM(2)
      IF (MO .EQ. 0) RETURN
      W(1) = 1.D0 - W(1)
      W(2) = - W(2)
      RETURN
C
C         PADE APPROXIMATION FOR THE ASYMPTOTIC EXPANSION
C                    FOR  Z*EXP(Z*Z)*ERFC(Z)
C
   80 D = 4.D0*R
      IF (R .LT. 16.D0) D = 16.D0*R
      D2 = D*D
      TM(1) = SZ(1) + SZ(1)
      TM(2) = SZ(2) + SZ(2)
      G0(1) = 1.D0
      G0(2) = 0.D0
      GN(1) = (2.D0 + TM(1))/D
      GN(2) = TM(2)/D
      H0(1) = 1.D0
      H0(2) = 0.D0
      TM(1) = 3.D0 + TM(1)
      HN(1) = TM(1)/D
      HN(2) = TM(2)/D
      CALL CDIVID (GN(1), GN(2), HN(1), HN(2), WN(1), WN(2))
      NP1 = 1.D0
      TOL = 10.D0*EPS
C
   90    N = NP1
         NP1 = N + 1.D0
         N2 = N + N
         E = (N2*(N2 + 1.D0))/D2
         TM(1) = TM(1) + 4.D0
         QF(1) = (TM(1)*GN(1) - TM(2)*GN(2))/D - E*G0(1)
         QF(2) = (TM(1)*GN(2) + TM(2)*GN(1))/D - E*G0(2)
         G0(1) = GN(1)
         G0(2) = GN(2)
         GN(1) = QF(1)
         GN(2) = QF(2)
         QF(1) = (TM(1)*HN(1) - TM(2)*HN(2))/D - E*H0(1)
         QF(2) = (TM(1)*HN(2) + TM(2)*HN(1))/D - E*H0(2)
         H0(1) = HN(1)
         H0(2) = HN(2)
         HN(1) = QF(1)
         HN(2) = QF(2)
C
         W0(1) = WN(1)
         W0(2) = WN(2)
         CALL CDIVID (GN(1), GN(2), HN(1), HN(2), WN(1), WN(2))
         IF (ANORM(WN(1) - W0(1), WN(2) - W0(2)) .GT.
     *          TOL*ANORM(WN(1), WN(2))) GO TO 90
C
      TM(1) = X*HN(1) - Y*HN(2)
      TM(2) = X*HN(2) + Y*HN(1)
      CALL CDIVID (C*GN(1), C*GN(2), TM(1), TM(2), SM(1), SM(2))
      GO TO 130
C
C                      ASYMPTOTIC EXPANSION
C
  100 CALL DCREC (X, Y, TM(1), TM(2))
      SM(1) = TM(1)
      SM(2) = TM(2)
      QF(1) = TM(1)*TM(1) - TM(2)*TM(2)
      QF(2) = 2.D0*TM(1)*TM(2)
      TOL = 2.D0*EPS
      D = -0.5D0
  110    D = D + 1.D0
         TS(1) = TM(1)*QF(1) - TM(2)*QF(2)
         TS(2) = TM(1)*QF(2) + TM(2)*QF(1)
         TM(1) = -D*TS(1)
         TM(2) = -D*TS(2)
         SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
         IF (ANORM(TM(1),TM(2)) .GT. TOL*ANORM(SM(1),SM(2))) GO TO 110
      SM(1) = C*SM(1)
      SM(2) = C*SM(2)
      IF (X .LT. 1.D-2) GO TO 200
C
C                       TERMINATION
C
  130 E = DEXP(-SZ(1))
      QF(1) = E*DCOS(-SZ(2))
      QF(2) = E*DSIN(-SZ(2))
      TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      SM(1) = TS(1)
      SM(2) = TS(2)
C
      IF (MO .NE. 0) GO TO 140
         W(1) = SN*(0.5D0 + (0.5D0 - SM(1)))
         W(2) = - SN*SM(2)
         RETURN
  140 IF (SN .EQ. 1.D0) GO TO 141
         W(1) = 2.D0 - SM(1)
         W(2) = -SM(2)
         RETURN
  141 W(1) = SM(1)
      W(2) = SM(2)
      RETURN
C
C               MODIFIED ASYMPTOTIC EXPANSION
C
  200 E = DEXP(-SZ(1))
      QF(1) = E*DCOS(-SZ(2))
      QF(2) = E*DSIN(-SZ(2))
      W(1) = QF(1)*SM(1) - QF(2)*SM(2)
      W(2) = QF(1)*SM(2) + QF(2)*SM(1)
      IF (MO .EQ. 0) GO TO 210
         W(1) = 1.D0 + SN*W(1)
         W(2) = SN*W(2)
         RETURN
  210 IF (SN .LT. 0.0) RETURN
      W(1) = - W(1)
      W(2) = - W(2)
      RETURN
      END
      SUBROUTINE DCERFC (MO, Z, W)
C-----------------------------------------------------------------------
C
C              COMPUTATION OF THE COMPLEX COERROR FUNCTION
C
C                           ----------------
C
C           W = ERFC(Z)           IF MO = 0 OR REAL(Z) .LT. 0
C           W = DEXP(X*X)*ERFC(Z)  OTHERWISE
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION Z(2), W(2)
      DOUBLE PRECISION M, N, N2, N4, NP1
      DOUBLE PRECISION C, C2, D, D2, E, EPS, R, SN, TOL, X, Y
      DOUBLE PRECISION A0(2), AN(2), B0(2), BN(2)
      DOUBLE PRECISION G0(2), GN(2), H0(2), HN(2)
      DOUBLE PRECISION QF(2), SM(2), SZ(2), TM(2), TS(2), W0(2), WN(2)
      DOUBLE PRECISION ANORM, DPMPAR, DXPARG
C------------------------
      ANORM(X,Y) = DMAX1(DABS(X),DABS(Y))
C------------------------
C     C = 1/SQRT(PI)
C------------------------
      DATA C /.56418958354775628694807945156077D0/
C------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0.
C
                      EPS = DPMPAR(1)
C
C------------------------
      X = Z(1)
      Y = Z(2)
      SN = 1.D0
      IF (X .GE. 0.D0) GO TO 10
         X = -X
         Y = -Y
         SN = -1.D0
C
   10 IF (MO .NE. 0  .AND.  SN .EQ. 1.D0  .AND.
     *   DMAX1(X, DABS(Y)) .GE. 144.D0) GO TO 100
      R = X*X + Y*Y
      SZ(1) = X*X - Y*Y
      SZ(2) = 2.D0*X*Y
C
      IF (R .LE. 1.D0) GO TO 20
      IF (R .GE. 144.D0) GO TO 100
      IF (DABS(Y) .GT. 31.8D0*X) GO TO 50
      IF (DABS(Y) .GT. 7.0D0*X .AND. R .LT. 64.D0) GO TO 50
      IF (DABS(Y) .GT. 3.2D0*X .AND. R .LT. 49.D0) GO TO 50
      IF (DABS(Y) .GT. 2.0D0*X .AND. R .LT. 36.D0) GO TO 50
      IF (DABS(Y) .GT. 1.2D0*X .AND. R .LT. 25.D0) GO TO 50
      IF (DABS(Y) .GT. 0.9D0*X .AND. R .LT. 16.D0) GO TO 50
      IF (R .GE. 6.25D0) GO TO 80
      IF (DABS(Y) .GT. 0.6D0*X) GO TO 50
      IF (R .GE. 4.0D0) GO TO 40
C
      D = X - 2.D0
      IF (D*D + Y*Y .LT. 1.D0) GO TO 40
      GO TO 50
C
C                          TAYLOR SERIES
C
   20 C2 = C + C
      TM(1) = C2*X
      TM(2) = C2*Y
      SM(1) = TM(1)
      SM(2) = TM(2)
      TOL = 2.D0*EPS
      M = 0.D0
   21    M = M + 1.D0
         D = M + M + 1.D0
         TS(1) = TM(1)*SZ(1) - TM(2)*SZ(2)
         TS(2) = TM(1)*SZ(2) + TM(2)*SZ(1)
         TM(1) = -TS(1)/M
         TM(2) = -TS(2)/M
         TS(1) = TM(1)/D
         TS(2) = TM(2)/D
         SM(1) = SM(1) + TS(1)
         SM(2) = SM(2) + TS(2)
         IF (ANORM(TS(1),TS(2)) .GT. TOL*ANORM(SM(1),SM(2))) GO TO 21
C
      IF (SN .EQ. 1.D0) GO TO 30
         W(1) = 1.D0 + SM(1)
         W(2) = SM(2)
         RETURN
   30 SM(1) = 0.5D0 + (0.5D0 - SM(1))
      SM(2) = -SM(2)
      IF (MO .EQ. 0) GO TO 140
C
      E = DEXP(SZ(1))
      QF(1) = E*DCOS(SZ(2))
      QF(2) = E*DSIN(SZ(2))
      W(1) = QF(1)*SM(1) - QF(2)*SM(2)
      W(2) = QF(1)*SM(2) + QF(2)*SM(1)
      RETURN
C
C                  TAYLOR SERIES AROUND Z0 = 2
C
   40 IF (SN .LT. 0.D0) GO TO 41
         CALL ERFCM2 (MO, Z, W)
         RETURN
   41 TM(1) = X
      TM(2) = Y
      CALL ERFCM2 (0, TM, W)
      W(1) = 2.D0 - W(1)
      W(2) = - W(2)
      RETURN
C
C            PADE APPROXIMATION FOR THE TAYLOR SERIES
C                    FOR  (EXP(Z*Z)/Z)*ERF(Z)
C
   50 D = 4.D0
      IF (R .GT. 16.D0) D = 16.D0
      IF (R .GT. 64.D0) D = 64.D0
      D2 = D*D
      CALL DCREC (SZ(1), SZ(2), W(1), W(2))
      A0(1) = 1.D0
      A0(2) = 0.D0
      AN(1) = (W(1) + 4.D0/15.D0)*D
      AN(2) = W(2)*D
      B0(1) = 1.D0
      B0(2) = 0.D0
      BN(1) = (W(1) - 0.4D0)*D
      BN(2) = W(2)*D
      CALL CDIVID (AN(1), AN(2), BN(1), BN(2), WN(1), WN(2))
      TOL = 10.D0*EPS
      N4 = 0.D0
C
   60    N4 = N4 + 4.D0
         E = (N4 + 1.D0)*(N4 + 5.D0)
         TM(1) = D*(W(1) - 2.D0/E)
         TM(2) = D*W(2)
         E = D2*(N4*(N4 + 2.0))/((N4 - 1.0)*(N4 + 3.0)*(N4 + 1.0)**2)
C
         QF(1) = (TM(1)*AN(1) - TM(2)*AN(2)) + E*A0(1)
         QF(2) = (TM(1)*AN(2) + TM(2)*AN(1)) + E*A0(2)
         A0(1) = AN(1)
         A0(2) = AN(2)
         AN(1) = QF(1)
         AN(2) = QF(2)
         QF(1) = (TM(1)*BN(1) - TM(2)*BN(2)) + E*B0(1)
         QF(2) = (TM(1)*BN(2) + TM(2)*BN(1)) + E*B0(2)
         B0(1) = BN(1)
         B0(2) = BN(2)
         BN(1) = QF(1)
         BN(2) = QF(2)
C
         W0(1) = WN(1)
         W0(2) = WN(2)
         CALL CDIVID (AN(1), AN(2), BN(1), BN(2), WN(1), WN(2))
         IF (ANORM(WN(1) - W0(1), WN(2) - W0(2)) .GT.
     *          TOL*ANORM(WN(1), WN(2))) GO TO 60
C
      C2 = C + C
      SM(1) = C2*(X*WN(1) - Y*WN(2))
      SM(2) = C2*(X*WN(2) + Y*WN(1))
C
      IF (MO .EQ. 0 .OR. SN .NE. 1.D0) GO TO 70
         E = DEXP(SZ(1))
         W(1) = E*DCOS(SZ(2)) - SM(1)
         W(2) = E*DSIN(SZ(2)) - SM(2)
         RETURN
   70 E = DEXP(-SZ(1))
      QF(1) = E*DCOS(-SZ(2))
      QF(2) = E*DSIN(-SZ(2))
      TM(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TM(2) = QF(1)*SM(2) + QF(2)*SM(1)
      W(1) = 1.D0 - SN*TM(1)
      W(2) = - SN*TM(2)
      RETURN
C
C         PADE APPROXIMATION FOR THE ASYMPTOTIC EXPANSION
C                    FOR  Z*EXP(Z*Z)*ERFC(Z)
C
   80 D = 4.D0*R
      IF (R .LT. 16.D0) D = 16.D0*R
      D2 = D*D
      TM(1) = SZ(1) + SZ(1)
      TM(2) = SZ(2) + SZ(2)
      G0(1) = 1.D0
      G0(2) = 0.D0
      GN(1) = (2.D0 + TM(1))/D
      GN(2) = TM(2)/D
      H0(1) = 1.D0
      H0(2) = 0.D0
      TM(1) = 3.D0 + TM(1)
      HN(1) = TM(1)/D
      HN(2) = TM(2)/D
      CALL CDIVID (GN(1), GN(2), HN(1), HN(2), WN(1), WN(2))
      NP1 = 1.D0
      TOL = 10.D0*EPS
C
   90    N = NP1
         NP1 = N + 1.D0
         N2 = N + N
         E = (N2*(N2 + 1.D0))/D2
         TM(1) = TM(1) + 4.D0
         QF(1) = (TM(1)*GN(1) - TM(2)*GN(2))/D - E*G0(1)
         QF(2) = (TM(1)*GN(2) + TM(2)*GN(1))/D - E*G0(2)
         G0(1) = GN(1)
         G0(2) = GN(2)
         GN(1) = QF(1)
         GN(2) = QF(2)
         QF(1) = (TM(1)*HN(1) - TM(2)*HN(2))/D - E*H0(1)
         QF(2) = (TM(1)*HN(2) + TM(2)*HN(1))/D - E*H0(2)
         H0(1) = HN(1)
         H0(2) = HN(2)
         HN(1) = QF(1)
         HN(2) = QF(2)
C
         W0(1) = WN(1)
         W0(2) = WN(2)
         CALL CDIVID (GN(1), GN(2), HN(1), HN(2), WN(1), WN(2))
         IF (ANORM(WN(1) - W0(1), WN(2) - W0(2)) .GT.
     *          TOL*ANORM(WN(1), WN(2))) GO TO 90
C
      TM(1) = X*HN(1) - Y*HN(2)
      TM(2) = X*HN(2) + Y*HN(1)
      CALL CDIVID (C*GN(1), C*GN(2), TM(1), TM(2), SM(1), SM(2))
      GO TO 130
C
C                      ASYMPTOTIC EXPANSION
C
  100 CALL DCREC (X, Y, TM(1), TM(2))
      SM(1) = TM(1)
      SM(2) = TM(2)
      QF(1) = TM(1)*TM(1) - TM(2)*TM(2)
      QF(2) = 2.D0*TM(1)*TM(2)
      TOL = 2.D0*EPS
      D = -0.5D0
  110    D = D + 1.D0
         TS(1) = TM(1)*QF(1) - TM(2)*QF(2)
         TS(2) = TM(1)*QF(2) + TM(2)*QF(1)
         TM(1) = -D*TS(1)
         TM(2) = -D*TS(2)
         SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
         IF (ANORM(TM(1),TM(2)) .GT. TOL*ANORM(SM(1),SM(2))) GO TO 110
      SM(1) = C*SM(1)
      SM(2) = C*SM(2)
      IF (X .LT. 1.D-2) GO TO 200
C
C                       TERMINATION
C
  130 IF (MO .NE. 0 .AND. SN .EQ. 1.D0) GO TO 140
      E = DEXP(-SZ(1))
      QF(1) = E*DCOS(-SZ(2))
      QF(2) = E*DSIN(-SZ(2))
      TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      SM(1) = TS(1)
      SM(2) = TS(2)
C
      IF (SN .EQ. 1.D0) GO TO 140
         W(1) = 2.D0 - SM(1)
         W(2) = -SM(2)
         RETURN
  140 W(1) = SM(1)
      W(2) = SM(2)
      RETURN
C
C               MODIFIED ASYMPTOTIC EXPANSION
C
  200 IF (MO .NE. 0 .AND. SN .EQ. 1.D0) GO TO 210
      E = DEXP(-SZ(1))
      QF(1) = E*DCOS(-SZ(2))
      QF(2) = E*DSIN(-SZ(2))
      TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      W(1) = 1.D0 + SN*TS(1)
      W(2) = SN*TS(2)
      RETURN
C
  210 IF (DABS(Y) .GE. 100.D0) GO TO 140
      IF (SZ(1) .LE. DXPARG(1)) GO TO 140
      E = DEXP(SZ(1))
      W(1) = E*DCOS(SZ(2)) + SM(1)
      W(2) = E*DSIN(SZ(2)) + SM(2)
      RETURN
      END
      SUBROUTINE ERFCM2 (MO, Z, W)
C-----------------------------------------------------------------------
C           CALCULATION OF ERFC(Z) USING THE TAYLOR SERIES
C                          AROUND Z0 = 2
C-----------------------------------------------------------------------
      DOUBLE PRECISION Z(2), W(2)
      DOUBLE PRECISION A(63), C, E, EPS, H(2), T(2), TOL, X, Y
      DOUBLE PRECISION ANORM, DPMPAR
C------------------------------
      ANORM(X,Y) = DMAX1(DABS(X),DABS(Y))
C------------------------------
C     C = (2/SQRT(PI))*EXP(-4)
C     E = ERFC(2)
C------------------------------
      DATA C /.20666985354092053857068941306585476D-01/
      DATA E /.46777349810472658379307436327470714D-02/
C------------------------------
      DATA A(1)  / .20000000000000000000000000000000000D+01/,
     *     A(2)  / .23333333333333333333333333333333333D+01/,
     *     A(3)  / .16666666666666666666666666666666667D+01/,
     *     A(4)  / .63333333333333333333333333333333333D+00/,
     *     A(5)  /-.22222222222222222222222222222222222D-01/,
     *     A(6)  /-.16349206349206349206349206349206349D+00/,
     *     A(7)  /-.76984126984126984126984126984126984D-01/,
     *     A(8)  /-.24250440917107583774250440917107584D-02/,
     *     A(9)  / .12716049382716049382716049382716049D-01/,
     *     A(10) / .50208433541766875100208433541766875D-02/
      DATA A(11) /-.25305969750414194858639303083747528D-03/,
     *     A(12) /-.78593217482106370995259884148773038D-03/,
     *     A(13) /-.19118154038788959423880058800693721D-03/,
     *     A(14) / .46324144207742091339974937858535742D-04/,
     *     A(15) / .33885549097189308829520469732109944D-04/,
     *     A(16) / .28637897646612243562134629672756034D-05/,
     *     A(17) /-.29071891082127275370004560446169188D-05/,
     *     A(18) /-.89674405786490646425523560263096103D-06/,
     *     A(19) / .96069103941908684338469767911200105D-07/,
     *     A(20) / .99432863129093191401848891268744113D-07/
      DATA A(21) / .97610310501460621303387795457283579D-08/,
     *     A(22) /-.65557500375673133822289344530892436D-08/,
     *     A(23) /-.18706782059105426900361744016236561D-08/,
     *     A(24) / .20329898993447386223176373714372370D-09/,
     *     A(25) / .16941915827254374668448114614201210D-09/,
     *     A(26) / .10619149520827430973786114446699534D-10/,
     *     A(27) /-.10136148256511788733365237088810952D-10/,
     *     A(28) /-.21042890133669970575386166675721692D-11/,
     *     A(29) / .37186985840699828780916522245407087D-12/,
     *     A(30) / .17921843632701679986488128324051002D-12/
      DATA A(31) /-.89823991804248069863542565948598397D-16/,
     *     A(32) /-.10533182313660970970232171410372199D-13/,
     *     A(33) /-.12340742690978398320850088252659714D-14/,
     *     A(34) / .44315624546581333350568244777175883D-15/,
     *     A(35) / .11584041639989442481950487524296214D-15/,
     *     A(36) /-.10765703619385988116658460442219647D-16/,
     *     A(37) /-.70653158723054941879586082239984222D-17/,
     *     A(38) /-.18708903154917138727191793341667090D-18/,
     *     A(39) / .32549879318817103966053527398133297D-18/,
     *     A(40) / .40654116689599228385911733319215613D-19/
      DATA A(41) /-.11250074516817311101947327325293424D-19/,
     *     A(42) /-.28923865378584966737386008432031980D-20/,
     *     A(43) / .23653053641701517160704870522922706D-21/,
     *     A(44) / .14665384680061888088099002254334292D-21/,
     *     A(45) / .26971039707314316218154193225264469D-23/,
     *     A(46) /-.58753834789274356433279671015522650D-23/,
     *     A(47) /-.59960357240498652932299485494869633D-24/,
     *     A(48) / .18586826578121663981412155416486531D-24/,
     *     A(49) / .38364131854692721721867481914852428D-25/,
     *     A(50) /-.41342210492630142578080062451711039D-26/
      DATA A(51) /-.17646283105274988992381528904600860D-26/,
     *     A(52) / .19828685934364181151988692232131608D-28/,
     *     A(53) / .65592252170840353572672782446212733D-28/,
     *     A(54) / .40626551379996340638338449938639730D-29/,
     *     A(55) /-.20097984104191034713653294173834095D-29/,
     *     A(56) /-.28104226475997460044096389060743131D-30/,
     *     A(57) / .48705319298749358709127987806547949D-31/,
     *     A(58) / .12664655832830787747161769929972617D-31/,
     *     A(59) /-.75168312488894341862391776330113688D-33/,
     *     A(60) /-.45760473722605993842481669806804415D-33/
      DATA A(61) /-.56725491529575395930156379514718000D-35/,
     *     A(62) / .13932664042920082608489441616061541D-34/,
     *     A(63) / .10452448992516358449586503951463322D-35/
C------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0
C
             EPS = DPMPAR(1)
C
C------------------------------
      TOL = EPS*1.D+12
      H(1) = 1.D0 + (1.D0 - Z(1))
      H(2) = - Z(2)
C
      X = 1.D0
      Y = 0.D0
      W(1) = A(30)
      W(2) = 0.D0
      DO 10 N = 31,63
         T(1) = X*H(1) - Y*H(2)
         T(2) = X*H(2) + Y*H(1)
         X = T(1)
         Y = T(2)
         T(1) = A(N)*X
         T(2) = A(N)*Y
         W(1) = W(1) + T(1)
         W(2) = W(2) + T(2)
         IF (ANORM(T(1),T(2)) .LE. TOL*ANORM(W(1),W(2))) GO TO 20
   10 CONTINUE
C
   20 DO 21 J = 1,29
         N = 30 - J
         X = H(1)*W(1) - H(2)*W(2)
         W(2) = H(1)*W(2) + H(2)*W(1)
         W(1) = A(N) + X
   21 CONTINUE
      X = H(1)*W(1) - H(2)*W(2)
      W(2) = H(1)*W(2) + H(2)*W(1)
      W(1) = 1.D0 + X
C
      X = C*(H(1)*W(1) - H(2)*W(2))
      W(2) = C*(H(1)*W(2) + H(2)*W(1))
      W(1) = E + X
      IF (MO .EQ. 0) RETURN
C
C                     COMPUTE EXP(Z*Z)*ERFC(Z)
C
      X = Z(1)*Z(1) - Z(2)*Z(2)
      Y = 2.D0*Z(1)*Z(2)
      X = DEXP(X)
      T(1) = X*DCOS(Y)
      T(2) = X*DSIN(Y)
      X = T(1)*W(1) - T(2)*W(2)
      Y = T(1)*W(2) + T(2)*W(1)
      W(1) = X
      W(2) = Y
      RETURN
      END
      DOUBLE PRECISION FUNCTION DERF (X)
C-----------------------------------------------------------------------
C        DOUBLE PRECISION EVALUATION OF THE ERROR FUNCTION
C-----------------------------------------------------------------------
      DOUBLE PRECISION AX, T, X, W
      DOUBLE PRECISION A(21)
      DOUBLE PRECISION DERFC0
C-------------------------------
      DATA A(1)  / .1283791670955125738961589031215D+00/,
     *     A(2)  /-.3761263890318375246320529677070D+00/,
     *     A(3)  / .1128379167095512573896158902931D+00/,
     *     A(4)  /-.2686617064513125175943235372542D-01/,
     *     A(5)  / .5223977625442187842111812447877D-02/,
     *     A(6)  /-.8548327023450852832540164081187D-03/,
     *     A(7)  / .1205533298178966425020717182498D-03/,
     *     A(8)  /-.1492565035840625090430728526820D-04/,
     *     A(9)  / .1646211436588924261080723578109D-05/,
     *     A(10) /-.1636584469123468757408968429674D-06/
      DATA A(11) / .1480719281587021715400818627811D-07/,
     *     A(12) /-.1229055530145120140800510155331D-08/,
     *     A(13) / .9422759058437197017313055084212D-10/,
     *     A(14) /-.6711366740969385085896257227159D-11/,
     *     A(15) / .4463222608295664017461758843550D-12/,
     *     A(16) /-.2783497395542995487275065856998D-13/,
     *     A(17) / .1634095572365337143933023780777D-14/,
     *     A(18) /-.9052845786901123985710019387938D-16/,
     *     A(19) / .4708274559689744439341671426731D-17/,
     *     A(20) /-.2187159356685015949749948252160D-18/,
     *     A(21) / .7043407712019701609635599701333D-20/
C-------------------------------
C
C                     DABS(X) .LE. 1
C
      AX = DABS(X)
      IF (AX .GT. 1.D0) GO TO 20
      T = X*X
      W = A(21)
      DO 10 I = 1,20
         K = 21 - I
         W = T*W + A(K)
   10 CONTINUE
      DERF = X*(1.D0 + W)
      RETURN
C
C                     DABS(X) .GT. 1
C
   20 IF (AX .GE. 8.5D0) GO TO 30
      DERF = 0.5D0 + (0.5D0 - DEXP(-X*X)*DERFC0(AX))
      IF (X .LT. 0.D0) DERF = -DERF
      RETURN
C
C                 LIMIT VALUE FOR LARGE X
C
   30 DERF = DSIGN(1.D0,X)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DERFC (X)
C-----------------------------------------------------------------------
C         EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, AX, T, W
      DOUBLE PRECISION A(21)
      DOUBLE PRECISION DERFC0, DXPARG
C-------------------------------
      DATA A(1)  / .1283791670955125738961589031215D+00/,
     *     A(2)  /-.3761263890318375246320529677070D+00/,
     *     A(3)  / .1128379167095512573896158902931D+00/,
     *     A(4)  /-.2686617064513125175943235372542D-01/,
     *     A(5)  / .5223977625442187842111812447877D-02/,
     *     A(6)  /-.8548327023450852832540164081187D-03/,
     *     A(7)  / .1205533298178966425020717182498D-03/,
     *     A(8)  /-.1492565035840625090430728526820D-04/,
     *     A(9)  / .1646211436588924261080723578109D-05/,
     *     A(10) /-.1636584469123468757408968429674D-06/
      DATA A(11) / .1480719281587021715400818627811D-07/,
     *     A(12) /-.1229055530145120140800510155331D-08/,
     *     A(13) / .9422759058437197017313055084212D-10/,
     *     A(14) /-.6711366740969385085896257227159D-11/,
     *     A(15) / .4463222608295664017461758843550D-12/,
     *     A(16) /-.2783497395542995487275065856998D-13/,
     *     A(17) / .1634095572365337143933023780777D-14/,
     *     A(18) /-.9052845786901123985710019387938D-16/,
     *     A(19) / .4708274559689744439341671426731D-17/,
     *     A(20) /-.2187159356685015949749948252160D-18/,
     *     A(21) / .7043407712019701609635599701333D-20/
C-------------------------------
C
C                     DABS(X) .LE. 1
C
      AX = DABS(X)
      IF (AX .GT. 1.D0) GO TO 20
      T = X*X
      W = A(21)
      DO 10 I = 1,20
         K = 21 - I
         W = T*W + A(K)
   10 CONTINUE
      DERFC = 0.5D0 + (0.5D0 - X*(1.D0 + W))
      RETURN
C
C                       X .LT. -1
C
   20 IF (X .GT. 0.D0) GO TO 30
      DERFC = 2.D0
      IF (X .LT. -8.3D0) RETURN
      T = X*X
      DERFC = 2.D0 - DEXP(-T) * DERFC0(AX)
      RETURN
C
C                       X .GT. 1
C
   30 DERFC = 0.D0
      IF (X .GT. 100.D0) RETURN
      T = X*X
      IF (T .GT. -DXPARG(1)) RETURN
      DERFC = DEXP(-T) * DERFC0(X)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DERFC1 (IND, X)
C-----------------------------------------------------------------------
C
C         EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION
C
C          DERFC1(IND,X) = ERFC(X)           IF IND = 0
C          DERFC1(IND,X) = EXP(X*X)*ERFC(X)  OTHERWISE
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, AX, T, W
      DOUBLE PRECISION A(21)
      DOUBLE PRECISION DERFC0, DXPARG
C-------------------------------
      DATA A(1)  / .1283791670955125738961589031215D+00/,
     *     A(2)  /-.3761263890318375246320529677070D+00/,
     *     A(3)  / .1128379167095512573896158902931D+00/,
     *     A(4)  /-.2686617064513125175943235372542D-01/,
     *     A(5)  / .5223977625442187842111812447877D-02/,
     *     A(6)  /-.8548327023450852832540164081187D-03/,
     *     A(7)  / .1205533298178966425020717182498D-03/,
     *     A(8)  /-.1492565035840625090430728526820D-04/,
     *     A(9)  / .1646211436588924261080723578109D-05/,
     *     A(10) /-.1636584469123468757408968429674D-06/
      DATA A(11) / .1480719281587021715400818627811D-07/,
     *     A(12) /-.1229055530145120140800510155331D-08/,
     *     A(13) / .9422759058437197017313055084212D-10/,
     *     A(14) /-.6711366740969385085896257227159D-11/,
     *     A(15) / .4463222608295664017461758843550D-12/,
     *     A(16) /-.2783497395542995487275065856998D-13/,
     *     A(17) / .1634095572365337143933023780777D-14/,
     *     A(18) /-.9052845786901123985710019387938D-16/,
     *     A(19) / .4708274559689744439341671426731D-17/,
     *     A(20) /-.2187159356685015949749948252160D-18/,
     *     A(21) / .7043407712019701609635599701333D-20/
C-------------------------------
C
C                     DABS(X) .LE. 1
C
      AX = DABS(X)
      IF (AX .GT. 1.D0) GO TO 20
      T = X*X
      W = A(21)
      DO 10 I = 1,20
         K = 21 - I
         W = T*W + A(K)
   10 CONTINUE
      DERFC1 = 0.5D0 + (0.5D0 - X*(1.D0 + W))
      IF (IND .NE. 0) DERFC1 = DEXP(T) * DERFC1
      RETURN
C
C                       X .LT. -1
C
   20 IF (X .GT. 0.D0) GO TO 50
      IF (X .LT. -8.3D0) GO TO 80
      IF (IND .EQ. 0) GO TO 30
         DERFC1 = 2.D0*DEXP(X*X) - DERFC0(AX)
         RETURN
   30 DERFC1 = 2.D0 - DEXP(-X*X)*DERFC0(AX)
      RETURN
C
C                       X .GT. 1
C
   50 IF (IND .EQ. 0) GO TO 60
         DERFC1 = DERFC0(X)
         RETURN
   60 DERFC1 = 0.D0
      IF (X .GT. 100.D0) RETURN
      T = X*X
      IF (T .GT. -DXPARG(1)) RETURN
      DERFC1 = DEXP(-T) * DERFC0(X)
      RETURN
C
C             LIMIT VALUE FOR LARGE NEGATIVE X
C
   80 DERFC1 = 2.D0
      IF (IND .NE. 0) DERFC1 = 2.D0*DEXP(X*X)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DERFC0 (X)
C-----------------------------------------------------------------------
C
C           EVALUATION OF EXP(X**2)*ERFC(X) FOR X .GE. 1
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C        APRIL 1992
C-------------------------------
      DOUBLE PRECISION X, T, U, V, Z, RPINV
      DOUBLE PRECISION P0, P1, P2, P3, P4, P5, P6, P7,
     *                 Q1, Q2, Q3, Q4, Q5, Q6, Q7
      DOUBLE PRECISION R0, R1, R2, R3, R4, R5, R6, R7, R8
      DOUBLE PRECISION A0, A1, A2, A3, A4, A5, A6, A7, A8,
     *                 B1, B2, B3, B4, B5, B6, B7, B8, B9,
     *                 B10, B11
      DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8,
     *                 D1, D2, D3, D4, D5, D6, D7, D8, D9
      DOUBLE PRECISION E0, E1, E2, E3
      DOUBLE PRECISION S1, S2, S3, S4, S5, S6, S7, S8, S9,
     *                 S10, S11
C-------------------------------
C     RPINV = 1/SQRT(PI)
C-------------------------------
      DATA RPINV /.56418958354775628694807945156077259D0/
C-------------------------------
      DATA P0 / .16506148041280876191828601D-03/,
     *     P1 / .15471455377139313353998665D-03/,
     *     P2 / .44852548090298868465196794D-04/,
     *     P3 /-.49177280017226285450486205D-05/,
     *     P4 /-.69353602078656412367801676D-05/,
     *     P5 /-.20508667787746282746857743D-05/,
     *     P6 /-.28982842617824971177267380D-06/,
     *     P7 /-.17272433544836633301127174D-07/
      DATA Q1  /.16272656776533322859856317D+01/,
     *     Q2  /.12040996037066026106794322D+01/,
     *     Q3  /.52400246352158386907601472D+00/,
     *     Q4  /.14497345252798672362384241D+00/,
     *     Q5  /.25592517111042546492590736D-01/,
     *     Q6  /.26869088293991371028123158D-02/,
     *     Q7  /.13133767840925681614496481D-03/
C-------------------------------
      DATA R0  / .145589721275038539045668824025D+00/,
     *     R1  /-.273421931495426482902320421863D+00/,
     *     R2  / .226008066916621506788789064272D+00/,
     *     R3  /-.163571895523923805648814425592D+00/,
     *     R4  / .102604312032193978662297299832D+00/,
     *     R5  /-.548023266949835519254211506880D-01/,
     *     R6  / .241432239725390106956523668160D-01/,
     *     R7  /-.822062115403915116036874169600D-02/,
     *     R8  / .180296241564687154310619200000D-02/
C-------------------------------
      DATA A0 /-.45894433406309678202825375D-03/,
     *     A1 /-.12281298722544724287816236D-01/,
     *     A2 /-.91144359512342900801764781D-01/,
     *     A3 /-.28412489223839285652511367D-01/,
     *     A4 / .14083827189977123530129812D+01/,
     *     A5 / .11532175281537044570477189D+01/,
     *     A6 /-.72170903389442152112483632D+01/,
     *     A7 /-.19685597805218214001309225D+01/,
     *     A8 / .93846891504541841150916038D+01/
      DATA B1 / .25136329960926527692263725D+02/,
     *     B2 / .15349442087145759184067981D+03/,
     *     B3 /-.29971215958498680905476402D+03/,
     *     B4 /-.33876477506888115226730368D+04/,
     *     B5 / .28301829314924804988873701D+04/,
     *     B6 / .22979620942196507068034887D+05/,
     *     B7 /-.24280681522998071562462041D+05/,
     *     B8 /-.36680620673264731899504580D+05/,
     *     B9 / .42278731622295627627042436D+05/,
     *     B10/ .28834257644413614344549790D+03/,
     *     B11/ .70226293775648358646587341D+03/
C-------------------------------
      DATA C0 /-.7040906288250128001000086D-04/,
     *     C1 /-.3858822461760510359506941D-02/,
     *     C2 /-.7708202127512212359395078D-01/,
     *     C3 /-.6713655014557429480440263D+00/,
     *     C4 /-.2081992124162995545731882D+01/,
     *     C5 / .2898831421475282558867888D+01/,
     *     C6 / .2199509380600429331650192D+02/,
     *     C7 / .2907064664404115316722996D+01/,
     *     C8 /-.4766208741588182425380950D+02/
      DATA D1 / .5238852785508439144747174D+02/,
     *     D2 / .9646843357714742409535148D+03/,
     *     D3 / .7007152775135939601804416D+04/,
     *     D4 / .8515386792259821780601162D+04/,
     *     D5 /-.1002360095177164564992134D+06/,
     *     D6 /-.2065250031331232815791912D+06/,
     *     D7 / .5695324805290370358175984D+06/,
     *     D8 / .6589752493461331195697873D+06/,
     *     D9 /-.1192930193156561957631462D+07/
C-------------------------------
      DATA E0 / .540464821348814822409610122136D+00/,
     *     E1 /-.261515522487415653487049835220D-01/,
     *     E2 /-.288573438386338758794591212600D-02/,
     *     E3 /-.529353396945788057720258856000D-03/
C-------------------------------
C     COEFFICIENTS FOR THE ASYMPTOTIC EXPANSION
C-------------------------------
      DATA S1  / .75000000000000000000D+00/,
     *     S2  /-.18750000000000000000D+01/,
     *     S3  / .65625000000000000000D+01/,
     *     S4  /-.29531250000000000000D+02/,
     *     S5  / .16242187500000000000D+03/,
     *     S6  /-.10557421875000000000D+04/,
     *     S7  / .79180664062500000000D+04/,
     *     S8  /-.67303564453125000000D+05/,
     *     S9  / .63938386230468750000D+06/,
     *     S10 /-.67135305541992187500D+07/,
     *     S11 / .77205601373291015625D+08/
C-------------------------------
C
C                     1 .LE. X .LE. 2
C
      IF (X .GT. 2.D0) GO TO 10
      U = ((((((P7*X + P6)*X + P5)*X + P4)*X + P3)*X +
     *          P2)*X + P1)*X + P0
      V = ((((((Q7*X + Q6)*X + Q5)*X + Q4)*X + Q3)*X +
     *          Q2)*X + Q1)*X + 1.D0
C
      T = (X - 3.75D0)/(X + 3.75D0)
      DERFC0 = (((((((((U/V)*T + R8)*T + R7)*T + R6)*T + R5)*T +
     *                   R4)*T + R3)*T + R2)*T + R1)*T + R0
      RETURN
C
C                     2 .LT. X .LE. 4
C
   10 IF (X .GT. 4.D0) GO TO 20
      Z = 1.D0/(2.5D0 + X*X)
      U = (((((((A8*Z + A7)*Z + A6)*Z + A5)*Z + A4)*Z + A3)*Z +
     *                  A2)*Z + A1)*Z + A0
      V = ((((((((((B11*Z + B10)*Z + B9)*Z + B8)*Z + B7)*Z + B6)*Z +
     *              B5)*Z + B4)*Z + B3)*Z + B2)*Z + B1)*Z + 1.D0
C
      T = 13.D0*Z - 1.D0
      DERFC0 = ((((U/V)*T + E2)*T + E1)*T + E0)/X
      RETURN
C
C                     4 .LT. X .LT. 50
C
   20 IF (X .GE. 50.D0) GO TO 30
      Z = 1.D0/(2.5D0 + X*X)
      U = (((((((C8*Z + C7)*Z + C6)*Z + C5)*Z + C4)*Z + C3)*Z +
     *                  C2)*Z + C1)*Z + C0
      V = ((((((((D9*Z + D8)*Z + D7)*Z + D6)*Z + D5)*Z + D4)*Z +
     *                   D3)*Z + D2)*Z + D1)*Z + 1.D0
C
      T = 13.D0*Z - 1.D0
      DERFC0 = (((((U/V)*T + E3)*T + E2)*T + E1)*T + E0)/X
      RETURN
C
C                        X .GE. 50
C
   30 T = (1.D0/X)**2
      Z = (((((((((((S11*T + S10)*T + S9)*T + S8)*T + S7)*T +
     *        S6)*T + S5)*T + S4)*T + S3)*T + S2)*T + S1)*T -
     *        0.5D0)*T + 1.D0
      DERFC0 = RPINV*(Z/X)
      RETURN
      END
      REAL FUNCTION ERFI (P, Q)
C-----------------------------------------------------------------------
C
C              EVALUATION OF THE INVERSE ERROR FUNCTION
C
C                        ---------------
C
C     FOR 0 .LE. P .LT. 1,  W = ERFI(P,Q) WHERE ERF(W) = P. IT IS
C     ASSUMED THAT Q = 1 - P.  IF P .LT. 0, Q .LE. 0, OR P + Q IS
C     NOT 1, THEN ERFI(P,Q) IS SET TO A NEGATIVE VALUE.
C
C-----------------------------------------------------------------------
C     REFERENCE. MATHEMATICS OF COMPUTATION,OCT.1976,PP.827-830.
C                  J.M.BLAIR,C.A.EDWARDS,J.H.JOHNSON
C-----------------------------------------------------------------------
      REAL A(6),B(6),A1(7),B1(7),A2(9),B2(8),A3(9),B3(6)
C-----------------------------------------------------------------------
C     C2 = LN(1.E-100)
C-----------------------------------------------------------------------
      DATA C /.5625/, C1 /.87890625/
      DATA C2 /-.2302585092994046E+03/
C-----------------------------------------------------------------------
C                            TABLE NO.16
C-----------------------------------------------------------------------
      DATA A(1)/.1400216916161353E+03/,  A(2)/-.7204275515686407E+03/,
     1     A(3)/.1296708621660511E+04/,  A(4)/-.9697932901514031E+03/,
     2     A(5)/.2762427049269425E+03/,  A(6)/-.2012940180552054E+02/
      DATA B(1)/.1291046303114685E+03/,  B(2)/-.7312308064260973E+03/,
     1     B(3)/.1494970492915789E+04/,  B(4)/-.1337793793683419E+04/,
     2     B(5)/.5033747142783567E+03/,  B(6)/-.6220205554529216E+02/
C-----------------------------------------------------------------------
C                            TABLE NO.36
C-----------------------------------------------------------------------
      DATA A1(1)/-.1690478046781745E+00/, A1(2)/.3524374318100228E+01/,
     1     A1(3)/-.2698143370550352E+02/, A1(4)/.9340783041018743E+02/,
     2     A1(5)/-.1455364428646732E+03/, A1(6)/.8805852004723659E+02/,
     3     A1(7)/-.1349018591231947E+02/
      DATA B1(1)/-.1203221171313429E+00/, B1(2)/.2684812231556632E+01/,
     1     B1(3)/-.2242485268704865E+02/, B1(4)/.8723495028643494E+02/,
     2     B1(5)/-.1604352408444319E+03/, B1(6)/.1259117982101525E+03/,
     3     B1(7)/-.3184861786248824E+02/
C-----------------------------------------------------------------------
C                            TABLE NO.56
C-----------------------------------------------------------------------
      DATA A2(1)/.3100808562552958E-04/, A2(2)/.4097487603011940E-02/,
     1     A2(3)/.1214902662897276E+00/, A2(4)/.1109167694639028E+01/,
     2     A2(5)/.3228379855663924E+01/, A2(6)/.2881691815651599E+01/,
     3     A2(7)/.2047972087262996E+01/, A2(8)/.8545922081972148E+00/,
     4     A2(9)/.3551095884622383E-02/
      DATA B2(1)/.3100809298564522E-04/, B2(2)/.4097528678663915E-02/,
     1     B2(3)/.1215907800748757E+00/, B2(4)/.1118627167631696E+01/,
     2     B2(5)/.3432363984305290E+01/, B2(6)/.4140284677116202E+01/,
     3     B2(7)/.4119797271272204E+01/, B2(8)/.2162961962641435E+01/
C-----------------------------------------------------------------------
C                            TABLE NO.79
C-----------------------------------------------------------------------
      DATA A3(1)/.3205405422062050E-08/, A3(2)/.1899479322632128E-05/,
     1     A3(3)/.2814223189858532E-03/, A3(4)/.1370504879067817E-01/,
     2     A3(5)/.2268143542005976E+00/, A3(6)/.1098421959892340E+01/,
     3     A3(7)/.6791143397056208E+00/, A3(8)/-.834334189167721E+00/,
     4     A3(9)/.3421951267240343E+00/
      DATA B3(1)/.3205405053282398E-08/, B3(2)/.1899480592260143E-05/,
     1     B3(3)/.2814349691098940E-03/, B3(4)/.1371092249602266E-01/,
     2     B3(5)/.2275172815174473E+00/, B3(6)/.1125348514036959E+01/
C-----------------------------------------------------------------------
      IF (P .LT. 0.0 .OR. Q .LE. 0.0) GO TO 100
      EPS = AMAX1(SPMPAR(1),1.E-15)
      T = 0.5 + (0.5 - (P + Q))
      IF (ABS(T) .GT. 3.0*EPS) GO TO 110
C
C                      0 .LE. P .LE. 0.75
C
      IF (P .GT. 0.75) GO TO 10
      V = P*P - C
      T = P *  (((((A(6)*V + A(5))*V + A(4))*V + A(3))*V
     *                     + A(2))*V + A(1))
      S = (((((V + B(6))*V + B(5))*V + B(4))*V + B(3))*V
     *                     + B(2))*V + B(1)
      GO TO 40
C
C                    0.75 .LT. P .LE. 0.9375
C
   10 IF (P .GT. 0.9375) GO TO 20
      V = P*P - C1
      T = P *  ((((((A1(7)*V + A1(6))*V + A1(5))*V + A1(4))*V
     *                       + A1(3))*V + A1(2))*V + A1(1))
      S = ((((((V + B1(7))*V + B1(6))*V + B1(5))*V + B1(4))*V
     *            + B1(3))*V + B1(2))*V + B1(1)
      GO TO 40
C
C                  1.E-100 .LE. Q .LT. 0.0625
C
   20 V1 = ALOG(Q)
      V = 1.0/SQRT(-V1)
      IF (V1 .LT. C2) GO TO 30
      T = (((((((A2(9)*V + A2(8))*V + A2(7))*V + A2(6))*V + A2(5))*V
     *                   + A2(4))*V + A2(3))*V + A2(2))*V + A2(1)
      S = V *  ((((((((V + B2(8))*V + B2(7))*V + B2(6))*V + B2(5))*V
     *                   + B2(4))*V + B2(3))*V + B2(2))*V + B2(1))
      GO TO 40
C
C                 1.E-10000 .LE. Q .LT. 1.E-100
C
   30 T = (((((((A3(9)*V + A3(8))*V + A3(7))*V + A3(6))*V + A3(5))*V
     *                   + A3(4))*V + A3(3))*V + A3(2))*V + A3(1)
      S = V * ((((((V + B3(6))*V + B3(5))*V + B3(4))*V + B3(3))*V
     *                + B3(2))*V + B3(1))
   40 ERFI = T/S
      RETURN
C
C                         ERROR RETURN
C
  100 ERFI = -1.0
      RETURN
  110 ERFI = -2.0
      RETURN
      END
      DOUBLE PRECISION FUNCTION DERFI (P, Q)
C-----------------------------------------------------------------------
C
C                  DOUBLE PRECISION COMPUTATION OF
C                    THE INVERSE ERROR FUNCTION
C
C                         ----------------
C
C     FOR 0 .LE. P .LE. 1,  W = DERFI(P,Q) WHERE ERF(W) = P. IT
C     IS ASSUMED THAT Q = 1 - P. IF P .LT. 0, Q .LE. 0, OR P + Q
C     IS NOT 1, THEN DERFI(P,Q) IS SET TO A NEGATIVE VALUE.
C
C-----------------------------------------------------------------------
C     REFERENCE. MATHEMATICS OF COMPUTATION,OCT.1976,PP.827-830.
C                  J.M.BLAIR,C.A.EDWARDS,J.H.JOHNSON
C-----------------------------------------------------------------------
      DOUBLE PRECISION P, Q
      DOUBLE PRECISION C, C1, C2, R, EPS, F, LNQ, S, T, X
      DOUBLE PRECISION A(7), A1(7), A2(7), A3(11), A4(9),
     *                 B(7), B1(6), B2(6), B3(10), B4(9)
      DOUBLE PRECISION DPMPAR, DERF, DERFC1
C-----------------------------------------------------------------------
C     C2 = LN(1.E-100)
C     R  = SQRT(PI)/2
C-----------------------------------------------------------------------
      DATA C /.5625D0/, C1 /.87890625D0/
      DATA C2 /-.2302585092994045684017991454684364D+03/
      DATA R   /.8862269254527580136490837416705726D+00/
C-----------------------
      DATA A(1)/.841467547194693616D-01/, A(2)/.160499904248262200D+01/,
     *     A(3)/.809451641478547505D+01/, A(4)/.164273396973002581D+02/,
     *     A(5)/.154297507839223692D+02/, A(6)/.669584134660994039D+01/,
     *     A(7)/.108455979679682472D+01/
      DATA B(1)/.352281538790042405D-02/, B(2)/.293409069065309557D+00/,
     *     B(3)/.326709873508963100D+01/, B(4)/.123611641257633210D+02/,
     *     B(5)/.207984023857547070D+02/, B(6)/.170791197367677668D+02/,
     *     B(7)/.669253523595376683D+01/
C-----------------------
      DATA A1(1)/.552755110179178015D+2/, A1(2)/.657347545992519152D+3/,
     *     A1(3)/.124276851197202733D+4/, A1(4)/.818859792456464820D+3/,
     *     A1(5)/.234425632359410093D+3/, A1(6)/.299942187305427917D+2/,
     *     A1(7)/.140496035731853946D+1/
      DATA B1(1)/.179209835890172156D+3/, B1(2)/.991315839349539886D+3/,
     *     B1(3)/.138271033653003487D+4/, B1(4)/.764020340925985926D+3/,
     *     B1(5)/.194354053300991923D+3/, B1(6)/.228139510050586581D+2/
C-----------------------
      DATA A2(1)/.500926197430588206D+1/, A2(2)/.111349802614499199D+3/,
     *     A2(3)/.353872732756132161D+3/, A2(4)/.356000407341490731D+3/,
     *     A2(5)/.143264457509959760D+3/, A2(6)/.240823237485307567D+2/,
     *     A2(7)/.140496035273226366D+1/
      DATA B2(1)/.209004294324106981D+2/, B2(2)/.198607335199741185D+3/,
     *     B2(3)/.439311287748524270D+3/, B2(4)/.355415991280861051D+3/,
     *     B2(5)/.123303672628828521D+3/, B2(6)/.186060775181898848D+2/
C-----------------------------------------------------------------------
C                       MODIFIED TABLE NO.59
C-----------------------------------------------------------------------
      DATA A3(1) /.237121026548776092D4/, A3(2) /.732899958728969905D6/,
     *     A3(3) /.182063754893444775D7/, A3(4) /.269191299062422172D7/,
     *     A3(5) /.304817224671614253D7/, A3(6) /.130643103351072345D7/,
     *     A3(7) /.296799076241952125D6/, A3(8) /.457006532030955554D5/,
     *     A3(9) /.373449801680687213D4/, A3(10)/.118062255483596543D3/,
     *     A3(11)/.100000329157954960D1/
      DATA B3(1) /.851911109952055378D6/, B3(2) /.194746720192729966D7/,
     *     B3(3) /.373640079258593694D7/, B3(4) /.397271370110424145D7/,
     *     B3(5) /.339457682064283712D7/, B3(6) /.136888294898155938D7/,
     *     B3(7) /.303357770911491406D6/, B3(8) /.459721480357533823D5/,
     *     B3(9) /.373762573565814355D4/, B3(10)/.118064334590001264D3/
C-----------------------------------------------------------------------
C                       MODIFIED TABLE NO.82
C-----------------------------------------------------------------------
      DATA A4(1)/.154269429680540807D12/, A4(2)/.430207405012067454D12/,
     *     A4(3)/.182623446525965017D12/, A4(4)/.248740194409838713D11/,
     *     A4(5)/.133506080294978121D10/, A4(6)/.302446226073105850D08/,
     *     A4(7)/.285909602878724425D06/, A4(8)/.101789226017835707D04/,
     *     A4(9)/.100000004821118676D01/
      DATA B4(1)/.220533001293836387D12/, B4(2)/.347822938010402687D12/,
     *     B4(3)/.468373326975152250D12/, B4(4)/.185251723580351631D12/,
     *     B4(5)/.249464490520921771D11/, B4(6)/.133587491840784926D10/,
     *     B4(7)/.302480682561295591D08/, B4(8)/.285913799407861384D06/,
     *     B4(9)/.101789250893050230D04/
C-----------------------------------------------------------------------
      IF (P .LT. 0.D0 .OR. Q .LE. 0.D0) GO TO 100
      EPS = DPMPAR(1)
      T = 0.5D0 + (0.5D0 - (P + Q))
      IF (DABS(T) .GT. 3.D0*EPS) GO TO 110
C
C                      0 .LE. P .LE. 0.75
C
      IF (P .GT. 0.75D0) GO TO 10
      X = C - P*P
      S = (((((A(1)*X + A(2))*X + A(3))*X + A(4))*X + A(5))*X
     *                + A(6))*X + A(7)
      T = ((((((B(1)*X + B(2))*X + B(3))*X + B(4))*X + B(5))*X
     *                 + B(6))*X + B(7))*X + 1.D0
      DERFI = P*(S/T)
      IF (EPS .GT. 1.D-19) RETURN
C
      X = DERFI
      F = DERF(X) - P
      DERFI = X - R * DEXP(X*X) * F
      RETURN
C
C                    0.75 .LT. P .LE. 0.9375
C
   10 IF (P .GT. 0.9375D0) GO TO 40
      X = C1 - P*P
      IF (X .GT. 0.1D0) GO TO 20
      S = ((((((A1(1)*X + A1(2))*X + A1(3))*X + A1(4))*X
     *                  + A1(5))*X + A1(6))*X + A1(7))
      T = ((((((B1(1)*X + B1(2))*X + B1(3))*X + B1(4))*X
     *                  + B1(5))*X + B1(6))*X + 1.D0)
      GO TO 30
C
   20 S = ((((((A2(1)*X + A2(2))*X + A2(3))*X + A2(4))*X
     *                  + A2(5))*X + A2(6))*X + A2(7))
      T = ((((((B2(1)*X + B2(2))*X + B2(3))*X + B2(4))*X
     *                  + B2(5))*X + B2(6))*X + 1.D0)
C
   30 DERFI = P*(S/T)
      IF (EPS .GT. 1.D-19) RETURN
C
      X = DERFI
      T = DERFC1(1,X) - DEXP(X*X)*Q
      DERFI = X + R * T
      RETURN
C
C                  1.E-100 .LE. Q .LT. 0.0625
C
   40 LNQ = DLOG(Q)
      X = 1.D0/DSQRT(- LNQ)
      IF (LNQ .LT. C2) GO TO 50
      S = (((((((((A3(1)*X + A3(2))*X + A3(3))*X + A3(4))*X + A3(5))*X
     *                     + A3(6))*X + A3(7))*X + A3(8))*X + A3(9))*X
     *                     + A3(10))*X + A3(11)
      T = (((((((((B3(1)*X + B3(2))*X + B3(3))*X + B3(4))*X + B3(5))*X
     *                     + B3(6))*X + B3(7))*X + B3(8))*X + B3(9))*X
     *                     + B3(10))*X + 1.D0
      GO TO 60
C
C                 1.E-10000 .LE. Q .LT. 1.E-100
C
   50 S = (((((((A4(1)*X + A4(2))*X + A4(3))*X + A4(4))*X + A4(5))*X
     *                   + A4(6))*X + A4(7))*X + A4(8))*X + A4(9)
      T = ((((((((B4(1)*X + B4(2))*X + B4(3))*X + B4(4))*X + B4(5))*X
     *         + B4(6))*X + B4(7))*X + B4(8))*X + B4(9))*X + 1.D0
C
   60 DERFI = S/(X*T)
      IF (EPS .GT. 5.D-20) RETURN
C
      X = DERFI
      T = DERFC1(1,X)
      F = (DLOG(T) - LNQ) - X*X
      DERFI = X + R*T*F
      RETURN
C
C                         ERROR RETURN
C
  100 DERFI = -1.D0
      RETURN
  110 DERFI = -2.D0
      RETURN
      END
      REAL FUNCTION AERF (X, H)
C-----------------------------------------------------------------------
C             COMPUTATION OF ERF(X + H) - ERF(X - H)
C-----------------------------------------------------------------------
C     C = 2/SQRT(PI)
C     P = LN(9*SQRT(PI))
C---------------------
      DATA C /1.12837916709551257/, P /2.76959/
C---------------------
C
C     **** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C          SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 .
C
                       EPS = SPMPAR(1)
C
C---------------------
      AERF = 0.0
      IF (H .EQ. 0.0) RETURN
C
      AH = ABS(H)
      AX = ABS(X)
      XPH = AX + AH
      XMH = AX - AH
C
      T = AMAX1(AH,AX)
      T = T*T
      IF (1.6*T*T .LT. EPS) GO TO 140
      IF ((AX*AH)**2 .LT. 0.5*EPS) GO TO 150
      IF (AX .LE. AH) GO TO 100
C
      IF (XMH .LT. 9.0) GO TO 5
         IF (XMH*XMH + P .GT. -EXPARG(1)) RETURN
    5 IF (4.0*AH*AX .GT. -EPSLN(0)) GO TO 120
C
      IF (AX .GT. 3.0*AH) GO TO 10
      IF (XPH .LT. 1.0) GO TO 110
      GO TO 130
C-------------------------------------------------
C        FOR (AX LESS THAN OR EQUAL TO .40)
C-------------------------------------------------
   10 E = AMAX1(1.E-15,EPS)
      IF (AX .GT. 0.40) GO TO 30
      H2 = XPH*XPH
      A2 = XMH*XMH
      X2 = AX + AX
      ST = 1.
      HF = XMH
      N = 0
      N1 = 1
      DN2 = 1.
      S = 0.
   20   N = N + 1
        N1 = N1 + 2
        DN2 = -DN2/N
        ST = H2*ST + X2*HF
        HF = A2*HF
        T = ST*DN2/N1
        S = S + T
        IF (ABS(T) .GT. E*ABS(S)) GO TO 20
      S = 0.5 + (S + 0.5)
      AERF = 2.0*C*AH*S
      GO TO 45
C-------------------------------------------------
C        FOR (AX GREATER THAN .40)
C-------------------------------------------------
   30 N = 1
      J = 0
      H2 = 0.
      Z = EXP(-0.5*AX*AX)
      U = 2.0*AH*C*Z
      H3 = Z
      V = 2.0*H*H
      HF = 2.0*AX*AH
      S = 0.
   35   H2 = (HF*H3 - V*H2)/N
        N = N + 1
        H3 = (HF*H2 - V*H3)/N
        N = N + 1
        HG = H3/N
        S = S + HG
        IF (ABS(HG) .GT. E*ABS(S)) GO TO 35
        IF (J .NE. 0) GO TO 40
        J = 1
        GO TO 35
   40 AERF = U*(S + Z)
   45 IF (H .LT. 0.0) AERF = -AERF
      RETURN
C-------------------------------------------------
C        SPECIAL CASES
C-------------------------------------------------
  100 IF (XPH .LT. 5.8) GO TO 110
      IF (XMH .GT. -5.6) GO TO 120
      AERF = SIGN(2.0,H)
      RETURN
C
  110 AERF = ERF(XPH) - ERF(XMH)
      IF (H .LT. 0.0) AERF = -AERF
      RETURN
C
  120 AERF = ERFC(XMH)
      IF (H .LT. 0.0) AERF = -AERF
      RETURN
C
  130 AERF = ERFC(XMH) - ERFC(XPH)
      IF (H .LT. 0.0) AERF = -AERF
      RETURN
C
  140 AERF = 2.0*C*H*(0.5 + (0.5 - (X*X + H*H/3.0)))
      RETURN
C
C     THE VALUE IS  2.0*EXP(-X*X)*ERF(H)
C
  150 T = 2.0
      X2 = X*X
      IF (X2 .GE. EPS) T = 2.0*EXP(-X2)
      IF (H*H .GE. 3.0*EPS) GO TO 160
         AERF = C*H*T
         RETURN
  160 AERF = T*ERF(H)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DAERF (X, H)
C-----------------------------------------------------------------------
C             COMPUTATION OF ERF(X + H) - ERF(X - H)
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, H
      DOUBLE PRECISION AH, AX, A2, C, DN2, E, EPS, HF, HG, H2, H3,
     *                 N, N1, P, S, ST, T, U, V, XMH, XPH, X2, Z
      DOUBLE PRECISION DERF, DERFC, DPMPAR, DEPSLN, DXPARG
C---------------------
C     C = 2/SQRT(PI)
C     P = LN(9*SQRT(PI))
C---------------------
      DATA C /1.12837916709551257389615890312155D0/
      DATA P /2.76959D0/
C---------------------
C
C     **** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C          SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0 .
C
                       EPS = DPMPAR(1)
C
C---------------------
      DAERF = 0.D0
      IF (H .EQ. 0.D0) RETURN
C
      AH = DABS(H)
      AX = DABS(X)
      XPH = AX + AH
      XMH = AX - AH
C
      T = DMAX1(AH,AX)
      T = T*T
      IF (1.6D0*T*T .LT. EPS) GO TO 140
      IF ((AX*AH)**2 .LT. 0.5D0*EPS) GO TO 150
      IF (AX .LE. AH) GO TO 100
C
      IF (XMH .LT. 9.D0) GO TO 5
         IF (XMH*XMH + P .GT. -DXPARG(1)) RETURN
    5 IF (4.D0*AH*AX .GT. -DEPSLN(0)) GO TO 120
C
      IF (AX .GT. 3.D0*AH) GO TO 10
      IF (XPH .LT. 1.D0) GO TO 110
      GO TO 130
C-------------------------------------------------
C        FOR (AX LESS THAN OR EQUAL TO .40)
C-------------------------------------------------
   10 E = DMAX1(1.D-30,EPS)
      IF (AX .GT. 0.4D0) GO TO 30
      H2 = XPH*XPH
      A2 = XMH*XMH
      X2 = AX + AX
      ST = 1.D0
      HF = XMH
      N = 0.D0
      N1 = 1.D0
      DN2 = 1.D0
      S = 0.D0
   20   N = N + 1.D0
        N1 = N1 + 2.D0
        DN2 = -DN2/N
        ST = H2*ST + X2*HF
        HF = A2*HF
        T = ST*DN2/N1
        S = S + T
        IF (DABS(T) .GT. E*DABS(S)) GO TO 20
      S = 0.5D0 + (0.5D0 + S)
      DAERF = 2.D0*C*AH*S
      GO TO 45
C-------------------------------------------------
C        FOR (AX GREATER THAN .40)
C-------------------------------------------------
   30 N = 1.D0
      J = 0
      H2 = 0.D0
      Z = DEXP(-0.5D0*AX*AX)
      U = 2.D0*AH*C*Z
      H3 = Z
      V = 2.D0*H*H
      HF = 2.D0*AX*AH
      S = 0.D0
   35   H2 = (HF*H3 - V*H2)/N
        N = N + 1.D0
        H3 = (HF*H2 - V*H3)/N
        N = N + 1.D0
        HG = H3/N
        S = S + HG
        IF (DABS(HG) .GT. E*DABS(S)) GO TO 35
        IF (J .NE. 0) GO TO 40
        J = 1
        GO TO 35
   40 DAERF = U*(S + Z)
   45 IF (H .LT. 0.D0) DAERF = -DAERF
      RETURN
C-------------------------------------------------
C        SPECIAL CASES
C-------------------------------------------------
  100 IF (XPH .LT. 8.5D0) GO TO 110
      IF (XMH .GT. -8.3D0) GO TO 120
      DAERF = DSIGN(2.D0,H)
      RETURN
C
  110 DAERF = DERF(XPH) - DERF(XMH)
      IF (H .LT. 0.D0) DAERF = -DAERF
      RETURN
C
  120 DAERF = DERFC(XMH)
      IF (H .LT. 0.D0) DAERF = -DAERF
      RETURN
C
  130 DAERF = DERFC(XMH) - DERFC(XPH)
      IF (H .LT. 0.D0) DAERF = -DAERF
      RETURN
C
  140 DAERF = 2.D0*C*H*(0.5D0 + (0.5D0 - (X*X + H*H/3.D0)))
      RETURN
C
C     THE VALUE IS  2.0*EXP(-X*X)*ERF(H)
C
  150 T = 2.D0
      X2 = X*X
      IF (X2 .GE. EPS) T = 2.D0*DEXP(-X2)
      IF (H*H .GE. 3.D0*EPS) GO TO 160
         DAERF = C*H*T
         RETURN
  160 DAERF = T*DERF(H)
      RETURN
      END
      FUNCTION PNDF(X,IND)
C     ---------------
C     A = 1/SQRT(2)
C     C = SQRT(2/PI)
C     ---------------
      DATA A/.707106781186548/
      DATA C/.797884560802865/
C     ---------------
      T = A*X
      IF (IND .NE. 0) GO TO 20
      IF (X .LT. -8.0) GO TO 10
      PNDF = 0.5*ERFC1(0,-T)
      RETURN
   10 PNDF = C/ERFC1(1,-T)
      RETURN
   20 IF (X .GT. 8.0) GO TO 30
      PNDF = 0.5*ERFC1(0,T)
      RETURN
   30 PNDF = C/ERFC1(1,T)
      RETURN
      END
      SUBROUTINE PNI (P, Q, D, W, IERR)
C-----------------------------------------------------------------------
C
C         EVALUATION OF THE INVERSE NORMAL DISTRIBUTION FUNCTION
C
C                           ------------
C
C     LET F(T) = 1/(SQRT(2*PI)*EXP(-T*T/2)). THEN THE FUNCTION
C
C        PROB(X) = INTEGRAL FROM MINUS INFINITY TO X OF F(T)
C
C     IS THE NORMAL DISTRIBUTION FUNCTION OF ZERO MEAN AND UNIT
C     VARIANCE. IT IS ASSUMED THAT P .GT. 0, Q .GT. 0, P + Q = 1,
C     AND D = P - 0.5. THE VALUE W IS COMPUTED WHERE PROB(W) = P.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C
C       IERR = 0  NO INPUT ERRORS WERE DETECTED. W WAS COMPUTED.
C       IERR = 1  EITHER P OR Q IS INCORRECT.
C       IERR = 2  D IS INCORRECT.
C
C-----------------------------------------------------------------------
C     RT2 = SQRT(2)
C------------------------
      DATA RT2 /1.414213562373095/
C------------------------
      T = AMIN1(P,Q)
      IF (T .LE. 0.0) GO TO 10
      EPS = AMAX1(SPMPAR(1),1.E-15)
      W = 0.5 + (0.5 - (P + Q))
      IF (ABS(W) .GT. 2.0*EPS) GO TO 10
C
      U = ABS(D + D)
      V = T + T
      W = ERFI(U, V)
      IF (W .LT. 0.0) GO TO 20
C
      IERR = 0
      W = RT2*W
      IF (D .LT. 0.0) W = - W
      RETURN
C
C                         ERROR RETURN
C
   10 IERR = 1
      RETURN
   20 IERR = 2
      RETURN
      END
      SUBROUTINE DPNI (P, Q, D, W, IERR)
C-----------------------------------------------------------------------
C
C         EVALUATION OF THE INVERSE NORMAL DISTRIBUTION FUNCTION
C
C                           ------------
C
C     LET F(T) = 1/(SQRT(2*PI)*EXP(-T*T/2)). THEN THE FUNCTION
C
C        PROB(X) = INTEGRAL FROM MINUS INFINITY TO X OF F(T)
C
C     IS THE NORMAL DISTRIBUTION FUNCTION OF ZERO MEAN AND UNIT
C     VARIANCE. IT IS ASSUMED THAT P .GT. 0, Q .GT. 0, P + Q = 1,
C     AND D = P - 0.5. THE VALUE W IS COMPUTED WHERE PROB(W) = P.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C
C       IERR = 0  NO INPUT ERRORS WERE DETECTED. W WAS COMPUTED.
C       IERR = 1  EITHER P OR Q IS INCORRECT.
C       IERR = 2  D IS INCORRECT.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION P, Q, D, W
      DOUBLE PRECISION EPS, RT2, U, V, T
      DOUBLE PRECISION DPMPAR, DERFI
C------------------------
C     RT2 = SQRT(2)
C------------------------
      DATA RT2 /1.4142135623730950488016887242097D0/
C------------------------
      T = DMIN1(P,Q)
      IF (T .LE. 0.D0) GO TO 10
      EPS = DPMPAR(1)
      W = 0.5D0 + (0.5D0 - (P + Q))
      IF (DABS(W) .GT. 2.D0*EPS) GO TO 10
C
      U = DABS(D + D)
      V = T + T
      W = DERFI(U, V)
      IF (W .LT. 0.D0) GO TO 20
C
      IERR = 0
      W = RT2*W
      IF (D .LT. 0.D0) W = - W
      RETURN
C
C                         ERROR RETURN
C
   10 IERR = 1
      RETURN
   20 IERR = 2
      RETURN
      END
      REAL FUNCTION DAW(X)
C-----------------------------------------------------------------------
C
C     THIS FUNCTION COMPUTES SINGLE PRECISION VALUES OF DAWSONS
C     INTEGRAL,
C
C        EXP(-X*X) * INTEGRAL (FROM 0 TO X) EXP(T*T) DT,
C
C     DEFINED FOR ALL REAL ARGUMENTS.
C
C     THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV
C     APPROXIMATIONS PUBLISHED IN MATH. COMP. 24, 171-178(1970) BY
C     CODY, PACIOREK AND THACHER.
C
C-----------------------------------------------------------------------
      REAL P1(9),Q1(9),P2(8),Q2(7),P3(8),Q3(7),P4(7),Q4(6),
     *     FRAC,SUMP,SUMQ,W2,X,Y,XLARGE,XSMALL
C---------------
      DATA XLARGE/16777216.0/, XSMALL/.59604644775391E-07/
C---------------
C
C           COEFFICIENTS FOR R(8,8) APPROXIMATION,
C           USED FOR ABS(X)  .LT.  2.5
C
C---------------
      DATA P1(1)/.100000000000000E+01/, P1(2)/-.135599049815353E+00/,
     *     P1(3)/.456738974064825E-01/, P1(4)/-.258323495918050E-02/,
     *     P1(5)/.360079463580992E-03/, P1(6)/-.944375029163387E-05/,
     *     P1(7)/.634674256878843E-06/, P1(8)/-.711645839183817E-08/,
     *     P1(9)/.977985913592343E-10/
      DATA Q1(1)/.100000000000000E+01/, Q1(2)/.531067616851310E+00/,
     *     Q1(3)/.133052308640737E+00/, Q1(4)/.206907491644210E-01/,
     *     Q1(5)/.220437428972266E-02/, Q1(6)/.166706801664365E-03/,
     *     Q1(7)/.887964712053131E-05/, Q1(8)/.311750854173480E-06/,
     *     Q1(9)/.574807177698046E-08/
C---------------
C
C           COEFFICIENTS FOR R(7,7) APPROXIMATION,
C           IN J-FRACTION FORM, USED FOR
C           2.5 .LE. ABS(X) .LT. 3.5
C
C---------------
      DATA P2(1)/-.150695651187161E+01/, P2(2)/ .293365747395449E+02/,
     *     P2(3)/-.400000893643550E+02/, P2(4)/-.757931918089369E-01/,
     *     P2(5)/-.889106479747812E+01/, P2(6)/ .152644099623699E+02/,
     *     P2(7)/-.597678086823489E+01/, P2(8)/ .500236896088668E+00/
      DATA Q2(1)/-.673106069744813E+00/, Q2(2)/ .124486788262252E+04/,
     *     Q2(3)/ .721193217600229E+01/, Q2(4)/ .112461662024575E+03/,
     *     Q2(5)/ .729177556415532E+02/, Q2(6)/ .115840292551888E+03/,
     *     Q2(7)/ .226064666074309E+00/
C---------------
C
C           COEFFICIENTS FOR R(7,7) APPROXIMATION,
C           IN J-FRACTION FORM, USED FOR
C           3.5 .LE. ABS(X) .LE. 5.0
C
C---------------
      DATA P3(1)/ .476405645273229E+01/, P3(2)/-.266167674896399E+02/,
     *     P3(3)/-.916804879813552E+01/, P3(4)/-.150507703496692E+02/,
     *     P3(5)/ .506460153742231E+01/, P3(6)/-.498544802986608E+01/,
     *     P3(7)/-.149838042036691E+01/, P3(8)/ .499999902705054E+00/
      DATA Q3(1)/ .287776122973187E+03/, Q3(2)/ .256105722342226E+02/,
     *     Q3(3)/ .751701277744067E+02/, Q3(4)/ .146515167783109E+03/,
     *     Q3(5)/ .330707724676114E+02/, Q3(6)/-.148715811787195E+01/,
     *     Q3(7)/ .250011459611839E+00/
C---------------
C
C           COEFFICIENTS FOR R(6,6) APPROXIMATION,
C           IN J-FRACTION FORM, USED FOR ABS(X) .GT. 5.0
C
C---------------
      DATA P4(1)/-.315576735766984E+02/, P4(2)/-.100791496592972E+02/,
     *     P4(3)/-.710713709224200E+01/, P4(4)/-.596879853243925E+01/,
     *     P4(5)/-.449773645376092E+01/, P4(6)/-.249999965398199E+01/,
     *     P4(7)/ .499999999999330E+00/
      DATA Q4(1)/ .168874162155616E+03/, Q4(2)/ .698280748271071E+01/,
     *     Q4(3)/-.213029621139181E+02/, Q4(4)/-.712157348463305E+01/,
     *     Q4(5)/-.250005973192356E+01/, Q4(6)/ .750000000715687E+00/
C-----------------------------------------------------------------------
C
      IF (ABS(X) .GT. XLARGE) GO TO 500
      IF (ABS(X) .LT. XSMALL) GO TO 600
      Y = X * X
      IF (Y .GE. 6.25E0) GO TO 200
C
C     ---------- ABS(X) .LT. 2.5 ----------
C
      SUMP = (((((((P1(9) * Y + P1(8)) * Y + P1(7)) * Y + P1(6))
     1        * Y + P1(5)) * Y + P1(4)) * Y + P1(3)) * Y + P1(2))
     2        * Y + P1(1)
      SUMQ = (((((((Q1(9) * Y + Q1(8)) * Y + Q1(7)) * Y + Q1(6))
     1        * Y + Q1(5)) * Y + Q1(4)) * Y + Q1(3)) * Y + Q1(2))
     2        * Y + Q1(1)
      DAW = X * SUMP / SUMQ
      GO TO 1000
C
C     ---------- 2.5 .LE. ABS(X) .LT. 3.5 ----------
C
  200 IF (Y .GE. 12.25E0) GO TO 300
      FRAC = 0.0E0
C
      DO 220 I = 1, 7
  220 FRAC = Q2(I) / (P2(I) + Y + FRAC)
C
      DAW = (P2(8) + FRAC) / X
      GO TO 1000
C
C     ---------- 3.5 .LE. ABS(X) .LT. 5.0 ----------
C
  300 IF (Y .GE. 25.0E0) GO TO 400
      FRAC = 0.0E0
C
      DO 320 I = 1, 7
  320 FRAC = Q3(I) / (P3(I) + Y + FRAC)
C
      DAW = (P3(8) + FRAC) / X
      GO TO 1000
C
C     ---------- 5.0 .LE. ABS(X) .LE. XLARGE ----------
C
  400 W2 = 1.0E0 / X / X
      FRAC = 0.0E0
C
      DO 420 I = 1, 6
  420 FRAC = Q4(I) / (P4(I) + Y + FRAC)
C
      FRAC = P4(7) + FRAC
      DAW = (0.5E0 + 0.5E0 * W2 * FRAC) / X
      GO TO 1000
C
C     ---------- XLARGE .LT. ABS(X) ----------
C
  500 DAW = 0.5E0 / X
      GO TO 1000
C
C     ---------- RETURN FOR SMALL X ----------
C
  600 DAW = X
C
 1000 RETURN
      END
      DOUBLE PRECISION FUNCTION DPDAW (X)
C-----------------------------------------------------------------------
C            DOUBLE PRECISION COMPUTATION OF DAWSONS INTEGRAL
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, A(20), B(45), AX, EPS, T, W
      DOUBLE PRECISION DCSEVL, DPDAW0
C----------------------------
      DATA EPS /1.D-31/
C----------------------------
      DATA A(1)  /-.6666666666666666666666666666657D+00/,
     *     A(2)  / .2666666666666666666666666665302D+00/,
     *     A(3)  /-.7619047619047619047619046823290D-01/,
     *     A(4)  / .1693121693121693121693097101950D-01/,
     *     A(5)  /-.3078403078403078403073750370528D-02/,
     *     A(6)  / .4736004736004736004148385001356D-03/,
     *     A(7)  /-.6314672981339647953899064401849D-04/,
     *     A(8)  / .7429027036870170692270376716931D-05/,
     *     A(9)  /-.7820028459863171536925638117632D-06/,
     *     A(10) / .7447646152244351276445219666744D-07/
      DATA A(11) /-.6476214045244314289022051868963D-08/,
     *     A(12) / .5180971231894821888421654461823D-09/,
     *     A(13) /-.3837756389504541092817011259727D-10/,
     *     A(14) / .2646727414301012080897585412600D-11/,
     *     A(15) /-.1707553348198261876085879075486D-12/,
     *     A(16) / .1034770025122653524451023758330D-13/,
     *     A(17) /-.5905667147861158816695814259561D-15/,
     *     A(18) / .3157018166820009192834256496230D-16/,
     *     A(19) /-.1501742103181747984387915732309D-17/,
     *     A(20) / .4921379778280206677674574916266D-19/
C----------------------------
      DATA B(1)  /-.56886544105215527114160533733674D-01/,
     *     B(2)  /-.31811346996168131279322878048822D+00/,
     *     B(3)  / .20873845413642236789741580198858D+00/,
     *     B(4)  /-.12475409913779131214073498314784D+00/,
     *     B(5)  / .67869305186676777092847516423676D-01/,
     *     B(6)  /-.33659144895270939503068230966587D-01/,
     *     B(7)  / .15260781271987971743682460381640D-01/,
     *     B(8)  /-.63483709625962148230586094788535D-02/,
     *     B(9)  / .24326740920748520596865966109343D-02/,
     *     B(10) /-.86219541491065032038526983549637D-03/
      DATA B(11) / .28376573336321625302857636538295D-03/,
     *     B(12) /-.87057549874170423699396581464335D-04/,
     *     B(13) / .24986849985481658331800044137276D-04/,
     *     B(14) /-.67319286764160294344603050339520D-05/,
     *     B(15) / .17078578785573543710504524047844D-05/,
     *     B(16) /-.40917551226475381271896592490038D-06/,
     *     B(17) / .92828292216755773260751785312273D-07/,
     *     B(18) /-.19991403610147617829845096332198D-07/,
     *     B(19) / .40963490644082195241210487868917D-08/,
     *     B(20) /-.80032409540993168075706781753561D-09/
      DATA B(21) / .14938503128761465059143225550110D-09/,
     *     B(22) /-.26687999885622329284924651063339D-10/,
     *     B(23) / .45712216985159458151405617724103D-11/,
     *     B(24) /-.75187305222043565872243727326771D-12/,
     *     B(25) / .11893100052629681879029828987302D-12/,
     *     B(26) /-.18116907933852346973490318263084D-13/,
     *     B(27) / .26611733684358969193001612199626D-14/,
     *     B(28) /-.37738863052129419795444109905930D-15/,
     *     B(29) / .51727953789087172679680082229329D-16/,
     *     B(30) /-.68603684084077500979419564670102D-17/
      DATA B(31) / .88123751354161071806469337321745D-18/,
     *     B(32) /-.10974248249996606292106299624652D-18/,
     *     B(33) / .13261199326367178513595545891635D-19/,
     *     B(34) /-.15562732768137380785488776571562D-20/,
     *     B(35) / .17751425583655720607833415570773D-21/,
     *     B(36) /-.19695006967006578384953608765439D-22/,
     *     B(37) / .21270074896998699661924010120533D-23/,
     *     B(38) /-.22375398124627973794182113962666D-24/,
     *     B(39) / .22942768578582348946971383125333D-25/,
     *     B(40) /-.22943788846552928693329592319999D-26/
      DATA B(41) / .22391702100592453618342297600000D-27/,
     *     B(42) /-.21338230616608897703678225066666D-28/,
     *     B(43) / .19866196585123531518028458666666D-29/,
     *     B(44) /-.18079295866694391771955199999999D-30/,
     *     B(45) / .16090686015283030305450666666666D-31/
C----------------------------
      AX = DABS(X)
      IF (AX .GE. 4.D0) GO TO 30
      T = X*X
      IF (AX .GT. 1.D0) GO TO 20
C
C                       ABS(X) .LE. 1
C
      DPDAW = X
      IF (T .LT. EPS) RETURN
C
      W = A(20)
      DO 10 I = 1,19
         K = 20 - I
         W = T*W + A(K)
   10 CONTINUE
      DPDAW = X * (0.75D0 + (0.25D0 + T*W))
      RETURN
C
C                    1 .LT. ABS(X) .LT. 4
C
   20 DPDAW = X * (.25D0 + DCSEVL(.125D0*T - 1.D0, B, 45))
      RETURN
C
C                       ABS(X) .GE. 4
C
   30 DPDAW = DPDAW0(AX)/X
      RETURN
      END
      DOUBLE PRECISION FUNCTION DPDAW0 (X)
C-----------------------------------------------------------------------
C
C                EVALUATION OF X*DAW(X) FOR X .GE. 4
C                WHERE DAW(X) IS THE DAWSON INTEGRAL
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, T, U, V, W
      DOUBLE PRECISION A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10,
     *                 A11, A12, A13, A14, A15, A16, A17, A18,
     *                 B1, B2, B3, B4
      DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, C10,
     *                 C11, C12, C13, C14,
     *                 D1, D2, D3, D4, D5, D6, D7, D8
      DOUBLE PRECISION E0, E1, E2, E3, E4, E5, E6, E7, E8, E9, E10,
     *                 F1, F2, F3, F4, F5, F6, F7, F8, F9, F10
      DOUBLE PRECISION G0, G1, G2, G3, G4, G5, G6, G7, G8, G9, G10,
     *                 G11, H1, H2, H3, H4, H5, H6, H7, H8, H9, H10
      DOUBLE PRECISION S0, S1, S2, S3, S4, S5
      DOUBLE PRECISION P0, P1, P2, P3, P4, P5, Q1, Q2, Q3, Q4, Q5
C----------------------------
      DATA A0  / .59682223611279114961181337D-06/,
     *     A1  / .17685355947137064277328544D-05/,
     *     A2  / .46539151619719879425847199D-05/,
     *     A3  / .60206549750426063518629015D-05/,
     *     A4  / .71968323029042065431569341D-05/,
     *     A5  / .30632314265730271259576310D-05/,
     *     A6  / .58023977792358623878717970D-06/,
     *     A7  /-.79009104459686847104040749D-06/,
     *     A8  /-.48136647436848802449955585D-06/,
     *     A9  / .15516701696125663593787151D-05/
      DATA A10 / .41907470564012404920368069D-05/,
     *     A11 / .58027971313506864533128271D-05/,
     *     A12 / .55370618938769991926278955D-05/,
     *     A13 / .38921890500515083447099834D-05/,
     *     A14 / .20373391058442140223632125D-05/,
     *     A15 / .77894504402267231707108862D-06/,
     *     A16 / .20671717275442647450228015D-06/,
     *     A17 / .34163346266402336952767687D-07/,
     *     A18 / .26550833614486808486653527D-08/
C----------------------------
      DATA B1  / .24655153970246619491575782D+01/,
     *     B2  / .62943144539382480033771054D+01/,
     *     B3  / .62122304537339562619049238D+01/,
     *     B4  / .72256247680648550388609993D+01/
C----------------------------
      DATA C0  / .59682220964671964619429990D-06/,
     *     C1  / .15714896176335781761895194D-05/,
     *     C2  / .38969553030269966874001463D-05/,
     *     C3  / .52383725295173020317044495D-05/,
     *     C4  / .68105053752194312932660379D-05/,
     *     C5  / .54424292166005622934118953D-05/,
     *     C6  / .42426204827598626398351706D-05/,
     *     C7  / .16034175582037599078896885D-05/,
     *     C8  / .40869743822567069272296881D-06/,
     *     C9  /-.28877279517645392833652391D-06/
      DATA C10 /-.23330912423546272053845073D-06/,
     *     C11 /-.52391219684126122047201575D-07/,
     *     C12 / .21002079856304960793765863D-07/,
     *     C13 / .15999459808634652894884878D-07/,
     *     C14 / .30942877932880022278704223D-08/
C----------------------------
      DATA D1  / .21353586303464124681525146D+01/,
     *     D2  / .51903635881846225790635588D+01/,
     *     D3  / .55426108503039000945912263D+01/,
     *     D4  / .72404445472735688881512590D+01/,
     *     D5  / .42043425514299588216548098D+01/,
     *     D6  / .39555198251457455938284071D+01/,
     *     D7  / .96558431899415447517392039D+00/,
     *     D8  / .85802563214754700974536646D+00/
C----------------------------
      DATA E0  / .59682220964671964619429989D-06/,
     *     E1  / .84093250039847132132545694D-06/,
     *     E2  / .21215362314612857942015465D-05/,
     *     E3  / .17544801458346344458699925D-05/,
     *     E4  / .23300467572238537581015267D-05/,
     *     E5  / .10789302963153438789721000D-05/,
     *     E6  / .84593690165753140097573765D-06/,
     *     E7  / .58921927492401852305814815D-07/,
     *     E8  / .88699252882391671775568852D-08/,
     *     E9  /-.45367333700483839577191791D-07/
      DATA E10 /-.57476692572774473717756092D-08/
C----------------------------
      DATA F1  / .91128032791938035312580060D+00/,
     *     F2  / .28248447610354665352098820D+01/,
     *     F3  / .12208226691968579661669930D+01/,
     *     F4  / .26127044898109340807106578D+01/,
     *     F5  / .34850941500747816686718301D+00/,
     *     F6  / .11058424028893031129155960D+01/,
     *     F7  /-.58583432304677947215235382D-01/,
     *     F8  / .22235753204903993496120223D+00/,
     *     F9  /-.22116625272550591073419658D-01/,
     *     F10 / .14938281115881437851795141D-01/
C----------------------------
      DATA G0  / .59682220962853689178993039D-06/,
     *     G1  / .10399202637216492921747166D-05/,
     *     G2  / .20011159669496258291170369D-05/,
     *     G3  / .19689301951834731308289277D-05/,
     *     G4  / .18861506874082130108404839D-05/,
     *     G5  / .10403672611266773427898830D-05/,
     *     G6  / .42700287233074049241986613D-06/,
     *     G7  /-.16199303908856237550380048D-07/,
     *     G8  /-.73900110466591484816182863D-07/,
     *     G9  /-.21369058482679700785965255D-07/
      DATA G10 / .42853587024761116737793072D-08/,
     *     G11 /-.27226352610679391576406666D-09/
C----------------------------
      DATA H1  / .12446924554654251972427023D+01/,
     *     H2  / .24571243397858142676189669D+01/,
     *     H3  / .16710488988253927773151334D+01/,
     *     H4  / .17260859791081983044753913D+01/,
     *     H5  / .67406536368694046314885196D+00/,
     *     H6  / .47403526893401885333000527D+00/,
     *     H7  / .96251479080923959509108658D-01/,
     *     H8  / .53334517885765587426678624D-01/,
     *     H9  / .39450307003297031975491216D-02/,
     *     H10 / .20209221166462656808887976D-02/
C----------------------------
      DATA S0  / .8210986449041747719684610504710D-02/,
     *     S1  / .8646073144815053170065230898334D-02/,
     *     S2  / .4768322737615973285410030924398D-03/,
     *     S3  / .4792593707378225992657970685396D-04/,
     *     S4  / .7507677744363576693833551190204D-05/,
     *     S5  / .1737929446861228512373840727547D-05/
C----------------------------
      DATA P0 / .29531250000000000000002D+02/,
     *     P1 /-.14571781607273299440392D+04/,
     *     P2 / .24285318385898860175073D+05/,
     *     P3 /-.15843555052114168113822D+06/,
     *     P4 / .32969397422638395586636D+06/,
     *     P5 /-.55331506994311967089636D+04/
      DATA Q1 /-.54843599093412230906873D+02/,
     *     Q2 / .10882497826844164906477D+04/,
     *     Q3 /-.96578534881552358457185D+04/,
     *     Q4 / .37803382357862589384458D+05/,
     *     Q5 /-.51283783372259864777146D+05/
C----------------------------
      IF (X .GE. 12.D0) GO TO 50
      T = (32.D0/(X*X) - 0.5D0) - 0.5D0
      IF (T .GE. 0.D0) GO TO 20
C
C                    -7/9 .LE. T .LE. -0.4
C
      IF (T .GT. -0.4D0) GO TO 10
      U = ((((((((A18*T + A17)*T + A16)*T + A15)*T + A14)*T +
     *            A13)*T + A12)*T + A11)*T + A10)*T + A9
      U = ((((((((U*T + A8)*T + A7)*T + A6)*T + A5)*T +
     *            A4)*T + A3)*T + A2)*T + A1)*T + A0
      V = (((B4*T + B3)*T + B2)*T + B1)*T + 1.D0
      GO TO 40
C
C                     -0.4 .LT. T .LT. 0
C
   10 U = ((((((((C14*T + C13)*T + C12)*T + C11)*T + C10)*T +
     *            C9)*T + C8)*T + C7)*T + C6)*T + C5
      U = ((((U*T + C4)*T + C3)*T + C2)*T + C1)*T + C0
      V = (((((((D8*T + D7)*T + D6)*T + D5)*T + D4)*T +
     *           D3)*T + D2)*T + D1)*T + 1.D0
      GO TO 40
C
C                      0 .LE. T .LE. 0.4
C
   20 IF (T .GT. 0.4D0) GO TO 30
      U = (((((((((E10*T + E9)*T + E8)*T + E7)*T + E6)*T +
     *             E5)*T + E4)*T + E3)*T + E2)*T + E1)*T + E0
      V = (((((((((F10*T + F9)*T + F8)*T + F7)*T + F6)*T +
     *             F5)*T + F4)*T + F3)*T + F2)*T + F1)*T + 1.D0
      GO TO 40
C
C                      0.4 .LT. T .LE. 1
C
   30 U = ((((((((G11*T + G10)*T + G9)*T + G8)*T + G7)*T +
     *            G6)*T + G5)*T + G4)*T + G3)*T + G2
      U = (U*T + G1)*T + G0
      V = (((((((((H10*T + H9)*T + H8)*T + H7)*T + H6)*T +
     *             H5)*T + H4)*T + H3)*T + H2)*T + H1)*T + 1.D0
C
C          THE ABOVE FOUR MINIMAX APPROXIMATIONS U/V
C          ARE ACCURATE TO WITHIN 1 UNIT OF THE 25-TH
C          SIGNIFICANT DIGIT. THUS, THE APPROXIMATION
C          FOR W IS ACCURATE TO WITHIN 1 UNIT OF THE
C          29-TH SIGNIFICANT DIGIT.
C
   40 W = ((((((U/V)*T + S5)*T + S4)*T + S3)*T + S2)*T +
     *                   S1)*T + S0
      DPDAW0 = 0.5D0 + W
      RETURN
C
C                          X .GE. 12
C
   50 T = (1.D0/X)**2
      W = (((((P5*T + P4)*T + P3)*T + P2)*T + P1)*T + P0)/
     *    (((((Q5*T + Q4)*T + Q3)*T + Q2)*T + Q1)*T + 1.D0)
      W = ((((W*T + 6.5625D0)*T + 1.875D0)*T + 0.75D0)*T +
     *        0.5D0)*T + 1.D0
      DPDAW0 = 0.5D0*W
      RETURN
      END
      SUBROUTINE CFRNLI (MO, Z, W)
C-----------------------------------------------------------------------
C
C            COMPUTATION OF THE COMPLEX FRESNEL INTEGRAL E(Z)
C
C                           ----------------
C
C                      W = E(Z)          IF MO = 0
C                      W = EXP(-Z)*E(Z)  OTHERWISE
C
C-----------------------------------------------------------------------
      COMPLEX Z, W
      REAL CD(18), CE(18), QF(2), SM(2), TM(2), TS(2), ZR(2)
C------------------------
C     C = 1/SQRT(PI)
C     C0 = -1/SQRT(2)
C------------------------
      DATA C  / .564189583547756/
      DATA C0 /-.707106781186548/
C------------------------
      DATA CD(1) /0.00000000000000E00/,  CD(2) /2.08605856013476E-2/,
     1     CD(3) /8.29806940495687E-2/,  CD(4) /1.85421653326079E-1/,
     2     CD(5) /3.27963479382361E-1/,  CD(6) /5.12675279912828E-1/,
     3     CD(7) /7.45412958045105E-1/,  CD(8) /1.03695067418297E00/,
     4     CD(9) /1.40378061255437E00/,  CD(10)/1.86891662214001E00/,
     5     CD(11)/2.46314830523929E00/,  CD(12)/3.22719383737352E00/,
     6     CD(13)/4.21534348280013E00/,  CD(14)/5.50178873151549E00/,
     7     CD(15)/7.19258966683102E00/,  CD(16)/9.45170208076408E00/,
     8     CD(17)/1.25710718314784E+1/,  CD(18)/1.72483537216334E+1/
      DATA CE(1) /8.15723083324096E-2/,  CE(2) /1.59285285253437E-1/,
     1     CE(3) /1.48581625614499E-1/,  CE(4) /1.33219670836245E-1/,
     2     CE(5) /1.15690392878957E-1/,  CE(6) /9.78580959447535E-2/,
     3     CE(7) /8.05908834297624E-2/,  CE(8) /6.40204538609872E-2/,
     4     CE(9) /4.81445242767885E-2/,  CE(10)/3.33540658473295E-2/,
     5     CE(11)/2.05548099470193E-2/,  CE(12)/1.07847403887506E-2/,
     6     CE(13)/4.55634892214219E-3/,  CE(14)/1.43984458138925E-3/,
     7     CE(15)/3.07056139834171E-4/,  CE(16)/3.78156541168541E-5/,
     8     CE(17)/2.05173509616121E-6/,  CE(18)/2.63564823682747E-8/
C------------------------
      X = REAL(Z)
      Y = AIMAG(Z)
      R = CPABS(X, Y)
      IF (R .EQ. 0.0) GO TO 200
C
C              EVALUATION OF ZR = SQRT(2*Z/PI)
C
      IF (X .GE. 0.0) GO TO 10
         ZR(2) = SQRT(R - X)
         ZR(1) = Y/ZR(2)
         GO TO 11
   10 ZR(1) = SQRT(R + X)
      IF (Y .LT. 0.0) ZR(1) = -ZR(1)
      ZR(2) = Y/ZR(1)
   11 ZR(1) = C*ZR(1)
      ZR(2) = C*ZR(2)
C
      IF (R .LE. 1.0) GO TO 20
      IF (R .GE. 38.0) GO TO 60
      IF (X .LT. 0.016*Y*Y) GO TO 50
C
C                       TAYLOR SERIES
C
   20 SM(1) = 0.0
      SM(2) = 0.0
      TM(1) = ZR(1)
      TM(2) = ZR(2)
      PM = 0.0
   30    PM = PM + 1.0
         DM = 2.0*PM + 1.0
         TS(1) = TM(1)*X - TM(2)*Y
         TS(2) = TM(1)*Y + TM(2)*X
         TM(1) = TS(1)/PM
         TM(2) = TS(2)/PM
         TS(1) = TM(1)/DM
         TS(2) = TM(2)/DM
         IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 31
         IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 40
   31    SM(1) = SM(1) + TS(1)
         SM(2) = SM(2) + TS(2)
         GO TO 30
   40 SM(1) = ZR(1) + SM(1)
      SM(2) = (C0 + ZR(2)) + SM(2)
C
      IF (MO .EQ. 0) GO TO 120
      QM = EXP(-X)
      QF(1) = QM*COS(-Y)
      QF(2) = QM*SIN(-Y)
      GO TO 110
C
C              RATIONAL FUNCTION APPROXIMATION
C
   50 SM(1) = 0.0
      SM(2) = 0.0
      DO 51 I = 1,18
         TS(1) = X - CD(I)
         TS(2) = Y
         SS = TS(1)*TS(1) + TS(2)*TS(2)
         TM(1) =  CE(I)*TS(1)/SS
         TM(2) = -CE(I)*TS(2)/SS
         SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
   51 CONTINUE
      TS(1) = ZR(1)*SM(1) - ZR(2)*SM(2)
      TS(2) = ZR(1)*SM(2) + ZR(2)*SM(1)
      SM(1) = 0.5*TS(1)
      SM(2) = 0.5*TS(2)
      GO TO 100
C
C                   ASYMPTOTIC EXPANSION
C
   60 QF(1) = (X/R)/R
      QF(2) = -(Y/R)/R
      TM(1) = QF(1)
      TM(2) = QF(2)
      SM(1) = TM(1)
      SM(2) = TM(2)
      PM = -0.5
   70    PM = PM + 1.0
         TS(1) = TM(1)*QF(1) - TM(2)*QF(2)
         TS(2) = TM(1)*QF(2) + TM(2)*QF(1)
         TM(1) = PM*TS(1)
         TM(2) = PM*TS(2)
         IF (ABS(SM(1)) + ABS(TM(1)) .NE. ABS(SM(1))) GO TO 71
         IF (ABS(SM(2)) + ABS(TM(2)) .EQ. ABS(SM(2))) GO TO 80
   71    SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
         IF (PM .LT. 25.5) GO TO 70
   80 TS(1) = ZR(1)*SM(1) - ZR(2)*SM(2)
      TS(2) = ZR(1)*SM(2) + ZR(2)*SM(1)
      SM(1) = 0.5*TS(1)
      SM(2) = 0.5*TS(2)
      IF (ZR(2) .LT. 8.E-3) GO TO 210
C
C                       TERMINATION
C
  100 IF (MO .NE. 0) GO TO 120
      QM = EXP(X)
      QF(1) = QM*COS(Y)
      QF(2) = QM*SIN(Y)
C
  110 TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      SM(1) = TS(1)
      SM(2) = TS(2)
C
  120 W = CMPLX(SM(1),SM(2))
      RETURN
C
C                      CASE WHEN Z = 0
C
  200 W = CMPLX(0.0,C0)
      RETURN
C
C               MODIFIED ASYMPTOTIC EXPANSION
C
  210 IF (MO .NE. 0) GO TO 220
      QM = EXP(X)
      QF(1) = QM*COS(Y)
      QF(2) = QM*SIN(Y)
      TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      W = CMPLX(TS(1), C0 + TS(2))
      RETURN
C
  220 IF (-X .LE. EXPARG(1)) GO TO 120
      QM = C0*EXP(-X)
      SM(1) = SM(1) + QM*SIN(Y)
      SM(2) = SM(2) + QM*COS(Y)
      W = CMPLX(SM(1),SM(2))
      RETURN
      END
      SUBROUTINE FRNL (T, C, S)
C-----------------------------------------------------------------------
C             EVALUATION OF THE REAL FRESNEL INTEGRALS
C-----------------------------------------------------------------------
      REAL N
      REAL A(6),B(6),CP(13),SP(13)
      REAL PN(6),PD(6),QN(6),QD(6)
      REAL AN(6),AD(6),BN(6),BD(6)
      REAL CN(5),CD(5),DN(5),DD(5)
      REAL FP(7),GP(7),P(6),Q(6)
C--------------------------
      DATA PI/3.1415926535898/
C--------------------------
      DATA A(1)/-.119278241233760E-05/,  A(2)/.540730666359417E-04/,
     1     A(3)/-.160488306381990E-02/,  A(4)/.281855008757077E-01/,
     2     A(5)/-.246740110027210E+00/,  A(6)/.100000000000000E+01/
      DATA B(1)/-.155653074871090E-06/,  B(2)/.844415353045065E-05/,
     1     B(3)/-.312116934326082E-03/,  B(4)/.724478420395276E-02/,
     2     B(5)/-.922805853580325E-01/,  B(6)/.523598775598300E+00/
C--------------------------
      DATA CP(1) /.114739945188034E-20/,  CP(2) /-.384444827287950E-18/,
     1     CP(3) /.832125729394275E-16/,  CP(4) /-.142979507360076E-13/,
     2     CP(5) /.198954961821465E-11/,  CP(6) /-.220226545457144E-09/,
     3     CP(7) /.188434924092257E-07/,  CP(8) /-.120009722914157E-05/,
     4     CP(9) /.540741337442140E-04/,  CP(10)/-.160488313553028E-02/,
     5     CP(11)/.281855008777956E-01/,  CP(12)/-.246740110027196E+00/,
     6     CP(13)/.999999999999996E+00/
      DATA SP(1) /.705700784853927E-22/,  SP(2) /-.252757991492418E-19/,
     1     SP(3) /.594117488940008E-17/,  SP(4) /-.112161631555448E-14/,
     2     SP(5) /.173332189994074E-12/,  SP(6) /-.215742302078015E-10/,
     3     SP(7) /.210821173208116E-08/,  SP(8) /-.156471443116560E-06/,
     4     SP(9) /.844427287845253E-05/,  SP(10)/-.312116942346186E-03/,
     5     SP(11)/.724478420418951E-02/,  SP(12)/-.922805853580323E-01/,
     6     SP(13)/.523598775598300E+00/
C--------------------------
      DATA PN(1)/.318309816100920E+00/,  PN(2)/.134919391391516E+02/,
     1     PN(3)/.158258097490377E+03/,  PN(4)/.598796451682535E+03/,
     2     PN(5)/.632369782194966E+03/,  PN(6)/.967985390141920E+02/
      DATA PD(1)/.100000000000000E+01/,  PD(2)/.426900960480796E+02/,
     1     PD(3)/.509085485682426E+03/,  PD(4)/.200034664144742E+04/,
     2     PD(5)/.231910140792937E+04/,  PD(6)/.486678558201084E+03/
      DATA QN(1)/.101320876178478E+00/,  QN(2)/.490534697099052E+01/,
     1     QN(3)/.652095157811808E+02/,  QN(4)/.274183825747887E+03/,
     2     QN(5)/.305040725009211E+03/,  QN(6)/.364566615872326E+02/
      DATA QD(1)/.100000000000000E+01/,  QD(2)/.499330024470621E+02/,
     1     QD(3)/.709854097670206E+03/,  QD(4)/.343470762861172E+04/,
     2     QD(5)/.522213879312684E+04/,  QD(6)/.168801831831851E+04/
C--------------------------
      DATA AN(1)/.318309885869756E+00/,  AN(2)/.254179177393500E+02/,
     1     AN(3)/.575003792540838E+03/,  AN(4)/.426673405867140E+04/,
     2     AN(5)/.891831887923938E+04/,  AN(6)/.267955736537967E+04/
      DATA AD(1)/.100000000000000E+01/,  AD(2)/.801567066285184E+02/,
     1     AD(3)/.182971463354850E+04/,  AD(4)/.138848884373420E+05/,
     2     AD(5)/.309228411873207E+05/,  AD(6)/.120421274105856E+05/
      DATA BN(1)/.101321181932417E+00/,  BN(2)/.925021984290547E+01/,
     1     BN(3)/.240932023056602E+03/,  BN(4)/.206079616836437E+04/,
     2     BN(5)/.484901973010149E+04/,  BN(6)/.130680669688315E+04/
      DATA BD(1)/.100000000000000E+01/,  BD(2)/.928158182389149E+02/,
     1     BD(3)/.250926840439955E+04/,  BD(4)/.233924458152954E+05/,
     2     BD(5)/.685638896406835E+05/,  BD(6)/.418593101455019E+05/
C--------------------------
      DATA CN(1)/.318309886182000E+00/,  CN(2)/.299191968327887E+02/,
     1     CN(3)/.691428839605668E+03/,  CN(4)/.394539800974744E+04/,
     2     CN(5)/.290314254767015E+04/
      DATA CD(1)/.100000000000000E+01/,  CD(2)/.942978925136851E+02/,
     1     CD(3)/.219977296283666E+04/,  CD(4)/.129726479671006E+05/,
     2     CD(5)/.114991427758165E+05/
      DATA DN(1)/.101321183630876E+00/,  DN(2)/.110988033615242E+02/,
     1     DN(3)/.306282306497228E+03/,  DN(4)/.213130259794164E+04/,
     2     DN(5)/.171270676541694E+04/
      DATA DD(1)/.100000000000000E+01/,  DD(2)/.111060616085627E+03/,
     1     DD(3)/.318197586347414E+04/,  DD(4)/.249342095714049E+05/,
     2     DD(5)/.359241903823488E+05/
C--------------------------
      DATA FP(1)/.449763389301234E+05/,  FP(2)/-.188763642051836E+04/,
     1     FP(3)/.669261097103246E+02/,  FP(4)/-.343966606879114E+01/,
     2     FP(5)/.343112896133346E+00/,  FP(6)/-.967546019461500E-01/,
     3     FP(7)/.318309886183465E+00/
      DATA GP(1)/.316642183365360E+06/,  GP(2)/-.120618995106638E+05/,
     1     GP(3)/.359164749179351E+03/,  GP(4)/-.142252603258172E+02/,
     2     GP(5)/.982934118445454E+00/,  GP(6)/-.153989722912325E+00/,
     3     GP(7)/.101321183639714E+00/
C--------------------------
      DATA P(1)/-654729075.0/,  P(2)/2027025.0/,  P(3)/-10395.0/,
     1     P(4)/105.0/,  P(5)/-3.0/,  P(6)/1.0/
      DATA Q(1)/-13749310575.0/,  Q(2)/34459425.0/,  Q(3)/-135135.0/,
     1     Q(4)/945.0/,  Q(5)/-15.0/,  Q(6)/1.0/
C--------------------------
C
C     ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE
C            LARGEST POSITIVE INTEGER THAT MAY BE USED.
C
                     MAX = IPMPAR(3)
C
C-----------------------------------------------------------------------
      X = ABS(T)
      IF (X .GT. 4.0) GO TO 50
      XX = X*X
      Y = XX*XX
C-----------------------------------------------------------------------
C             EVALUATION OF C(X) AND S(X) FOR X .LT. 1.65
C                          WHERE X = ABS(T)
C-----------------------------------------------------------------------
      IF (X .GT. 0.6) GO TO 10
      C = ((((A(1)*Y + A(2))*Y + A(3))*Y + A(4))*Y + A(5))*Y + A(6)
      S = ((((B(1)*Y + B(2))*Y + B(3))*Y + B(4))*Y + B(5))*Y + B(6)
      C = T*C
      S = T*XX*S
      RETURN
C
   10 IF (X .GE. 1.65) GO TO 20
      C = CP(1)
      S = SP(1)
      DO 11 I = 2,13
         C = CP(I) + C*Y
   11    S = SP(I) + S*Y
      C = T*C
      S = T*XX*S
      RETURN
C-----------------------------------------------------------------------
C          EVALUATION OF THE AUXILIARY FUNCTIONS F(X) AND G(X)
C                        FOR X .GE. 1.65
C-----------------------------------------------------------------------
   20 IF (X .GE. 2.0) GO TO 30
      FN = ((((PN(1)*Y + PN(2))*Y + PN(3))*Y + PN(4))*Y + PN(5))*Y
     *                 + PN(6)
      FD = ((((PD(1)*Y + PD(2))*Y + PD(3))*Y + PD(4))*Y + PD(5))*Y
     *                 + PD(6)
      GN = ((((QN(1)*Y + QN(2))*Y + QN(3))*Y + QN(4))*Y + QN(5))*Y
     *                 + QN(6)
      GD = ((((QD(1)*Y + QD(2))*Y + QD(3))*Y + QD(4))*Y + QD(5))*Y
     *                 + QD(6)
      F = FN/(X*FD)
      G = GN/(X*XX*GD)
      Y = 0.5*XX
      GO TO 80
C
   30 IF (X .GE. 3.0) GO TO 40
      FN = ((((AN(1)*Y + AN(2))*Y + AN(3))*Y + AN(4))*Y + AN(5))*Y
     *                 + AN(6)
      FD = ((((AD(1)*Y + AD(2))*Y + AD(3))*Y + AD(4))*Y + AD(5))*Y
     *                 + AD(6)
      GN = ((((BN(1)*Y + BN(2))*Y + BN(3))*Y + BN(4))*Y + BN(5))*Y
     *                 + BN(6)
      GD = ((((BD(1)*Y + BD(2))*Y + BD(3))*Y + BD(4))*Y + BD(5))*Y
     *                 + BD(6)
      F = FN/(X*FD)
      G = GN/(X*XX*GD)
      GO TO 70
C
   40 FN = (((CN(1)*Y + CN(2))*Y + CN(3))*Y + CN(4))*Y + CN(5)
      FD = (((CD(1)*Y + CD(2))*Y + CD(3))*Y + CD(4))*Y + CD(5)
      GN = (((DN(1)*Y + DN(2))*Y + DN(3))*Y + DN(4))*Y + DN(5)
      GD = (((DD(1)*Y + DD(2))*Y + DD(3))*Y + DD(4))*Y + DD(5)
      F = FN/(X*FD)
      G = GN/(X*XX*GD)
      GO TO 70
C
   50 IF (X .GE. 6.0) GO TO 60
      XX = X*X
      Y = 1.0/(XX*XX)
      F = (((((FP(1)*Y + FP(2))*Y + FP(3))*Y + FP(4))*Y + FP(5))*Y
     *                 + FP(6))*Y + FP(7)
      G = (((((GP(1)*Y + GP(2))*Y + GP(3))*Y + GP(4))*Y + GP(5))*Y
     *                 + GP(6))*Y + GP(7)
      F = F/X
      G = G/(X*XX)
      GO TO 70
C
   60 IF (X .GE. FLOAT(MAX)) GO TO 100
      PIX = PI*X
      PIXX = PIX*X
      Y = 1.0/PIXX
      Y = Y*Y
      F = ((((P(1)*Y + P(2))*Y + P(3))*Y + P(4))*Y + P(5))*Y + P(6)
      G = ((((Q(1)*Y + Q(2))*Y + Q(3))*Y + Q(4))*Y + Q(5))*Y + Q(6)
      F = F/PIX
      G = G/(PIX*PIXX)
C-----------------------------------------------------------------------
C           EVALUATION OF SIN(0.5*PI*X*X) AND COS(0.5*PI*X*X)
C                 THE RESULTS ARE STORED IN SY AND CY
C-----------------------------------------------------------------------
   70 M = X
      L = MOD(M,2)
      N = M - L
      Y = X - M
      R = X - N
C
      Y = Y*N
      M = Y
      Y = Y - M
      IF (MOD(M,2) .NE. 0) Y = (Y - 0.5) - 0.5
      Y = Y + 0.5*R*R
C
   80 SY = SIN1(Y)
      CY = COS1(Y)
C-----------------------------------------------------------------------
C                             TERMINATION
C-----------------------------------------------------------------------
   90 C = 0.5 + (F*SY - G*CY)
      S = 0.5 - (F*CY + G*SY)
      IF (T .GE. 0.0) RETURN
         C = - C
         S = - S
         RETURN
C
  100 IF (T .LT. 0.0) GO TO 110
         C = 0.5
         S = 0.5
         RETURN
  110 C = -0.5
      S = -0.5
      RETURN
      END
      SUBROUTINE CEXPLI (MO, Z, W)
C-----------------------------------------------------------------------
C           EVALUATION OF THE COMPLEX EXPONENTIAL INTEGRAL
C-----------------------------------------------------------------------
      COMPLEX Z, W
      REAL N, NP1
      REAL CD(18), CE(18)
      REAL QF(2), SM(2), TM(2), TS(2)
      REAL G0(2), GN(2), H0(2), HN(2), WN(2)
      LOGICAL IND
C-------------------------
      ANORM(X,Y) = AMAX1(ABS(X),ABS(Y))
C-------------------------
      DATA PI /3.14159265358979/
      DATA EULER /.577215664901533/
C-------------------------
      DATA CD(1)  /0.00000000000000E+00/, CD(2)  /.311105957086528E-01/,
     *     CD(3)  /.103661260539112E+00/, CD(4)  /.216532335244554E+00/,
     *     CD(5)  /.369931427960192E+00/, CD(6)  /.566766259990589E+00/,
     *     CD(7)  /.814042066324748E+00/, CD(8)  /.112384247540813E+01/,
     *     CD(9)  /.151400478148512E+01/, CD(10) /.200886795032284E+01/,
     *     CD(11) /.264052411823592E+01/, CD(12) /.345098449933392E+01/,
     *     CD(13) /.449583360763202E+01/, CD(14) /.585058263409822E+01/,
     *     CD(15) /.762273501463380E+01/, CD(16) /.997814501584578E+01/,
     *     CD(17) /.132122064896408E+02/, CD(18) /.180322948376021E+02/
      DATA CE(1)  /.850156516121093E-02/, CE(2)  /.505037465849058E-01/,
     *     CE(3)  /.836817368956407E-01/, CE(4)  /.107047582417607E+00/,
     *     CE(5)  /.120424719029462E+00/, CE(6)  /.125096631582229E+00/,
     *     CE(7)  /.122314435224685E+00/, CE(8)  /.112621417553907E+00/,
     *     CE(9)  /.963419407392582E-01/, CE(10) /.747398422757511E-01/,
     *     CE(11) /.508596135953441E-01/, CE(12) /.290822706773628E-01/,
     *     CE(13) /.132201640530101E-01/, CE(14) /.443802939829067E-02/,
     *     CE(15) /.992612478987576E-03/, CE(16) /.126579795112011E-03/,
     *     CE(17) /.702150908253350E-05/, CE(18) /.910281532564632E-07/
C-------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0.
C
                      EPS = SPMPAR(1)
C
C-------------------------
C
      X = REAL(Z)
      Y = AIMAG(Z)
      R = CPABS(X,Y)
      EPS = AMAX1(EPS,1.E-15)
C
      IF (R .LE. 1.0) GO TO 20
      IF (R .GE. 40.0) GO TO 60
      IF (R .LT. 4.0) GO TO 10
         IF (X .LE. 0.0 .OR. ABS(Y) .GT. 8.0) GO TO 60
         IF (R .LT. 10.0 .AND. ABS(Y) .GT. 1.8*X) GO TO 60
         GO TO 20
   10 IF (X .LT. 0.09*Y*Y) GO TO 50
      IF (R .GT. 3.6 .AND. ABS(Y) .GT. 1.8*X) GO TO 60
C
C                        TAYLOR SERIES
C
   20 SM(1) = 0.0
      SM(2) = 0.0
      TM(1) = X
      TM(2) = Y
      N = 1.0
   30    N = N + 1.0
         TS(1) = TM(1)*X - TM(2)*Y
         TS(2) = TM(1)*Y + TM(2)*X
         TM(1) = TS(1)/N
         TM(2) = TS(2)/N
         TS(1) = TM(1)/N
         TS(2) = TM(2)/N
         SM(1) = SM(1) + TS(1)
         SM(2) = SM(2) + TS(2)
         IF (ANORM(TS(1),TS(2)) .GT. EPS*ANORM(SM(1),SM(2)))
     *        GO TO 30
      SM(1) = X + SM(1)
      SM(2) = Y + SM(2)
C
      SM(1) = (EULER + ALOG(R)) + SM(1)
      SM(2) = ATAN2(-Y, -X) + SM(2)
      GO TO 110
C
C                      RATIONAL EXPANSION
C
   50 SM(1) = 0.0
      SM(2) = 0.0
      DO 51 I = 1,18
         TS(1) = X - CD(I)
         TS(2) = Y
         SS = TS(1)*TS(1) + TS(2)*TS(2)
         SM(1) = SM(1) + CE(I)*TS(1)/SS
         SM(2) = SM(2) - CE(I)*TS(2)/SS
   51 CONTINUE
      GO TO 100
C
C         PADE APPROXIMATION FOR THE ASYMPTOTIC EXPANSION
C                       FOR EXP(-Z)*EI(Z)
C
   60 X = - X
      Y = - Y
      D = 4.0*R
      IF (R .LT. 10.0) D = 32.0
      G0(1) = 1.0
      G0(2) = 0.0
      GN(1) = (1.0 + X)/D
      GN(2) = Y/D
      H0(1) = 1.0
      H0(2) = 0.0
      U = X + 2.0
      HN(1) = U/D
      HN(2) = GN(2)
      W = CMPLX(1.0 + X, Y)/CMPLX(U,Y)
      WN(1) = REAL(W)
      WN(2) = AIMAG(W)
      NP1 = 1.0
      TOL = 4.0*EPS
C
   70    N = NP1
         NP1 = N + 1.0
         E = (N*NP1)/D
         U = U + 2.0
         TM(1) = ((U*GN(1) - Y*GN(2)) - E*G0(1))/D
         TM(2) = ((U*GN(2) + Y*GN(1)) - E*G0(2))/D
         G0(1) = GN(1)
         G0(2) = GN(2)
         GN(1) = TM(1)
         GN(2) = TM(2)
         TM(1) = ((U*HN(1) - Y*HN(2)) - E*H0(1))/D
         TM(2) = ((U*HN(2) + Y*HN(1)) - E*H0(2))/D
         H0(1) = HN(1)
         H0(2) = HN(2)
         HN(1) = TM(1)
         HN(2) = TM(2)
C
         TM(1) = WN(1)
         TM(2) = WN(2)
         W = CMPLX(GN(1),GN(2))/CMPLX(HN(1),HN(2))
         WN(1) = REAL(W)
         WN(2) = AIMAG(W)
         IF (ANORM(TM(1) - WN(1), TM(2) - WN(2)) .GT.
     *         TOL*ANORM(WN(1), WN(2))) GO TO 70
C
      X = REAL(Z)
      Y = AIMAG(Z)
      W = W/Z
      SM(1) = REAL(W)
      SM(2) = AIMAG(W)
C
C                         TERMINATION
C
  100 IND = X .LE. 0.0 .OR. ABS(Y) .GT. 1.E-2
      IF (IND .AND. MO .NE. 0) GO TO 130
      C = PI
      IF (Y .GT. 0.0) C = -PI
      QM = EXP(X)
      CY = COS(Y)
      SY = SIN(Y)
      QF(1) = QM*CY
      QF(2) = QM*SY
      IF (MO .EQ. 0) GO TO 120
C
      R = C/QM
      SM(1) = SM(1) + R*SY
      SM(2) = SM(2) + R*CY
      GO TO 130
C
  110 IF (MO .EQ. 0) GO TO 130
      IND = .TRUE.
      QM = EXP(-X)
      QF(1) = QM*COS(-Y)
      QF(2) = QM*SIN(-Y)
C
  120 TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      SM(1) = TS(1)
      SM(2) = TS(2)
      IF (.NOT. IND) SM(2) = SM(2) + C
C
  130 W = CMPLX(SM(1),SM(2))
      RETURN
      END
      SUBROUTINE EXPLI(INT,ARG,RESULT,IERR)
C
      REAL A(6),B(5),C(7),D(7),E(7),F(7),P1(8),Q1(8),P2(8),Q2(7),
     1        P3(8),Q3(7),P4(8),Q4(7),R(20),PX(9),QX(9),
     2        FRAC,SUMP,SUMQ,T,W,X,X0,XX0,XMX0,Y,DEXP40,XMAX,
     3        XMIN,EI,ARG,RESULT,EXPARG
      INTEGER I,INT,IERR
      DOUBLE PRECISION DX0
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE COMPUTES THE EXPONENTIAL INTEGRALS
C
C            EI(X),  E-SUB-1(X) = -EI(-X),  AND  EXP(-X)*EI(X)
C
C     WHERE
C
C             INTEGRAL (FROM T=-INFINITY TO T=X) (EXP(T)/T),  X .GT. 0,
C     EI(X) =
C             -INTEGRAL (FROM T=-X TO T=INFINITY) (EXP(-T)/T),
C                                                         X .LT. 0,
C
C     AND WHERE THE FIRST INTEGRAL IS A PRINCIPAL VALUE INTEGRAL. THE
C     ARGUMENTS INT, ARG, AND RESULT HAVE THE FOLLOWING USAGE ...
C
C            INT              ARG             RESULT
C             1            X .NE. 0          EI(X)
C             2            X .GT. 0          E-SUB-1(X)
C             3            X .NE. 0          EXP(-X)*EI(X)
C
C     THE EXPANSION FOR 4 .LE. X .LE. 8 IS DUE TO WAYNE FULLERTON (LOS
C     ALAMOS). THE REMAINING EXPANSIONS ARE FROM MATH. COMP. 22, 641-649
C     (1968), AND MATH. COMP. 23, 289-303(1969) BY CODY AND THACHER.
C
C        ------------
C
C     ERROR MONITORING
C
C        THE PARAMETER IERR IS A VARIABLE THAT IS SET BY THE ROUTINE.
C     IF NO ERRORS ARE DETECTED THEN IERR IS SET TO 0. THE FOLLOWING
C     TABLE INDICATES THE TYPES OF ERRORS THAT MAY BE ENCOUNTERED IN
C     THE ROUTINE AND THE FUNCTION VALUES SUPPLIED IN EACH CASE.
C
C     IERR    ERROR     ARGUMENT          FUNCTION VALUES FOR
C                        RANGE        EI(X)  EXP(-X)*EI(X)  E-SUB-1(X)
C      1    UNDERFLOW   X .LT. XMIN     0          -          0
C      2    OVERFLOW    X .GT. XMAX     T          -          -
C      3    ILLEGAL X     X = 0         T          T          T
C      4    ILLEGAL X    X .LT. 0       -          -          T
C
C     T INDICATES THAT THE ROUTINE TERMINATES WITHOUT ASSIGNING A VALUE
C     TO THE FUNCTION.
C
C        ----------
C
C     THIS SUBROUTINE WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR
C     THE FUNPACK PACKAGE OF SPECIAL FUNCTION SUBROUTINES. THE ROUTINE
C     WAS MODIFIED BY BY A.H. MORRIS (NSWC).
C
C-----------------------------------------------------------------------
C
C     XMAX AND XMIN ARE MACHINE DEPENDENT CONSTANTS FOR DETECTING
C     UNDERFLOW AND OVERFLOW. XMAX AND XMIN ARE GIVEN APPROXIMATE
C     VALUES IN STATEMENTS 240 AND 340.
C
C-----------------------------------------------------------------------
C
C     VALUE OF EXP(40.0)
C
C     ----------
      DATA DEXP40/.235385266837020E+18/
C     ----------
C
C     ZERO OF EI(X)
C
C     ----------
      DATA X0/.372507410781366/,DX0/.37250741078136663446199186658D0/
C     ----------
C
C     COEFFICIENTS FOR R(5,4) APPROXIMATION,
C     USED FOR -1.0 .LE. X .LT. 0.0
C
C     ----------
      DATA A(1)/-.577215664901531E+00/, A(2) /.758833087029943E+00/,
     *     A(3) /.125660818982053E+00/, A(4) /.204158408934305E-01/,
     *     A(5) /.825035122466538E-03/, A(6) /.962949813453924E-05/
      DATA B(1) /.100000000000000E+01/, B(2) /.417810755380398E+00/,
     *     B(3) /.730228560396799E-01/, B(4) /.642720224671078E-02/,
     *     B(5) /.245134203588369E-03/
C     ----------
C
C     COEFFICIENTS FOR R(6,6) APPROXIMATION,
C     USED FOR -4.0 .LE. X .LT. -1.0
C
C     ----------
      DATA C(1) /.465627107975096E-06/, C(2) /.999979577051595E+00/,
     *     C(3) /.904161556946328E+01/, C(4) /.243784088791317E+02/,
     *     C(5) /.230192559391334E+02/, C(6) /.690522522784443E+01/,
     *     C(7) /.430967839469389E+00/
      DATA D(1) /.100000000000000E+01/, D(2) /.100411643829054E+02/,
     *     D(3) /.324264210695138E+02/, D(4) /.412807841891424E+02/,
     *     D(5) /.204494785013794E+02/, D(6) /.331909213593302E+01/,
     *     D(7) /.103400130404874E+00/
C     ----------
C
C     COEFFICIENTS FOR R(6,6) APPROXIMATION,
C     USED FOR X .LT. -4.0
C
C     ----------
      DATA E(1)/-.999999999998447E+00/, E(2)/-.266271060431811E+02/,
     *     E(3)/-.241055827097015E+03/, E(4)/-.895927957772937E+03/,
     *     E(5)/-.129885688746484E+04/, E(6)/-.545374158883133E+03/,
     *     E(7)/-.566575206533869E+01/
      DATA F(1) /.100000000000000E+01/, F(2) /.286271060422192E+02/,
     *     F(3) /.292310039388533E+03/, F(4) /.133278537748257E+04/,
     *     F(5) /.277761949509163E+04/, F(6) /.240401713225909E+04/,
     *     F(7) /.631657483280800E+03/
C     ----------
C
C     COEFFICIENTS FOR R(7,7) APPROXIMATION,
C     IN CHEBYSHEV POLYNOMIAL FORM, USED FOR
C     0.0 .LT. X .LT. 4.0
C
C     ----------
      DATA P1(1)/-.866937339951070E+01/, P1(2)/-.549142265521085E+03/,
     *     P1(3)/-.421001615357070E+04/, P1(4)/-.249301393458648E+06/,
     *     P1(5)/-.119623669349247E+06/, P1(6)/-.221744627758845E+08/,
     *     P1(7) /.389280421311201E+07/, P1(8)/-.195773036904548E+09/
      DATA Q1(1) /.341718750000000E+02/, Q1(2)/-.160708926587221E+04/,
     *     Q1(3) /.357300298058508E+05/, Q1(4)/-.483547436162164E+06/,
     *     Q1(5) /.428559624611749E+07/, Q1(6)/-.249033375740540E+08/,
     *     Q1(7) /.891925767575612E+08/, Q1(8)/-.826271498626055E+08/
C     ----------
C
C     COEFFICIENTS FOR CHEBYSHEV EXPANSION FOR
C     4.0 .LE. X .LE. 8.0
C
C     ----------
      DATA R(1) / .636295897967470E+00/, R(2) /-.130811686750676E+00/,
     *     R(3) /-.843674102130539E-02/, R(4) / .265684915310067E-02/,
     *     R(5) / .328227217816581E-03/, R(6) /-.237834477714302E-04/,
     *     R(7) /-.114398043081001E-04/, R(8) /-.144059434332383E-05/,
     *     R(9) / .524159566511488E-08/, R(10)/ .384073064078443E-07/,
     *     R(11)/ .858802448602672E-08/, R(12)/ .102192266258550E-08/,
     *     R(13)/ .217491323232897E-10/, R(14)/-.220902381426231E-10/,
     *     R(15)/-.634575335449288E-11/, R(16)/-.108377465668577E-11/,
     *     R(17)/-.119098228722226E-12/, R(18)/-.284386823892656E-14/,
     *     R(19)/ .250803270266868E-14/, R(20)/ .787296415285598E-15/
C
C     COEFFICIENTS FOR R(7,7) APPROXIMATION,
C     IN J-FRACTION FORM, USED FOR
C     8.0 .LT. X .LT. 12.0
C
C     ----------
      DATA P2(1)/-.218086381520723E+01/, P2(2)/-.219010233854881E+02/,
     *     P2(3)/ .930816385662165E+01/, P2(4) /.250762811293560E+02/,
     *     P2(5)/-.331842531997221E+02/, P2(6) /.601217990830080E+02/,
     *     P2(7)/-.432531132878135E+02/, P2(8) /.100443109228078E+01/
      DATA Q2(1)/ .393707701852715E+01/, Q2(2) /.300892648372915E+03/,
     *     Q2(3)/-.625041161671876E+01/, Q2(4) /.100367439516726E+04/,
     *     Q2(5)/ .143256738121938E+02/, Q2(6) /.273624119889328E+04/,
     *     Q2(7)/ .527468851962908E+00/
C     ----------
C
C     COEFFICIENTS FOR R(7,7) APPROXIMATION,
C     IN J-FRACTION FORM, USED FOR
C     12.0 .LE. X .LT. 24.0
C
C     ----------
      DATA P3(1)/-.348334653602852E+01/, P3(2)/-.186545454883399E+02/,
     *     P3(3)/-.828561994140641E+01/, P3(4)/-.323467330305403E+02/,
     *     P3(5)/ .179601688769252E+02/, P3(6) /.175656315469614E+01/,
     *     P3(7)/-.195022321289660E+01/, P3(8) /.999994296074708E+00/
      DATA Q3(1) /.695000655887434E+02/, Q3(2) /.572837193837324E+02/,
     *     Q3(3) /.257776384238440E+02/, Q3(4) /.760761148007735E+03/,
     *     Q3(5) /.289516727925135E+02/, Q3(6)/-.343942266899870E+01/,
     *     Q3(7) /.100083867402639E+01/
C     ----------
C
C     COEFFICIENTS FOR R(7.7) APPROXIMATION,
C     IN J-FRACTION FORM, USED FOR X .GE. 24.0
C
C     ----------
      DATA P4(1)/-.531686623494482E+02/, P4(2)/ .891263822573708E+01/,
     *     P4(3)/-.139381360364405E+01/, P4(4)/-.308336269051763E+02/,
     *     P4(5)/-.749289167792884E+01/, P4(6)/-.500140345515924E+01/,
     *     P4(7)/-.300000016782086E+01/, P4(8)/ .100000000000058E+01/
      DATA Q4(1)/ .104745362652468E+04/, Q4(2)/-.674704580465832E+01/,
     *     Q4(3)/ .295999399486831E+03/, Q4(4)/-.431325836146628E+01/,
     *     Q4(5)/-.790404992298926E+01/, Q4(6)/-.299996432944446E+01/,
     *     Q4(7)/ .199999999924131E+01/
C-----------------------------------------------------------------------
C
      X = ARG
      IERR = 0
      IF (INT .EQ. 2) GO TO 450
      IF (X) 280, 640, 110
  110 IF (X .GE. 12.E0) GO TO 200
      IF (X .GT. 8.E0) GO TO 160
      IF (X .GE. 4.E0) GO TO 150
C     ---------- 0.0 .LT. X .LT. 4.0.
C                RATIONAL APPROXIMATION USED IS EXPRESSED
C                IN TERMS OF CHEBYSHEV POLYNOMIALS TO
C                IMPROVE CONDITIONING  ----------
      T = X + X
      T = T / 3.0E0 - 2.0E0
      PX(1) = 0.0E0
      QX(1) = 0.0E0
      PX(2) = P1(1)
      QX(2) = Q1(1)
C
      DO 120 I = 2, 7
         PX(I+1) = T * PX(I) - PX(I-1) + P1(I)
         QX(I+1) = T * QX(I) - QX(I-1) + Q1(I)
  120 CONTINUE
C
      SUMP = .5E0 * T * PX(8) - PX(7) + P1(8)
      SUMQ = .5E0 * T * QX(8) - QX(7) + Q1(8)
      FRAC = SUMP / SUMQ
      XMX0 = DBLE(X) - DX0
      IF (ABS(XMX0) .LT. 0.07E0) GO TO 140
      XX0 = X / X0
      EI = ALOG(XX0) + XMX0 * FRAC
      IF (INT .EQ. 3) EI = EXP(-X) * EI
      GO TO 410
C     ---------- EVALUATE APPROXIMATION FOR LN(X/X0)
C                FOR X CLOSE TO X0 ----------
  140 Y = XMX0 / X0
      EI = ALNREL(Y) + XMX0 * FRAC
      IF (INT .EQ. 3) EI = EXP(-X) * EI
      GO TO 410
C     ---------- 4.0 .LE. X .LE. 8.0 ----------
  150 M = 20
      EI = (1.0 + CSEVL (3.0 - 16.0/X, R, M)) / X
      IF (INT .EQ. 3) GO TO 410
      EI = EI * EXP(X)
      GO TO 410
C     ---------- 8.0 .LT. X .LT. 12.0 ----------
  160 FRAC = 0.0E0
C
      DO 180 I = 1, 7
  180 FRAC = Q2(I) / (P2(I) + X + FRAC)
C
      EI = (P2(8) + FRAC) / X
      IF (INT .EQ. 3) GO TO 410
      EI = EI * EXP(X)
      GO TO 410
C     ---------- 12.0 .LE. X .LT. 24.0 ----------
  200 IF (X .GE. 24.E0) GO TO 240
      FRAC = 0.0E0
C
      DO 220 I = 1, 7
  220 FRAC = Q3(I) / (P3(I) + X + FRAC)
C
      EI = (P3(8) + FRAC) / X
      IF (INT .EQ. 3) GO TO 410
      EI = EI * EXP(X)
      GO TO 410
C     ---------- 24.0 .LE. X ----------
  240 XMAX = EXPARG(0)
      IF ((X .GT. XMAX) .AND. (INT .LT. 3)) GO TO 620
      Y = 1.0E0 / X
      FRAC = 0.0E0
C
      DO 260 I = 1, 7
  260 FRAC = Q4(I) / (P4(I) + X + FRAC)
C
      FRAC = P4(8) + FRAC
      EI = Y + Y * Y * FRAC
      IF (INT .EQ. 3) GO TO 410
      IF (X .GT. 150.0E0) GO TO 270
      EI = EI * EXP(X)
      GO TO 410
C     ---------- CALCULATION REFORMULATED TO AVOID
C                PREMATURE OVERFLOW ----------
  270 EI = (EI * EXP(X-40.0E0)) * DEXP40
      GO TO 410
C     ---------- ORIGINAL X WAS NEGATIVE.  CALCULATION OF
C                E-SUB-1 JOINS AT LABEL 300 ----------
  280 Y = -X
  300 W = 1.0E0 / Y
      IF (Y .GT. 4.0E0) GO TO 340
      IF (Y .GT. 1.0E0) GO TO 320
C     ---------- 0.0 .LT. -X .LE. 1.0 ----------
      EI = ALOG(Y) - (((((A(6) * Y + A(5)) * Y + A(4))
     1            * Y + A(3)) * Y + A(2)) * Y + A(1)) /
     2       ((((B(5) * Y + B(4)) * Y + B(3))
     3            * Y + B(2)) * Y + B(1))
      IF (INT .EQ. 3) EI = EI * EXP(Y)
      GO TO 400
C     ---------- 1.0 .LT. -X .LE. 4.0 ----------
  320 EI = -((((((C(7) * W + C(6)) * W + C(5)) * W + C(4))
     1          * W + C(3)) * W + C(2)) * W + C(1))  /
     2       ((((((D(7) * W + D(6)) * W + D(5)) * W + D(4))
     3          * W + D(3)) * W + D(2)) * W + D(1))
      IF  (INT .EQ. 3) GO TO 410
      EI = EI * EXP(-Y)
      GO TO 400
C     ---------- 4.0 .LT. -X ----------
  340 XMIN = EXPARG(1)
      IF ((-ABS(X) .LT. XMIN) .AND. (INT .LT. 3)) GO TO 600
      EI = -W * (1.0E0 + W * ((((((E(7)
     1        * W + E(6)) * W + E(5)) * W + E(4))
     2          * W + E(3)) * W + E(2)) * W + E(1)) /
     3       ((((((F(7) * W + F(6)) * W + F(5))
     4          * W + F(4)) * W + F(3)) * W + F(2)) * W + F(1)))
      IF (INT .EQ. 3) GO TO 410
      EI = EI * EXP(-Y)
      T = 0.5E0 * EI
      IF (T .EQ. 0.0E0) GO TO 600
  400 IF (INT .EQ. 2) EI = -EI
  410 RESULT = EI
      RETURN
  450 Y = X
      IF (Y) 660, 640, 300
C     ---------- ERROR RETURN FOR X .LT. XMIN,
C                CAUSING UNDERFLOW ----------
  600 EI = 0.0E0
      IERR = 1
      GO TO 410
C     ---------- ERROR RETURN FOR X .GT. XMAX,
C                CAUSING OVERFLOW ----------
  620 IERR = 2
      RETURN
C     ---------- ERROR RETURN FOR ILLEGAL
C                ARGUMENT, X = 0 ----------
  640 IERR = 3
      RETURN
C     ---------- ERROR RETURN FOR NEGATIVE
C                ARGUMENT IN E-SUB-1 ----------
  660 IERR = 4
      RETURN
      END
      DOUBLE PRECISION FUNCTION DEI (X)
C-----------------------------------------------------------------------
C        DOUBLE PRECISION EVALUATION OF THE EXPONENTIAL INTEGRAL
C-----------------------------------------------------------------------
      DOUBLE PRECISION X
      DOUBLE PRECISION DE1E
C
      DEI = -DE1E(-X)
      IF (X .GT. 4.D0 .OR. X .LT. -1.D0) DEI = DEXP(X) * DEI
      RETURN
      END
      DOUBLE PRECISION FUNCTION DEI1 (X)
C-----------------------------------------------------------------------
C          DOUBLE PRECISION EVALUATION OF EXP(-X)*EI(X)
C-----------------------------------------------------------------------
      DOUBLE PRECISION X
      DOUBLE PRECISION DE1E
C
      DEI1  = -DE1E(-X)
      IF (X .GT. 4.D0 .OR. X .LT. -1.D0) RETURN
      DEI1 = DEXP(-X) * DEI1
      RETURN
      END
      DOUBLE PRECISION FUNCTION DE1E(X)
C-----------------------------------------------------------------------
C
C     LET E1(X) DENOTE THE EXPONENTIAL INTEGRAL FOR POSITIVE X AND
C     THE CAUCHY PRINCIPAL VALUE FOR NEGATIVE X. IF X IS NONZERO
C     THEN DE1E HAS THE VALUE ...
C
C          DE1E(X) = E1(X)          IF -4 .LE. X .LE. 1
C          DE1E(X) = EXP(X)*E1(X)   OTHERWISE
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
C
C     THE FOLLOWING SERIES FOR E1 WERE DEVELOPED BY WAYNE FULLERTON
C     (LOS ALAMOS NATIONAL LABORATORY).
C
C     SERIES A             ON THE INTERVAL -3.12500E-02 TO  0.
C                                        WITH WEIGHTED ERROR   4.62E-32
C                                         LOG WEIGHTED ERROR  31.34
C                               SIGNIFICANT FIGURES REQUIRED  29.70
C                                    DECIMAL PLACES REQUIRED  32.18
C
C
C     SERIES B             ON THE INTERVAL -1.25000E-01 TO -3.12500E-02
C                                        WITH WEIGHTED ERROR   2.22E-32
C                                         LOG WEIGHTED ERROR  31.65
C                               SIGNIFICANT FIGURES REQUIRED  30.75
C                                    DECIMAL PLACES REQUIRED  32.54
C
C
C     SERIES D             ON THE INTERVAL -2.50000E-01 TO -1.25000E-01
C                                        WITH WEIGHTED ERROR   5.19E-32
C                                         LOG WEIGHTED ERROR  31.28
C                               SIGNIFICANT FIGURES REQUIRED  30.82
C                                    DECIMAL PLACES REQUIRED  32.09
C
C
C     SERIES E             ON THE INTERVAL -4.00000E+00 TO -1.00000E+00
C                                        WITH WEIGHTED ERROR   8.49E-34
C                                         LOG WEIGHTED ERROR  33.07
C                               SIGNIFICANT FIGURES REQUIRED  34.13
C                                    DECIMAL PLACES REQUIRED  33.80
C
C
C     SERIES R             ON THE INTERVAL -1.00000E+00 TO  1.00000E+00
C                                        WITH WEIGHTED ERROR   8.08E-33
C                                         LOG WEIGHTED ERROR  32.09
C                        APPROX SIGNIFICANT FIGURES REQUIRED  30.4
C                                    DECIMAL PLACES REQUIRED  32.79
C
C
C     SERIES P             ON THE INTERVAL  2.50000E-01 TO  1.00000E+00
C                                        WITH WEIGHTED ERROR   6.65E-32
C                                         LOG WEIGHTED ERROR  31.18
C                               SIGNIFICANT FIGURES REQUIRED  30.69
C                                    DECIMAL PLACES REQUIRED  32.03
C
C
C     SERIES Q             ON THE INTERVAL  0.          TO  2.50000E-01
C                                        WITH WEIGHTED ERROR   5.07E-32
C                                         LOG WEIGHTED ERROR  31.30
C                               SIGNIFICANT FIGURES REQUIRED  30.40
C                                    DECIMAL PLACES REQUIRED  32.20
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, C, EPS, T, W
      DOUBLE PRECISION A(50), B(60), D(41), E(29), R(25), P(50), Q(64)
      DOUBLE PRECISION DEI0, DCSEVL, DPMPAR
C------------------------------
      DATA A(1)  / .3284394579616699087873844201881D-01/,
     *     A(2)  /-.1669920452031362851476184343387D-01/,
     *     A(3)  / .2845284724361346807424899853252D-03/,
     *     A(4)  /-.7563944358516206489487866938533D-05/,
     *     A(5)  / .2798971289450859157504843180879D-06/,
     *     A(6)  /-.1357901828534531069525563926255D-07/,
     *     A(7)  / .8343596202040469255856102904906D-09/,
     *     A(8)  /-.6370971727640248438275242988532D-10/,
     *     A(9)  / .6007247608811861235760831561584D-11/,
     *     A(10) /-.7022876174679773590750626150088D-12/
      DATA A(11) / .1018302673703687693096652346883D-12/,
     *     A(12) /-.1761812903430880040406309966422D-13/,
     *     A(13) / .3250828614235360694244030353877D-14/,
     *     A(14) /-.5071770025505818678824872259044D-15/,
     *     A(15) / .1665177387043294298172486084156D-16/,
     *     A(16) / .3166753890797514400677003536555D-16/,
     *     A(17) /-.1588403763664141515133118343538D-16/,
     *     A(18) / .4175513256138018833003034618484D-17/,
     *     A(19) /-.2892347749707141906710714478852D-18/,
     *     A(20) /-.2800625903396608103506340589669D-18/
      DATA A(21) / .1322938639539270903707580023781D-18/,
     *     A(22) /-.1804447444177301627283887833557D-19/,
     *     A(23) /-.7905384086522616076291644817604D-20/,
     *     A(24) / .4435711366369570103946235838027D-20/,
     *     A(25) /-.4264103994978120868865309206555D-21/,
     *     A(26) /-.3920101766937117541553713162048D-21/,
     *     A(27) / .1527378051343994266343752326971D-21/,
     *     A(28) / .1024849527049372339310308783117D-22/,
     *     A(29) /-.2134907874771433576262711405882D-22/,
     *     A(30) / .3239139475160028267061694700366D-23/
      DATA A(31) / .2142183762299889954762643168296D-23/,
     *     A(32) /-.8234609419601018414700348082312D-24/,
     *     A(33) /-.1524652829645809479613694401140D-24/,
     *     A(34) / .1378208282460639134668480364325D-24/,
     *     A(35) / .2131311202833947879523224999253D-26/,
     *     A(36) /-.2012649651526484121817466763127D-25/,
     *     A(37) / .1995535662263358016106311782673D-26/,
     *     A(38) / .2798995808984003464948686520319D-26/,
     *     A(39) /-.5534511845389626637640819277823D-27/,
     *     A(40) /-.3884995396159968861682544026146D-27/
      DATA A(41) / .1121304434507359382850680354679D-27/,
     *     A(42) / .5566568152423740948256563833514D-28/,
     *     A(43) /-.2045482929810499700448533938176D-28/,
     *     A(44) /-.8453813992712336233411457493674D-29/,
     *     A(45) / .3565758433431291562816111116287D-29/,
     *     A(46) / .1383653872125634705539949098871D-29/,
     *     A(47) /-.6062167864451372436584533764778D-30/,
     *     A(48) /-.2447198043989313267437655119189D-30/,
     *     A(49) / .1006850640933998348011548180480D-30/,
     *     A(50) / .4623685555014869015664341461674D-31/
C------------------------------
      DATA B(1)  / .20263150647078889499401236517381D+00/,
     *     B(2)  /-.73655140991203130439536898728034D-01/,
     *     B(3)  / .63909349118361915862753283840020D-02/,
     *     B(4)  /-.60797252705247911780653153363999D-03/,
     *     B(5)  /-.73706498620176629330681411493484D-04/,
     *     B(6)  / .48732857449450183453464992488076D-04/,
     *     B(7)  /-.23837064840448290766588489460235D-05/,
     *     B(8)  /-.30518612628561521027027332246121D-05/,
     *     B(9)  / .17050331572564559009688032992907D-06/,
     *     B(10) / .23834204527487747258601598136403D-06/
      DATA B(11) / .10781772556163166562596872364020D-07/,
     *     B(12) /-.17955692847399102653642691446599D-07/,
     *     B(13) /-.41284072341950457727912394640436D-08/,
     *     B(14) / .68622148588631968618346844526664D-09/,
     *     B(15) / .53130183120506356147602009675961D-09/,
     *     B(16) / .78796880261490694831305022893515D-10/,
     *     B(17) /-.26261762329356522290341675271232D-10/,
     *     B(18) /-.15483687636308261963125756294100D-10/,
     *     B(19) /-.25818962377261390492802405122591D-11/,
     *     B(20) / .59542879191591072658903529959352D-12/
      DATA B(21) / .46451400387681525833784919321405D-12/,
     *     B(22) / .11557855023255861496288006203731D-12/,
     *     B(23) /-.10475236870835799012317547189670D-14/,
     *     B(24) /-.11896653502709004368104489260929D-13/,
     *     B(25) /-.47749077490261778752643019349950D-14/,
     *     B(26) /-.81077649615772777976249734754135D-15/,
     *     B(27) / .13435569250031554199376987998178D-15/,
     *     B(28) / .14134530022913106260248873881287D-15/,
     *     B(29) / .49451592573953173115520663232883D-16/,
     *     B(30) / .79884048480080665648858587399367D-17/
      DATA B(31) /-.14008632188089809829248711935393D-17/,
     *     B(32) /-.14814246958417372107722804001680D-17/,
     *     B(33) /-.55826173646025601904010693937113D-18/,
     *     B(34) /-.11442074542191647264783072544598D-18/,
     *     B(35) / .25371823879566853500524018479923D-20/,
     *     B(36) / .13205328154805359813278863389097D-19/,
     *     B(37) / .62930261081586809166287426789485D-20/,
     *     B(38) / .17688270424882713734999261332548D-20/,
     *     B(39) / .23266187985146045209674296887432D-21/,
     *     B(40) /-.67803060811125233043773831844113D-22/
      DATA B(41) /-.59440876959676373802874150531891D-22/,
     *     B(42) /-.23618214531184415968532592503466D-22/,
     *     B(43) /-.60214499724601478214168478744576D-23/,
     *     B(44) /-.65517906474348299071370444144639D-24/,
     *     B(45) / .29388755297497724587042038699349D-24/,
     *     B(46) / .22601606200642115173215728758510D-24/,
     *     B(47) / .89534369245958628745091206873087D-25/,
     *     B(48) / .24015923471098457555772067457706D-25/,
     *     B(49) / .34118376888907172955666423043413D-26/,
     *     B(50) /-.71617071694630342052355013345279D-27/
      DATA B(51) /-.75620390659281725157928651980799D-27/,
     *     B(52) /-.33774612157467324637952920780800D-27/,
     *     B(53) /-.10479325703300941711526430332245D-27/,
     *     B(54) /-.21654550252170342240854880201386D-28/,
     *     B(55) /-.75297125745288269994689298432000D-30/,
     *     B(56) / .19103179392798935768638084000426D-29/,
     *     B(57) / .11492104966530338547790728833706D-29/,
     *     B(58) / .43896970582661751514410359193600D-30/,
     *     B(59) / .12320883239205686471647157725866D-30/,
     *     B(60) / .22220174457553175317538581162666D-31/
C------------------------------
      DATA D(1)  / .63629589796747038767129887806803D+00/,
     *     D(2)  /-.13081168675067634385812671121135D+00/,
     *     D(3)  /-.84367410213053930014487662129752D-02/,
     *     D(4)  / .26568491531006685413029428068906D-02/,
     *     D(5)  / .32822721781658133778792170142517D-03/,
     *     D(6)  /-.23783447771430248269579807851050D-04/,
     *     D(7)  /-.11439804308100055514447076797047D-04/,
     *     D(8)  /-.14405943433238338455239717699323D-05/,
     *     D(9)  / .52415956651148829963772818061664D-08/,
     *     D(10) / .38407306407844323480979203059716D-07/
      DATA D(11) / .85880244860267195879660515759344D-08/,
     *     D(12) / .10219226625855003286339969553911D-08/,
     *     D(13) / .21749132323289724542821339805992D-10/,
     *     D(14) /-.22090238142623144809523503811741D-10/,
     *     D(15) /-.63457533544928753294383622208801D-11/,
     *     D(16) /-.10837746566857661115340539732919D-11/,
     *     D(17) /-.11909822872222586730262200440277D-12/,
     *     D(18) /-.28438682389265590299508766008661D-14/,
     *     D(19) / .25080327026686769668587195487546D-14/,
     *     D(20) / .78729641528559842431597726421265D-15/
      DATA D(21) / .15475066347785217148484334637329D-15/,
     *     D(22) / .22575322831665075055272608197290D-16/,
     *     D(23) / .22233352867266608760281380836693D-17/,
     *     D(24) / .16967819563544153513464194662399D-19/,
     *     D(25) /-.57608316255947682105310087304533D-19/,
     *     D(26) /-.17591235774646878055625369408853D-19/,
     *     D(27) /-.36286056375103174394755328682666D-20/,
     *     D(28) /-.59235569797328991652558143488000D-21/,
     *     D(29) /-.76030380926310191114429136895999D-22/,
     *     D(30) /-.62547843521711763842641428479999D-23/
      DATA D(31) / .25483360759307648606037606400000D-24/,
     *     D(32) / .25598615731739857020168874666666D-24/,
     *     D(33) / .71376239357899318800207052800000D-25/,
     *     D(34) / .14703759939567568181578956800000D-25/,
     *     D(35) / .25105524765386733555198634666666D-26/,
     *     D(36) / .35886666387790890886583637333333D-27/,
     *     D(37) / .39886035156771301763317759999999D-28/,
     *     D(38) / .21763676947356220478805333333333D-29/,
     *     D(39) /-.46146998487618942367607466666666D-30/,
     *     D(40) /-.20713517877481987707153066666666D-30/
      DATA D(41) /-.51890378563534371596970666666666D-31/
C------------------------------
      DATA E(1)  /-.16113461655571494025720663927566180D+02/,
     *     E(2)  / .77940727787426802769272245891741497D+01/,
     *     E(3)  /-.19554058188631419507127283812814491D+01/,
     *     E(4)  / .37337293866277945611517190865690209D+00/,
     *     E(5)  /-.56925031910929019385263892220051166D-01/,
     *     E(6)  / .72110777696600918537847724812635813D-02/,
     *     E(7)  /-.78104901449841593997715184089064148D-03/,
     *     E(8)  / .73880933562621681878974881366177858D-04/,
     *     E(9)  /-.62028618758082045134358133607909712D-05/,
     *     E(10) / .46816002303176735524405823868362657D-06/
      DATA E(11) /-.32092888533298649524072553027228719D-07/,
     *     E(12) / .20151997487404533394826262213019548D-08/,
     *     E(13) /-.11673686816697793105356271695015419D-09/,
     *     E(14) / .62762706672039943397788748379615573D-11/,
     *     E(15) /-.31481541672275441045246781802393600D-12/,
     *     E(16) / .14799041744493474210894472251733333D-13/,
     *     E(17) /-.65457091583979673774263401588053333D-15/,
     *     E(18) / .27336872223137291142508012748799999D-16/,
     *     E(19) /-.10813524349754406876721727624533333D-17/,
     *     E(20) / .40628328040434303295300348586666666D-19/
      DATA E(21) /-.14535539358960455858914372266666666D-20/,
     *     E(22) / .49632746181648636830198442666666666D-22/,
     *     E(23) /-.16208612696636044604866560000000000D-23/,
     *     E(24) / .50721448038607422226431999999999999D-25/,
     *     E(25) /-.15235811133372207813973333333333333D-26/,
     *     E(26) / .44001511256103618696533333333333333D-28/,
     *     E(27) /-.12236141945416231594666666666666666D-29/,
     *     E(28) / .32809216661066001066666666666666666D-31/,
     *     E(29) /-.84933452268306432000000000000000000D-33/
C------------------------------
      DATA R(1)  /-.3739021479220279511668698204827D-01/,
     *     R(2)  / .4272398606220957726049179176528D-01/,
     *     R(3)  /-.130318207984970054415392055219726D+00/,
     *     R(4)  / .144191240246988907341095893982137D-01/,
     *     R(5)  /-.134617078051068022116121527983553D-02/,
     *     R(6)  / .107310292530637799976115850970073D-03/,
     *     R(7)  /-.742999951611943649610283062223163D-05/,
     *     R(8)  / .453773256907537139386383211511827D-06/,
     *     R(9)  /-.247641721139060131846547423802912D-07/,
     *     R(10) / .122076581374590953700228167846102D-08/
      DATA R(11) /-.548514148064092393821357398028261D-10/,
     *     R(12) / .226362142130078799293688162377002D-11/,
     *     R(13) /-.863589727169800979404172916282240D-13/,
     *     R(14) / .306291553669332997581032894881279D-14/,
     *     R(15) /-.101485718855944147557128906734933D-15/,
     *     R(16) / .315482174034069877546855328426666D-17/,
     *     R(17) /-.923604240769240954484015923200000D-19/,
     *     R(18) / .255504267970814002440435029333333D-20/,
     *     R(19) /-.669912805684566847217882453333333D-22/,
     *     R(20) / .166925405435387319431987199999999D-23/
      DATA R(21) /-.396254925184379641856000000000000D-25/,
     *     R(22) / .898135896598511332010666666666666D-27/,
     *     R(23) /-.194763366993016433322666666666666D-28/,
     *     R(24) / .404836019024630033066666666666666D-30/,
     *     R(25) /-.807981567699845120000000000000000D-32/
C------------------------------
      DATA P(1)  /-.60577324664060345999319382737747D+00/,
     *     P(2)  /-.11253524348366090030649768852718D+00/,
     *     P(3)  / .13432266247902779492487859329414D-01/,
     *     P(4)  /-.19268451873811457249246838991303D-02/,
     *     P(5)  / .30911833772060318335586737475368D-03/,
     *     P(6)  /-.53564132129618418776393559795147D-04/,
     *     P(7)  / .98278128802474923952491882717237D-05/,
     *     P(8)  /-.18853689849165182826902891938910D-05/,
     *     P(9)  / .37494319356894735406964042190531D-06/,
     *     P(10) /-.76823455870552639273733465680556D-07/
      DATA P(11) / .16143270567198777552956300060868D-07/,
     *     P(12) /-.34668022114907354566309060226027D-08/,
     *     P(13) / .75875420919036277572889747054114D-09/,
     *     P(14) /-.16886433329881412573514526636703D-09/,
     *     P(15) / .38145706749552265682804250927272D-10/,
     *     P(16) /-.87330266324446292706851718272334D-11/,
     *     P(17) / .20236728645867960961794311064330D-11/,
     *     P(18) /-.47413283039555834655210340820160D-12/,
     *     P(19) / .11221172048389864324731799928920D-12/,
     *     P(20) /-.26804225434840309912826809093395D-13/
      DATA P(21) / .64578514417716530343580369067212D-14/,
     *     P(22) /-.15682760501666478830305702849194D-14/,
     *     P(23) / .38367865399315404861821516441408D-15/,
     *     P(24) /-.94517173027579130478871048932556D-16/,
     *     P(25) / .23434812288949573293896666439133D-16/,
     *     P(26) /-.58458661580214714576123194419882D-17/,
     *     P(27) / .14666229867947778605873617419195D-17/,
     *     P(28) /-.36993923476444472706592538274474D-18/,
     *     P(29) / .93790159936721242136014291817813D-19/,
     *     P(30) /-.23893673221937873136308224087381D-19/
      DATA P(31) / .61150624629497608051934223837866D-20/,
     *     P(32) /-.15718585327554025507719853288106D-20/,
     *     P(33) / .40572387285585397769519294491306D-21/,
     *     P(34) /-.10514026554738034990566367122773D-21/,
     *     P(35) / .27349664930638667785806003131733D-22/,
     *     P(36) /-.71401604080205796099355574271999D-23/,
     *     P(37) / .18705552432235079986756924211199D-23/,
     *     P(38) /-.49167468166870480520478020949333D-24/,
     *     P(39) / .12964988119684031730916087125333D-24/,
     *     P(40) /-.34292515688362864461623940437333D-25/
      DATA P(41) / .90972241643887034329104820906666D-26/,
     *     P(42) /-.24202112314316856489934847999999D-26/,
     *     P(43) / .64563612934639510757670475093333D-27/,
     *     P(44) /-.17269132735340541122315987626666D-27/,
     *     P(45) / .46308611659151500715194231466666D-28/,
     *     P(46) /-.12448703637214131241755170133333D-28/,
     *     P(47) / .33544574090520678532907007999999D-29/,
     *     P(48) /-.90598868521070774437543935999999D-30/,
     *     P(49) / .24524147051474238587273216000000D-30/,
     *     P(50) /-.66528178733552062817107967999999D-31/
C------------------------------
      DATA Q(1)  /-.1892918000753016825495679942820D+00/,
     *     Q(2)  /-.8648117855259871489968817056824D-01/,
     *     Q(3)  / .7224101543746594747021514839184D-02/,
     *     Q(4)  /-.8097559457557386197159655610181D-03/,
     *     Q(5)  / .1099913443266138867179251157002D-03/,
     *     Q(6)  /-.1717332998937767371495358814487D-04/,
     *     Q(7)  / .2985627514479283322825342495003D-05/,
     *     Q(8)  /-.5659649145771930056560167267155D-06/,
     *     Q(9)  / .1152680839714140019226583501663D-06/,
     *     Q(10) /-.2495030440269338228842128765065D-07/
      DATA Q(11) / .5692324201833754367039370368140D-08/,
     *     Q(12) /-.1359957664805600338490030939176D-08/,
     *     Q(13) / .3384662888760884590184512925859D-09/,
     *     Q(14) /-.8737853904474681952350849316580D-10/,
     *     Q(15) / .2331588663222659718612613400470D-10/,
     *     Q(16) /-.6411481049213785969753165196326D-11/,
     *     Q(17) / .1812246980204816433384359484682D-11/,
     *     Q(18) /-.5253831761558460688819403840466D-12/,
     *     Q(19) / .1559218272591925698855028609825D-12/,
     *     Q(20) /-.4729168297080398718476429369466D-13/
      DATA Q(21) / .1463761864393243502076199493808D-13/,
     *     Q(22) /-.4617388988712924102232173623604D-14/,
     *     Q(23) / .1482710348289369323789239660371D-14/,
     *     Q(24) /-.4841672496239229146973165734417D-15/,
     *     Q(25) / .1606215575700290408116571966188D-15/,
     *     Q(26) /-.5408917538957170947895023784252D-16/,
     *     Q(27) / .1847470159346897881370231402310D-16/,
     *     Q(28) /-.6395830792759094470500610425050D-17/,
     *     Q(29) / .2242780721699759457250233276170D-17/,
     *     Q(30) /-.7961369173983947552744555308646D-18/
      DATA Q(31) / .2859308111540197459808619929272D-18/,
     *     Q(32) /-.1038450244701137145900697137446D-18/,
     *     Q(33) / .3812040607097975780866841008319D-19/,
     *     Q(34) /-.1413795417717200768717562723696D-19/,
     *     Q(35) / .5295367865182740958305442594815D-20/,
     *     Q(36) /-.2002264245026825902137211131439D-20/,
     *     Q(37) / .7640262751275196014736848610918D-21/,
     *     Q(38) /-.2941119006868787883311263523362D-21/,
     *     Q(39) / .1141823539078927193037691483586D-21/,
     *     Q(40) /-.4469308475955298425247020718489D-22/
      DATA Q(41) / .1763262410571750770630491408520D-22/,
     *     Q(42) /-.7009968187925902356351518262340D-23/,
     *     Q(43) / .2807573556558378922287757507515D-23/,
     *     Q(44) /-.1132560944981086432141888891562D-23/,
     *     Q(45) / .4600574684375017946156764233727D-24/,
     *     Q(46) /-.1881448598976133459864609148108D-24/,
     *     Q(47) / .7744916111507730845444328478037D-25/,
     *     Q(48) /-.3208512760585368926702703826261D-25/,
     *     Q(49) / .1337445542910839760619930421384D-25/,
     *     Q(50) /-.5608671881802217048894771735210D-26/
      DATA Q(51) / .2365839716528537483710069473279D-26/,
     *     Q(52) /-.1003656195025305334065834526856D-26/,
     *     Q(53) / .4281490878094161131286642556927D-27/,
     *     Q(54) /-.1836345261815318199691326958250D-27/,
     *     Q(55) / .7917798231349540000097468678144D-28/,
     *     Q(56) /-.3431542358742220361025015775231D-28/,
     *     Q(57) / .1494705493897103237475066008917D-28/,
     *     Q(58) /-.6542620279865705439739042420053D-29/,
     *     Q(59) / .2877581395199171114340487353685D-29/,
     *     Q(60) /-.1271557211796024711027981200042D-29/
      DATA Q(61) / .5644615555648722522388044622506D-30/,
     *     Q(62) /-.2516994994284095106080616830293D-30/,
     *     Q(63) / .1127259818927510206370368804181D-30/,
     *     Q(64) /-.5069814875800460855562584719360D-31/
C------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0.
C
                       EPS = DPMPAR(1)
C
C------------------------------
      IF (DABS(X) .GE. 90.D0) GO TO 80
      IF (X .GT. -1.D0) GO TO 40
C
C                    -90 .LT. X .LT. -4
C
      IF (X .GT. -32.D0) GO TO 10
      M = 50
      IF (EPS .GE. 1.D-20) M = 25
      DE1E = (1.D0 + DCSEVL (64.D0/X+1.D0, A, M))/X
      RETURN
C
   10 IF (X .GT. -8.D0) GO TO 20
      M = 60
      IF (EPS .GE. 1.D-20) M = 37
      DE1E = (1.D0 + DCSEVL ((64.D0/X+5.D0)/3.D0, B, M))/X
      RETURN
C
   20 IF (X .GE. -4.D0) GO TO 30
      M = 41
      IF (EPS .GE. 1.D-20) M = 27
      DE1E = (1.D0 + DCSEVL (16.D0/X+3.D0, D, M))/X
      RETURN
C
C                     -4 .LE. X .LE. 1
C
   30 M = 29
      IF (EPS .GE. 1.D-20) M = 20
      DE1E = -DLOG(-X) + DCSEVL ((2.D0*X+5.D0)/3.D0, E, M)
      RETURN
C
   40 IF (X .GT. 1.0D0) GO TO 60
      IF (X .LT. -0.4D0 .OR. X .GT. -0.35D0) GO TO 50
         DE1E = - DEI0(-X, EPS)
         RETURN
   50 M = 25
      IF (EPS .GE. 1.D-20) M = 18
      DE1E = (-DLOG(DABS(X)) - 0.6875D0 + X)  + DCSEVL (X, R, M)
      RETURN
C
C                     1 .LT. X .LT. 90
C
   60 IF (X .GT. 4.0D0) GO TO 70
      M = 50
      IF (EPS .GE. 1.D-20) M = 31
      DE1E = (1.D0 + DCSEVL ((8.D0/X-5.D0)/3.D0, P, M))/X
      RETURN
C
   70 M = 64
      IF (EPS .GE. 1.D-20) M = 35
      DE1E = (1.D0 + DCSEVL (8.D0/X-1.D0, Q, M))/X
      RETURN
C
C                   ASYMPTOTIC EXPANSION
C
   80 T = -1.D0/X
      C = T
      W = C
      M = 1
   81    M = M + 1
         C = (M*T)*C
         W = C + W
         IF (DABS(C) .GT. EPS) GO TO 81
      DE1E = (1.D0 + W)/X
      RETURN
      END
      DOUBLE PRECISION FUNCTION DEI0 (X, EPS)
C-----------------------------------------------------------------------
C
C            TAYLOR SERIES EXPANSION OF EI(X) AROUND X0,
C                  WHERE X0 IS THE ZERO OF EI(X).
C                    EPS IS THE TOLERANCE USED.
C
C-------------------------
C     WRITTEN BY A.H. MORRIS
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(40), C, EPS, H, T, X, W
      DOUBLE PRECISION DK1, DK2, DK3, DB, DB2, DX
C-------------------------
      DATA DK1 /25598514349.D0/, DK2 /12212826724.D0/,
     *     DK3 /52346020729.D0/
      DATA DB  /68719476736.D0/
      DATA DX  /.64725688445954142292644880487403537155379408215561D-33/
C-------------------------
      DATA A(1)  / .3896215733907167310156502703593482682018D+01/,
     *     A(2)  /-.3281607866398561670879044070702055058438D+01/,
     *     A(3)  / .6522376145438925697728352767902339522245D+01/,
     *     A(4)  /-.1296969738353651703636356975116693457132D+02/,
     *     A(5)  / .2788629796294204997855360701398702087604D+02/,
     *     A(6)  /-.6237880152891541873078526672920295283143D+02/,
     *     A(7)  / .1435349488096750987841265647073135861344D+03/,
     *     A(8)  /-.3371558271787468916821364466977375583658D+03/,
     *     A(9)  / .8045318399821382506595322457265602778098D+03/,
     *     A(10) /-.1943796645723498840655451915157946462648D+04/
      DATA A(11) / .4743765650402430835228269085129777320454D+04/,
     *     A(12) /-.1167346399116716364394668734600584330571D+05/,
     *     A(13) / .2892695530543545087445160311373446386859D+05/,
     *     A(14) /-.7210794586837158996878001987822898188198D+05/,
     *     A(15) / .1806695585893919626172098163733836311447D+06/,
     *     A(16) /-.4546962188544665746524572520110515778526D+06/,
     *     A(17) / .1148834546817744310374556891236080193473D+07/,
     *     A(18) /-.2912721663850837498392234670693435881386D+07/,
     *     A(19) / .7407692958000587759747953639495510375408D+07/,
     *     A(20) /-.1889172700038153127288849726417780854730D+08/
      DATA A(21) / .4830003493086024720868271496253148288055D+08/,
     *     A(22) /-.1237682190024917092137405370407916520821D+09/,
     *     A(23) / .3178111056663621852260468265468336116367D+09/,
     *     A(24) /-.8176185693184928170769596413793786736279D+09/,
     *     A(25) / .2107109291864363741291032089276432438927D+10/,
     *     A(26) /-.5438996831077284596300440196418865401363D+10/,
     *     A(27) / .1406026390995585037838894210474681627693D+11/,
     *     A(28) /-.3639689100149205333626392754168250384373D+11/,
     *     A(29) / .9433859509219164512733865811047107199412D+11/,
     *     A(30) /-.2448111705066430130314746602027041462835D+12/
      DATA A(31) / .6359981818273706257655285041587660739835D+12/,
     *     A(32) /-.1653989211524391716301960841541179924503D+13/,
     *     A(33) / .4305601123377464671923711939926758523701D+13/,
     *     A(34) /-.1121847693567642152208443795868288937687D+14/,
     *     A(35) / .2925565695557339262045727352754930716608D+14/,
     *     A(36) /-.7635552741959392076619218035480359307499D+14/,
     *     A(37) / .1994372792759425025753893705017248674884D+15/,
     *     A(38) /-.5213021921201092276891722450906568692592D+15/,
     *     A(39) / .1363558024737805584657706536660107687818D+16/,
     *     A(40) /-.3568973490569445692988895507297245137908D+16/
C-------------------------
C
C     SET  H = X - X0  WHERE X0 IS THE ZERO OF EI(X). X0 HAS THE
C     APPROXIMATE 60 DIGIT VALUE ...
C
C      .37250741078136663446 19918665801191335356 89497771654051555657
C
C     A MORE ACCURATE VALUE IS GIVEN BY ...
C
C            X0 = DK1/8**12 + DK2/8**24 + DK3/8**36 + DX
C
C     THE FOLLOWING CODE SHOULD YIELD THE CORRECT VALUE FOR H IF A
C     BINARY, OCTAL, OR HEXADECIMAL DOUBLE PRECISION ARITHMETIC IS
C     BEING USED.
C
      DB2 = DB*DB
      H = (((X - DK1/DB) - DK2/DB2) - DK3/(DB*DB2)) - DX
C
C-------------------------
      T = H
      W = 0.D0
      DO 10 N = 2,40
         C = A(N)*T
         W = W + C
         IF (DABS(C) .LT. EPS) GO TO 20
         T = H*T
   10 CONTINUE
C
   20 DEI0 = H * (A(1) + W)
      RETURN
      END
      REAL FUNCTION SI (X)
C-----------------------------------------------------------------------
C
C              EVALUATION OF THE SINE INTEGRAL FUNCTION
C
C                         ------------------
C
C     ALGORITHM.  A MINIMAX APPROXIMATION OBTAINED BY A. H. MORRIS
C     IS USED WHEN ABS(X) .LE. 5, AND THE CHEBYSHEV EXPANSION GIVEN
C     ON PAGE 326 OF THE REFERENCE IS USED WHEN ABS(X) .GT. 5.
C
C     REFERENCE.  LUKE, YUDELL L., THE SPECIAL FUNCTIONS AND THEIR
C     APPROXIMATIONS, VOL. 2, ACADEMIC PRESS, NEW YORK, 1969.
C
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C        FEB 1993
C
C-----------------------------------------------------------------------
      REAL C(46)
C-------------------------
      DATA N /46/, M /21/
      DATA PIHALF /1.5707963267949/
C-------------------------
      DATA A1 /-.480279472444504E-01/, A2 /.127177528378855E-02/,
     *     A3 /-.170630463362755E-04/, A4 /.129975549721579E-06/,
     *     A5 /-.582322888431340E-09/, A6 /.148011790132481E-11/,
     *     A7 /-.172103429855786E-14/
      DATA B1  /.752760831110726E-02/, B2 /.233090788469112E-04/,
     *     B3  /.305598403979701E-07/
C-------------------------
      DATA C(1) / 9.76155271128712E-01/, C(2) / 8.96845854916423E-02/,
     *     C(3) /-3.04656658030696E-02/, C(4) / 8.50892472922945E-02/,
     *     C(5) /-5.78073683148386E-03/, C(6) /-5.07182677775691E-03/,
     *     C(7) / 8.38643256650893E-04/, C(8) /-3.34223415981738E-04/,
     *     C(9) /-2.15746207281216E-05/, C(10)/ 1.28560650086065E-04/,
     *     C(11)/-1.56456413510232E-05/, C(12)/-1.52025513597262E-05/,
     *     C(13)/ 4.04001013843204E-06/, C(14)/-5.95896122752160E-07/,
     *     C(15)/-4.34985305974340E-07/, C(16)/ 7.13472533530840E-07/,
     *     C(17)/-5.34302186061100E-08/, C(18)/-1.76003581156610E-07/,
     *     C(19)/ 3.85028855125900E-08/, C(20)/ 1.92576544441700E-08/
      DATA C(21)/-1.00735358217200E-08/, C(22)/ 3.36359194377000E-09/,
     *     C(23)/ 1.28049619406000E-09/, C(24)/-2.42546870827000E-09/,
     *     C(25)/ 1.86917288950000E-10/, C(26)/ 7.13431298340000E-10/,
     *     C(27)/-1.70673483710000E-10/, C(28)/-1.14604070350000E-10/,
     *     C(29)/ 5.88004411500000E-11/, C(30)/-6.78417843000000E-12/,
     *     C(31)/-1.21572380900000E-11/, C(32)/ 1.26561248700000E-11/,
     *     C(33)/ 4.74814180000000E-13/, C(34)/-5.32309477000000E-12/,
     *     C(35)/ 9.05903810000000E-13/, C(36)/ 1.40046450000000E-12/,
     *     C(37)/-5.00968320000000E-13/, C(38)/-1.80458040000000E-13/,
     *     C(39)/ 1.66162910000000E-13/, C(40)/-5.02616400000000E-14/
      DATA C(41)/-3.48453600000000E-14/, C(42)/ 4.60056600000000E-14/,
     *     C(43)/ 5.74000000000000E-16/, C(44)/-1.95310700000000E-14/,
     *     C(45)/ 3.68837000000000E-15/, C(46)/ 5.62862000000000E-15/
C-------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0.
C            IT IS ASSUMED THAT SIN(X) AND COS(X) ARE DEFINED
C            FOR ABS(X) .LT. 1.0/EPS.
C
C-------------------------
      AX = ABS(X)
      IF (AX .GT. 5.0) GO TO 10
C
C                          ABS(X) .LE. 5
C
      T = X*X
      W = ((((((((A7*T + A6)*T + A5)*T + A4)*T + A3)*T + A2)*T + A1)*T
     *            + 0.5) + 0.5) / (((B3*T + B2)*T + B1)*T + 1.0)
      SI = X*W
      RETURN
C
C                          ABS(X) .GT. 5
C
   10 IF (AX .LT. 1.E+5) GO TO 20
      EPS = SPMPAR(1)
      IF (AX*EPS .GE. 1.0) GO TO 50
C
   20 Z = 10.0/AX - 1.0
      W = Z + Z
      J = N - 1
      T1 = C(J)
      T2 = 0.0
      DO 30 I = 1,M
         J = J - 2
         T = T1
         T1 = W*T1 - T2 + C(J)
         T2 = T
   30 CONTINUE
      P = Z*T1 - T2 + C(1)
C
      J = N
      T1 = C(J)
      T2 = 0.0
      DO 40 I = 1,M
         J = J - 2
         T = T1
         T1 = W*T1 - T2 + C(J)
         T2 = T
   40 CONTINUE
      Q = Z*T1 - T2 + C(2)
C
      SI = (P*COS(AX) + Q*SIN(AX))/AX
      SI = PIHALF - SI
      IF (X .LT. 0.0) SI = -SI
      RETURN
C
C                        ABS(X) .GE. 1/EPS
C
   50 SI = SIGN(PIHALF, X)
      RETURN
      END
      REAL FUNCTION CIN (X)
C-----------------------------------------------------------------------
C
C             EVALUATION OF THE COSINE INTEGRAL FUNCTION
C
C                        --------------------
C
C     ALGORITHM.  A MINIMAX APPROXIMATION OBTAINED BY A. H. MORRIS
C     IS USED WHEN ABS(X) .LE. 5, AND THE CHEBYSHEV EXPANSION GIVEN
C     ON PAGE 326 OF THE REFERENCE IS USED WHEN ABS(X) .GT. 5.
C
C     REFERENCE.  LUKE, YUDELL L., THE SPECIAL FUNCTIONS AND THEIR
C     APPROXIMATIONS, VOL. 2, ACADEMIC PRESS, NEW YORK, 1969.
C
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C        FEB 1993
C
C-----------------------------------------------------------------------
      REAL C(46)
      REAL SPMPAR
C-------------------------
      DATA N /46/, M /21/
      DATA EULER /.577215664901533/
C-------------------------
      DATA A1 /-.3204778460606743E-01/, A2 /.5675344472695174E-03/,
     *     A3 /-.5156904589230793E-05/, A4 /.2599346476124840E-07/,
     *     A5 /-.7022103360527070E-10/, A6 /.8201072014709134E-13/
      DATA B1  /.9618882060598870E-02/, B2 /.4239527386910357E-04/,
     *     B3  /.1039865274359493E-06/, B4 /.1238483219145955E-09/
C-------------------------
      DATA C(1) / 9.76155271128712E-01/, C(2) / 8.96845854916423E-02/,
     *     C(3) /-3.04656658030696E-02/, C(4) / 8.50892472922945E-02/,
     *     C(5) /-5.78073683148386E-03/, C(6) /-5.07182677775691E-03/,
     *     C(7) / 8.38643256650893E-04/, C(8) /-3.34223415981738E-04/,
     *     C(9) /-2.15746207281216E-05/, C(10)/ 1.28560650086065E-04/,
     *     C(11)/-1.56456413510232E-05/, C(12)/-1.52025513597262E-05/,
     *     C(13)/ 4.04001013843204E-06/, C(14)/-5.95896122752160E-07/,
     *     C(15)/-4.34985305974340E-07/, C(16)/ 7.13472533530840E-07/,
     *     C(17)/-5.34302186061100E-08/, C(18)/-1.76003581156610E-07/,
     *     C(19)/ 3.85028855125900E-08/, C(20)/ 1.92576544441700E-08/
      DATA C(21)/-1.00735358217200E-08/, C(22)/ 3.36359194377000E-09/,
     *     C(23)/ 1.28049619406000E-09/, C(24)/-2.42546870827000E-09/,
     *     C(25)/ 1.86917288950000E-10/, C(26)/ 7.13431298340000E-10/,
     *     C(27)/-1.70673483710000E-10/, C(28)/-1.14604070350000E-10/,
     *     C(29)/ 5.88004411500000E-11/, C(30)/-6.78417843000000E-12/,
     *     C(31)/-1.21572380900000E-11/, C(32)/ 1.26561248700000E-11/,
     *     C(33)/ 4.74814180000000E-13/, C(34)/-5.32309477000000E-12/,
     *     C(35)/ 9.05903810000000E-13/, C(36)/ 1.40046450000000E-12/,
     *     C(37)/-5.00968320000000E-13/, C(38)/-1.80458040000000E-13/,
     *     C(39)/ 1.66162910000000E-13/, C(40)/-5.02616400000000E-14/
      DATA C(41)/-3.48453600000000E-14/, C(42)/ 4.60056600000000E-14/,
     *     C(43)/ 5.74000000000000E-16/, C(44)/-1.95310700000000E-14/,
     *     C(45)/ 3.68837000000000E-15/, C(46)/ 5.62862000000000E-15/
C-------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0.
C            IT IS ASSUMED THAT SIN(X) AND COS(X) ARE DEFINED
C            FOR ABS(X) .LT. 1.0/EPS.
C
C-------------------------
      AX = ABS(X)
      IF (AX .GT. 5.0) GO TO 10
C
C                          ABS(X) .LE. 5
C
      T = X*X
      W = (((((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T + A1)*T +
     *           0.5) + 0.5) / ((((B4*T + B3)*T + B2)*T + B1)*T +
     *           1.0)
      CIN = 0.25*T*W
      RETURN
C
C                          ABS(X) .GT. 5
C
   10 IF (AX .LT. 1.E+5) GO TO 20
      EPS = SPMPAR(1)
      IF (AX*EPS .GE. 1.0) GO TO 50
C
   20 Z = 10.0/AX - 1.0
      W = Z + Z
      J = N - 1
      T1 = C(J)
      T2 = 0.0
      DO 30 I = 1,M
         J = J - 2
         T = T1
         T1 = W*T1 - T2 + C(J)
         T2 = T
   30 CONTINUE
      P = Z*T1 - T2 + C(1)
C
      J = N
      T1 = C(J)
      T2 = 0.0
      DO 40 I = 1,M
         J = J - 2
         T = T1
         T1 = W*T1 - T2 + C(J)
         T2 = T
   40 CONTINUE
      Q = Z*T1 - T2 + C(2)
C
      CIN = (P*SIN(AX) - Q*COS(AX))/AX
      CIN = (EULER - CIN) + ALOG(AX)
      RETURN
C
C                        ABS(X) .GE. 1/EPS
C
   50 CIN = EULER + ALOG(AX)
      RETURN
      END
      SUBROUTINE CEXEXI (Z, W)
C-----------------------------------------------------------------------
C        COMPUTATION OF THE EXPONENTIAL EXPONENTIAL INTEGRAL
C-----------------------------------------------------------------------
      COMPLEX Z, W
      REAL TS(2), SR(2), SM(2), TM(2), QF(2), ZL(2)
      REAL ED(18), EE(18), DD(19), DE(19), CD(18), CE(18)
C-------------------------
C     EULER = EULER CONSTANT
C     CONST = (PI*PI)/4
C     ZETA2 = THE RIEMANN ZETA FUNCTION EVALUATED AT 2
C-------------------------
      DATA CONST /2.46740110027234/
      DATA EULER /.577215664901533/
      DATA ZETA2 /1.64493406684823/
C-------------------------
      DATA ED(1)  /0.00000000000000E+00/, ED(2)  /.311105957086528E-01/,
     *     ED(3)  /.103661260539112E+00/, ED(4)  /.216532335244554E+00/,
     *     ED(5)  /.369931427960192E+00/, ED(6)  /.566766259990589E+00/,
     *     ED(7)  /.814042066324748E+00/, ED(8)  /.112384247540813E+01/,
     *     ED(9)  /.151400478148512E+01/, ED(10) /.200886795032284E+01/,
     *     ED(11) /.264052411823592E+01/, ED(12) /.345098449933392E+01/,
     *     ED(13) /.449583360763202E+01/, ED(14) /.585058263409822E+01/,
     *     ED(15) /.762273501463380E+01/, ED(16) /.997814501584578E+01/,
     *     ED(17) /.132122064896408E+02/, ED(18) /.180322948376021E+02/
      DATA EE(1)  /.850156516121093E-02/, EE(2)  /.505037465849058E-01/,
     *     EE(3)  /.836817368956407E-01/, EE(4)  /.107047582417607E+00/,
     *     EE(5)  /.120424719029462E+00/, EE(6)  /.125096631582229E+00/,
     *     EE(7)  /.122314435224685E+00/, EE(8)  /.112621417553907E+00/,
     *     EE(9)  /.963419407392582E-01/, EE(10) /.747398422757511E-01/,
     *     EE(11) /.508596135953441E-01/, EE(12) /.290822706773628E-01/,
     *     EE(13) /.132201640530101E-01/, EE(14) /.443802939829067E-02/,
     *     EE(15) /.992612478987576E-03/, EE(16) /.126579795112011E-03/,
     *     EE(17) /.702150908253350E-05/, EE(18) /.910281532564632E-07/
C-------------------------
      DATA DD(1)  /0.00000000000000E+00/, DD(2)  /.419556678374293E-01/,
     *     DD(3)  /.117533661648665E+00/, DD(4)  /.228560237455987E+00/,
     *     DD(5)  /.375667350161240E+00/, DD(6)  /.791594846276672E+00/,
     *     DD(7)  /.107546889623058E+01/, DD(8)  /.142659208030841E+01/,
     *     DD(9)  /.186290554952377E+01/, DD(10) /.240730009509856E+01/,
     *     DD(11) /.308854035607524E+01/, DD(12) /.394277605155259E+01/,
     *     DD(13) /.501593196543981E+01/, DD(14) /.636759180748651E+01/,
     *     DD(15) /.807776193096055E+01/, DD(16) /.102598961138887E+02/,
     *     DD(17) /.130896768422610E+02/, DD(18) /.168832169085916E+02/,
     *     DD(19) /.224083240941713E+02/
      DATA DE(1) /-.346911733535892E-03/, DE(2) /-.603787732461745E-02/,
     *     DE(3) /-.152461305949249E-01/, DE(4) /-.210582169827291E-01/,
     *     DE(5) /-.171894208720754E-01/, DE(6)  /.314323467033032E-01/,
     *     DE(7)  /.750898531566972E-01/, DE(8)  /.124689787807260E+00/,
     *     DE(9)  /.168579075090035E+00/, DE(10) /.191715080699511E+00/,
     *     DE(11) /.182600794550836E+00/, DE(12) /.142345674307147E+00/,
     *     DE(13) /.874862222419327E-01/, DE(14) /.402175083288425E-01/,
     *     DE(15) /.128575005680180E-01/, DE(16) /.257673782598441E-02/,
     *     DE(17) /.275955003784349E-03/, DE(18) /.119139315517122E-04/,
     *     DE(19) /.107292980199386E-06/
C-------------------------
      DATA CD(1)  /0.00000000000000E+00/, CD(2)  /.237286128313683E-01/,
     *     CD(3)  /.854113210668760E-01/, CD(4)  /.185276627282059E+00/,
     *     CD(5)  /.323741526616688E+00/, CD(6)  /.503045460381267E+00/,
     *     CD(7)  /.728806607587188E+00/, CD(8)  /.101122770102872E+01/,
     *     CD(9)  /.136598448171249E+01/, CD(10) /.181510139038929E+01/,
     *     CD(11) /.238824701955419E+01/, CD(12) /.312490532008812E+01/,
     *     CD(13) /.407802489894445E+01/, CD(14) /.532033545554865E+01/,
     *     CD(15) /.695624307290579E+01/, CD(16) /.914759902547031E+01/,
     *     CD(17) /.121829074388544E+02/, CD(18) /.167511311969873E+02/
      DATA CE(1)  /.349517258926827E-01/, CE(2)  /.135849105925897E+00/,
     *     CE(3)  /.158850581552296E+00/, CE(4)  /.153001434535435E+00/,
     *     CE(5)  /.134520752856461E+00/, CE(6)  /.111913051619671E+00/,
     *     CE(7)  /.892008386656190E-01/, CE(8)  /.679227205472067E-01/,
     *     CE(9)  /.486723197887211E-01/, CE(10) /.320170976532266E-01/,
     *     CE(11) /.187008965021111E-01/, CE(12) /.929708414427865E-02/,
     *     CE(13) /.372604763161087E-02/, CE(14) /.111989537559823E-02/,
     *     CE(15) /.228057496872353E-03/, CE(16) /.269596227781453E-04/,
     *     CE(17) /.141255430224301E-05/, CE(18) /.176352326808806E-07/
C-------------------------
      X = REAL(Z)
      Y = AIMAG(Z)
      R = X*X + Y*Y
C
      IF (R .LE. 1.0) GO TO 100
      IF (R .GE. 1296.0) GO TO 10
      IF (X .LT. 0.07*Y*Y) GO TO 30
      GO TO 40
C-----------------------------------------------------------------------
C                     ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
   10 QF(1) =  X/R
      QF(2) = -Y/R
      SM(1) = -QF(1)
      SM(2) = -QF(2)
      TM(1) =  SM(1)
      TM(2) =  SM(2)
      PM = 1.0
   20    TS(1) = TM(1)*QF(1) - TM(2)*QF(2)
         TS(2) = TM(1)*QF(2) + TM(2)*QF(1)
         TM(1) = PM*TS(1)
         TM(2) = PM*TS(2)
         PM = PM + 1.0
         TS(1) = TM(1)/PM
         TS(2) = TM(2)/PM
         IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 21
         IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 130
   21    SM(1) = SM(1) + TS(1)
         SM(2) = SM(2) + TS(2)
         IF (PM .LT. 36.0) GO TO 20
      GO TO 130
C-----------------------------------------------------------------------
C                      RATIONAL EXPANSION
C-----------------------------------------------------------------------
   30 SM(1) = 0.0
      SM(2) = 0.0
      DO 31 I = 1,18
         TS(1) = X - CD(I)
         TS(2) = Y
         SS = TS(1)*TS(1) + TS(2)*TS(2)
         TM(1) = -CE(I)*TS(1)/SS
         TM(2) =  CE(I)*TS(2)/SS
         SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
   31 CONTINUE
      GO TO 130
C-----------------------------------------------------------------------
C                 EXPANSION INVOLVING EI AND DI
C-----------------------------------------------------------------------
   40 ZL(1) = EULER + 0.5*ALOG(R)
      ZL(2) = ATAN2(-Y, -X)
C
C                    SET SM = EXP(Z)*EI(-Z)
C
      SM(1) = 0.0
      SM(2) = 0.0
      DO 50 I = 1,18
         TS(1) = -X - ED(I)
         TS(2) = -Y
         SS = TS(1)*TS(1) + TS(2)*TS(2)
         TM(1) =  EE(I)*TS(1)/SS
         TM(2) = -EE(I)*TS(2)/SS
         SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
   50 CONTINUE
      SR(1) = ZL(1)*SM(1) - ZL(2)*SM(2)
      SR(2) = ZL(1)*SM(2) + ZL(2)*SM(1)
C
C                    SET SM = EXP(Z)*DI(-Z)
C
      SM(1) = 0.0
      SM(2) = 0.0
      DO 60 I = 1,19
         TS(1) = -X - DD(I)
         TS(2) = -Y
         SS = TS(1)*TS(1) + TS(2)*TS(2)
         TM(1) =  DE(I)*TS(1)/SS
         TM(2) = -DE(I)*TS(2)/SS
         SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
   60 CONTINUE
      TS(1) = -(X*SM(1) + Y*SM(2))/R
      TS(2) = -(X*SM(2) - Y*SM(1))/R
C
C                    COMPUTE THE EXPANSION
C
      SR(1) = SR(1) - TS(1) - ZETA2
      SR(2) = SR(2) - TS(2)
      SM(1) = 0.0
      SM(2) = 0.0
      TM(1) = 1.0
      TM(2) = 0.0
      PM = 0.0
      QM = ZETA2
   70    PM = PM + 1.0
         QM = QM - 1.0/(PM*PM)
         TS(1) = TM(1)*X - TM(2)*Y
         TS(2) = TM(1)*Y + TM(2)*X
         TM(1) = TS(1)/PM
         TM(2) = TS(2)/PM
         TS(1) = QM*TM(1)
         TS(2) = QM*TM(2)
         IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 71
         IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 80
   71    SM(1) = SM(1) - TS(1)
         SM(2) = SM(2) - TS(2)
         GO TO 70
   80 SM(1) = SR(1) + SM(1)
      SM(2) = SR(2) + SM(2)
C
C                      COMPUTE EXP(-Z)*SM
C
      QM = EXP(-X)
      QF(1) = QM*COS(-Y)
      QF(2) = QM*SIN(-Y)
      TS(1) = QF(1)*SM(1) - QF(2)*SM(2)
      TS(2) = QF(1)*SM(2) + QF(2)*SM(1)
      SM(1) = TS(1)
      SM(2) = TS(2)
      GO TO 130
C-----------------------------------------------------------------------
C                  SERIES FOR X*X + Y*Y .LE. 1
C-----------------------------------------------------------------------
  100 SM(1) = 0.0
      SM(2) = 0.0
      ZL(1) = EULER + 0.5*ALOG(R)
      ZL(2) = ATAN2(-Y, -X)
      SR(1) = CONST + 0.5*(ZL(1)*ZL(1) - ZL(2)*ZL(2))
      SR(2) = ZL(1)*ZL(2)
      TM(1) = 1.0
      TM(2) = 0.0
      PM = 0.0
      QM = 0.0
  110    PM = PM + 1.0
         QM = QM + 1.0/PM
         TS(1) = -TM(1)*X + TM(2)*Y
         TS(2) = -TM(1)*Y - TM(2)*X
         TM(1) = TS(1)/PM
         TM(2) = TS(2)/PM
         R = (ZL(1) - 1.0/PM) - QM
         TS(1) = (R*TM(1) - ZL(2)*TM(2))/PM
         TS(2) = (R*TM(2) + ZL(2)*TM(1))/PM
         IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 111
         IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 120
  111    SM(1) = SM(1) + TS(1)
         SM(2) = SM(2) + TS(2)
         GO TO 110
  120 SM(1) = SR(1) + SM(1)
      SM(2) = SR(2) + SM(2)
C-----------------------------------------------------------------------
C                         TERMINATION
C-----------------------------------------------------------------------
  130 W = CMPLX(SM(1), SM(2))
      RETURN
      END
      COMPLEX FUNCTION CLI(Z)
C     ******************************************************************
C     COMPUTATION OF THE COMPLEX LOGARITHMIC INTEGRAL
C     ******************************************************************
      COMPLEX Z
      REAL QB(25), QF(2), DL(2), DS, ZD(2), ZL(2)
      REAL AZ(2), C, PM, R, SM(2), TM(2), TS(2), SR(2)
C     ---------------------
C     C = PI**2/6
C     ---------------------
      DATA C /1.64493406684823/
C     ---------------------
      DATA QB(1) / 2.77777777777778E-2/,  QB(2) /-1.00000000000000E-2/,
     1     QB(3) /-1.70068027210884E-2/,  QB(4) /-1.94444444444444E-2/,
     2     QB(5) /-2.06611570247934E-2/,  QB(6) /-2.14173006480699E-2/,
     3     QB(7) /-2.19488663772311E-2/,  QB(8) /-2.23492338111715E-2/,
     4     QB(9) /-2.26636891351914E-2/,  QB(10)/-2.29178211549926E-2/,
     5     QB(11)/-2.31276449354844E-2/,  QB(12)/-2.33038680700203E-2/,
     6     QB(13)/-2.34539766464373E-2/,  QB(14)/-2.35833786876607E-2/,
     7     QB(15)/-2.36960832049849E-2/,  QB(16)/-2.37951264448373E-2/,
     8     QB(17)/-2.38828504258091E-2/,  QB(18)/-2.39610907251825E-2/,
     9     QB(19)/-2.40313063764460E-2/,  QB(20)/-2.40946717197585E-2/,
     1     QB(21)/-2.41521426124012E-2/,  QB(22)/-2.42045049812210E-2/,
     2     QB(23)/-2.42524109782181E-2/,  QB(24)/-2.42964062815807E-2/,
     3     QB(25)/-2.43369509729144E-2/
C     ---------------------
      AZ(1) = REAL(Z)
      AZ(2) = AIMAG(Z)
      R = CPABS(AZ(1),AZ(2))
      IF (R .GT. 0.5) GO TO 10
      SR(1) = 0.0
      SR(2) = 0.0
      QF(1) = -AZ(1)
      QF(2) = -AZ(2)
      TM(1) =  AZ(1)
      TM(2) =  AZ(2)
      GO TO 30
C
   10 IF (R .LT. 3.0) GO TO 20
      ZL(1) = ALOG(R)
      ZL(2) = ATAN2(AZ(2),AZ(1))
      SR(1) = C + 0.5*(ZL(1)*ZL(1) - ZL(2)*ZL(2))
      SR(2) = ZL(1)*ZL(2)
      QF(1) = (-AZ(1)/R)/R
      QF(2) = (AZ(2)/R)/R
      TM(1) = QF(1)
      TM(2) = QF(2)
      GO TO 30
C
   20 ZD(1) = 1.0 + AZ(1)
      ZD(2) = AZ(2)
      DS = ZD(1)*ZD(1) + ZD(2)*ZD(2)
      IF (DS .EQ. 0.0) GO TO 100
      DL(1) = 0.5*ALOG(DS)
      DL(2) = ATAN2(ZD(2),ZD(1))
      IF (DS .GT. 0.25) GO TO 50
         ZL(1) = ALOG(R)
         ZL(2) = ATAN2(-AZ(2),-AZ(1))
         SR(1) = -C + (DL(1)*ZL(1) - DL(2)*ZL(2))
         SR(2) = DL(1)*ZL(2) + DL(2)*ZL(1)
         QF(1) = ZD(1)
         QF(2) = ZD(2)
         TM(1) = QF(1)
         TM(2) = QF(2)
C
C             EVALUATION OF THE TAYLOR SERIES
C
   30 SR(1) = SR(1) + TM(1)
      SR(2) = SR(2) + TM(2)
      SM(1) = 0.0
      SM(2) = 0.0
      PM = 1.0
   40    PM = PM + 1.0
         TS(1) = TM(1)*QF(1) - TM(2)*QF(2)
         TS(2) = TM(1)*QF(2) + TM(2)*QF(1)
         TM(1) = TS(1)
         TM(2) = TS(2)
         TS(1) = TM(1)/(PM*PM)
         TS(2) = TM(2)/(PM*PM)
         IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 41
         IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 80
   41    SM(1) = SM(1) + TS(1)
         SM(2) = SM(2) + TS(2)
         GO TO 40
C
C        EVALUATION OF THE SERIES IN  U = -LN(1 + Z)
C
   50 QF(1) = DL(1)*DL(1) - DL(2)*DL(2)
      QF(2) = 2.0*DL(1)*DL(2)
      SR(1) = DL(1) + 0.25*QF(1)
      SR(2) = DL(2) + 0.25*QF(2)
      SM(1) = 0.0
      SM(2) = 0.0
      TM(1) = DL(1)
      TM(2) = DL(2)
      DO 61 N = 1,25
         TS(1) = QB(N)*(TM(1)*QF(1) - TM(2)*QF(2))
         TS(2) = QB(N)*(TM(1)*QF(2) + TM(2)*QF(1))
         TM(1) = TS(1)
         TM(2) = TS(2)
         IF (ABS(SM(1)) + ABS(TM(1)) .NE. ABS(SM(1))) GO TO 60
         IF (ABS(SM(2)) + ABS(TM(2)) .EQ. ABS(SM(2))) GO TO 80
   60    SM(1) = SM(1) + TM(1)
         SM(2) = SM(2) + TM(2)
   61 CONTINUE
C
   80 CLI = CMPLX(SR(1) + SM(1), SR(2) + SM(2))
      RETURN
C
C                  EVALUATION AT Z = -1
C
  100 CLI = CMPLX(-C, 0.0)
      RETURN
      END
      REAL FUNCTION ALI(X)
C-----------------------------------------------------------------------
C            COMPUTATION OF THE REAL DILOGARITHM FUNCTION
C-----------------------------------------------------------------------
C     WRITTEN BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN VIRGINIA
C-----------------------------------------------------------------------
      REAL A(5), B(6), C(10), D(2), E(18), P(4), Q(8), R(7), S(6)
      DOUBLE PRECISION X0
C--------------------------
C     CONST = PI**2/6
C     X0 = ZERO OF THE REAL DILOGARITHM FUNCTION
C--------------------------
      DATA CONST /1.64493406684823/
      DATA X0 /-12.5951703698450161286398965D0/
C--------------------------
      DATA A(1)/.217590467528373E+01/, A(2)/.165569610692639E+01/,
     *     A(3)/.522944061702389E+00/, A(4)/.626073688152965E-01/,
     *     A(5)/.187280204672313E-02/
      DATA B(1)/.242590467528371E+01/, B(2)/.215106116463796E+01/,
     *     B(3)/.853664388896516E+00/, B(4)/.148635712775060E+00/,
     *     B(5)/.936304016023909E-02/, B(6)/.115362459229893E-03/
C--------------------------
      DATA C(1)/-.139792925233661E+01/, C(2) /.368504569727477E+00/,
     *     C(3) /.467406917183686E-01/, C(4) /.113795257294490E-01/,
     *     C(5) /.369638462505741E-02/, C(6) /.140888669464352E-02/,
     *     C(7) /.580505641503297E-03/, C(8) /.279065584075104E-03/,
     *     C(9) /.727678355839120E-04/, C(10)/.941452067850052E-04/
      DATA D(1)/-.164792925233634E+01/, D(2) /.669375771675355E+00/
C--------------------------
      DATA E(1)/-.194565741631859E+00/, E(2)/-.430017756528812E-02/,
     *     E(3)/-.129188263110634E-03/, E(4)/-.344864872694838E-05/,
     *     E(5) /.566899694553089E-09/, E(6) /.126641834906132E-07/,
     *     E(7) /.163966793864421E-08/, E(8) /.164221074630109E-09/,
     *     E(9) /.149644905021032E-10/, E(10)/.130214292886747E-11/,
     *     E(11)/.110415518123737E-12/, E(12)/.921674760163207E-14/,
     *     E(13)/.761646464974859E-15/, E(14)/.625216733700975E-16/,
     *     E(15)/.510910937990370E-17/, E(16)/.416215390793180E-18/,
     *     E(17)/.338357379188308E-19/, E(18)/.274674744366340E-20/
C--------------------------
      DATA P(1)/-.124827318209942E+01/, P(2)/-.593706951284264E-01/,
     *     P(3)/ .368603360394688E-01/, P(4)/ .243497524184253E-02/
      DATA Q(1)/ .100000000000000E+01/, Q(2)/ .252618047164349E+00/,
     *     Q(3)/ .171618729068655E-01/, Q(4)/ .234444792844727E-03/,
     *     Q(5)/-.174928841869743E-05/, Q(6)/ .347369010951250E-07/,
     *     Q(7)/-.713275908929482E-09/, Q(8)/ .958397514026421E-11/
C--------------------------
      DATA R(1)/.265189940015693E+00/, R(2)/.230201018075415E+00/,
     *     R(3)/.315999623504943E-01/, R(4)/.154066621939470E-02/,
     *     R(5)/.286697611038892E-04/, R(6)/.163031291368652E-06/,
     *     R(7)/.838957807732251E-10/
      DATA S(1)/.100000000000000E+01/, S(2)/.177195068872258E+00/,
     *     S(3)/.110559275223905E-01/, S(4)/.291916852717175E-03/,
     *     S(5)/.304793254397420E-05/, S(6)/.882114921507386E-08/
C--------------------------
C
      IF (X .GT. 1.0) GO TO 50
      IF (X .GE. 0.0) GO TO 40
      IF (X .GE.-0.5) GO TO 30
      IF (X .GE.-1.0) GO TO 20
      IF (X .GE.-2.0) GO TO 10
C
C                            X .LT. -2
C
      IF (X .GE. -26.63 .AND. X .LE. -6.97) GO TO 100
      T = -1.0/X
      W = (((((((((((C(10)*T + C(9))*T + C(8))*T + C(7))*T + C(6))*T +
     *               C(5))*T + C(4))*T + C(3))*T + C(2))*T + C(1))*T +
     *               0.5) + 0.5) / ((D(2)*T + D(1))*T + 1.0)
      ALI = 0.5*ALOG(-X)**2 - (2.0*CONST + W/X)
      RETURN
C
C                        -2 .LE. X .LT. -1
C
   10 T = -(1.0 + X)
      W = (((((A(5)*T + A(4))*T + A(3))*T + A(2))*T + A(1))*T + 1.0)/
     *    ((((((B(6)*T + B(5))*T + B(4))*T + B(3))*T + B(2))*T +
     *          B(1))*T + 1.0)
      ALI = -(CONST + T*W) + ALOG(-X)*ALOG(T)
      RETURN
C
C                       -1 .LE. X .LT. -1/2
C
   20 T = 0.5 + (0.5 + X)
      ALI = -CONST
      IF (T .EQ. 0.0) RETURN
      W = (((((((((((C(10)*T + C(9))*T + C(8))*T + C(7))*T + C(6))*T +
     *               C(5))*T + C(4))*T + C(3))*T + C(2))*T + C(1))*T +
     *               0.5) + 0.5) / ((D(2)*T + D(1))*T + 1.0)
      ALI = (-CONST + T*W) + ALOG(-X)*ALOG(T)
      RETURN
C
C                       -1/2 .LE. X .LT. 0
C
   30 T = -X
      W = (((((((((((C(10)*T + C(9))*T + C(8))*T + C(7))*T + C(6))*T +
     *               C(5))*T + C(4))*T + C(3))*T + C(2))*T + C(1))*T +
     *               0.5) + 0.5) / ((D(2)*T + D(1))*T + 1.0)
      ALI = X*W
      RETURN
C
C                         0 .LE. X .LE. 1
C
   40 W = (((((A(5)*X + A(4))*X + A(3))*X + A(2))*X + A(1))*X + 1.0)/
     *    ((((((B(6)*X + B(5))*X + B(4))*X + B(3))*X + B(2))*X +
     *          B(1))*X + 1.0)
      ALI = X*W
      RETURN
C
C                            X .GT. 1
C
   50 T = 1.0/X
      W = (((((A(5)*T + A(4))*T + A(3))*T + A(2))*T + A(1))*T + 1.0)/
     *    ((((((B(6)*T + B(5))*T + B(4))*T + B(3))*T + B(2))*T +
     *          B(1))*T + 1.0)
      ALI = (CONST - W/X) + 0.5*ALOG(X)**2
      RETURN
C
C-----------------------------------------------------------------------
C              EVALUATION FOR  -26.63 .LE. X .LE. -6.97
C-----------------------------------------------------------------------
C
  100 IF (X .LE. -14.0) GO TO 120
      IF (X .LE. -11.1) GO TO 110
C
C                    -11.1 .LT. X .LE. -6.97
C
      T = -(X + 7.0)
      ALI = (((P(4)*T + P(3))*T + P(2))*T + P(1)) / (((((((Q(8)*T +
     *         Q(7))*T + Q(6))*T + Q(5))*T + Q(4))*T + Q(3))*T +
     *         Q(2))*T + Q(1))
      RETURN

C
C                     -14 .LT. X .LE. -11.1
C
  110 T = DBLE(X) - X0
      W = E(14)
      DO 111 L = 1,13
         I = 14 - L
  111    W = W*T + E(I)
      ALI = T*W
      RETURN
C
C                     -26.63 .LE. X .LE. -14
C
  120 T = -(X + 14.0)
      ALI = ((((((R(7)*T + R(6))*T + R(5))*T + R(4))*T + R(3))*T +
     *            R(2))*T + R(1)) / (((((S(6)*T + S(5))*T +
     *            S(4))*T + S(3))*T + S(2))*T + S(1))
      RETURN
      END
      SUBROUTINE CGAMMA (MO, Z, W)
C-----------------------------------------------------------------------
C
C        EVALUATION OF THE COMPLEX GAMMA AND LOGGAMMA FUNCTIONS
C
C                        ---------------
C
C     MO IS AN INTEGER, Z A COMPLEX ARGUMENT, AND W A COMPLEX VARIABLE.
C
C                 W = GAMMA(Z)       IF MO = 0
C                 W = LN(GAMMA(Z))   OTHERWISE
C
C-----------------------------------------------------------------------
      COMPLEX Z, W
      COMPLEX ETA, ETA2, SUM
      REAL C0(12)
C---------------------------
C     ALPI = LOG(PI)
C     HL2P = 0.5 * LOG(2*PI)
C---------------------------
      DATA PI  /3.14159265358979/
      DATA PI2 /6.28318530717959/
      DATA ALPI/1.14472988584940/
      DATA HL2P/.918938533204673/
C---------------------------
      DATA C0(1) /.833333333333333E-01/, C0(2) /-.277777777777778E-02/,
     *     C0(3) /.793650793650794E-03/, C0(4) /-.595238095238095E-03/,
     *     C0(5) /.841750841750842E-03/, C0(6) /-.191752691752692E-02/,
     *     C0(7) /.641025641025641E-02/, C0(8) /-.295506535947712E-01/,
     *     C0(9) /.179644372368831E+00/, C0(10)/-.139243221690590E+01/,
     *     C0(11)/.134028640441684E+02/, C0(12)/-.156848284626002E+03/
C---------------------------
C
C     ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS.
C            MAX IS THE LARGEST POSITIVE INTEGER THAT MAY
C            BE USED, AND EPS IS THE SMALLEST REAL NUMBER
C            SUCH THAT 1.0 + EPS .GT. 1.0.
C
                      MAX = IPMPAR(3)
                      EPS = SPMPAR(1)
C
C---------------------------
      X = REAL(Z)
      Y = AIMAG(Z)
      IF (X .GE. 0.0) GO TO 50
C-----------------------------------------------------------------------
C            CASE WHEN THE REAL PART OF Z IS NEGATIVE
C-----------------------------------------------------------------------
      Y = ABS(Y)
      T = -PI*Y
      ET = EXP(T)
      E2T = ET*ET
C
C     SET  A1 = (1 + E2T)/2  AND  A2 = (1 - E2T)/2
C
      A1 = 0.5*(1.0 + E2T)
      T2 = T + T
      IF (T2 .LT. -0.15) GO TO 10
         A2 = -0.5*REXP(T2)
         GO TO 20
   10 A2 = 0.5*(0.5 + (0.5 - E2T))
C
C     COMPUTE SIN(PI*X) AND COS(PI*X)
C
   20 IF (ABS(X) .GE. AMIN1(FLOAT(MAX), 1.0/EPS)) GO TO 200
      K = ABS(X)
      U = X + K
      K = MOD(K,2)
      IF (U .GT. -0.5) GO TO 21
         U = 0.5 + (0.5 + U)
         K = K + 1
   21 U = PI*U
      SN = SIN(U)
      CN = COS(U)
      IF (K .NE. 1) GO TO 30
      SN = -SN
      CN = -CN
C
C     SET  H1 + H2*I  TO  PI/SIN(PI*Z)  OR  LOG(PI/SIN(PI*Z))
C
   30 A1 = SN*A1
      A2 = CN*A2
      A = A1*A1 + A2*A2
      IF (A .EQ. 0.0) GO TO 200
      IF (MO .NE. 0) GO TO 40
C
      H1 = A1/A
      H2 = -A2/A
      C = PI*ET
      H1 = C*H1
      H2 = C*H2
      GO TO 41
C
   40 H1 = (ALPI + T) - 0.5*ALOG(A)
      H2 = -ATAN2(A2,A1)
   41 IF (AIMAG(Z) .LT. 0.0) GO TO 42
         X = 1.0 - X
         Y = -Y
         GO TO 50
   42 H2 = -H2
      X = 1.0 - X
C-----------------------------------------------------------------------
C           CASE WHEN THE REAL PART OF Z IS NONNEGATIVE
C-----------------------------------------------------------------------
   50 W1 = 0.0
      W2 = 0.0
      N = 0
      T = X
      Y2 = Y*Y
      A = T*T + Y2
      CUT = 36.0
      IF (EPS .GT. 1.E-8) CUT = 16.0
      IF (A .GE. CUT) GO TO 80
      IF (A .EQ. 0.0) GO TO 200
   51    N = N + 1
         T = T + 1.0
         A = T*T + Y2
         IF (A .LT. CUT) GO TO 51
C
C     LET S1 + S2*I BE THE PRODUCT OF THE TERMS (Z+J)/(Z+N)
C
      U1 = (X*T + Y2)/A
      U2 = Y/A
      S1 = U1
      S2 = N*U2
      IF (N .LT. 2) GO TO 70
      U = T/A
      NM1 = N - 1
      DO 60 J = 1,NM1
         V1 = U1 + J*U
         V2 = (N - J)*U2
         C = S1*V1 - S2*V2
         D = S1*V2 + S2*V1
         S1 = C
         S2 = D
   60 CONTINUE
C
C     SET  W1 + W2*I = LOG(S1 + S2*I)  WHEN MO IS NONZERO
C
   70 S = S1*S1 + S2*S2
      IF (MO .EQ. 0) GO TO 80
      W1 = 0.5 * ALOG(S)
      W2 = ATAN2(S2,S1)
C
C     SET  V1 + V2*I = (Z - 0.5) * LOG(Z + N) - Z
C
   80 T1 = 0.5 * ALOG(A) - 1.0
      T2 = ATAN2(Y,T)
      U = X - 0.5
      V1 = (U*T1 - 0.5) - Y*T2
      V2 = U*T2 + Y*T1
C
C     LET A1 + A2*I BE THE ASYMPTOTIC SUM
C
      ETA  = CMPLX(T/A,-Y/A)
      ETA2 = ETA*ETA
      M = 12
      IF (A .GE. 289.0) M = 6
      IF (EPS .GT. 1.E-8) M = M/2
      SUM  = CMPLX(C0(M),0.0)
      L = M
      DO 90 J = 2,M
         L = L - 1
         SUM = CMPLX(C0(L),0.0) + SUM*ETA2
   90 CONTINUE
      SUM = SUM*ETA
      A1 = REAL(SUM)
      A2 = AIMAG(SUM)
C-----------------------------------------------------------------------
C                 GATHERING TOGETHER THE RESULTS
C-----------------------------------------------------------------------
      W1 = (((A1 + HL2P) - W1) + V1) - N
      W2 = (A2 - W2) + V2
      IF (REAL(Z) .LT. 0.0) GO TO 120
      IF (MO .NE. 0) GO TO 110
C
C     CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO = 0
C
      A = EXP(W1)
      W1 = A * COS(W2)
      W2 = A * SIN(W2)
      IF (N .EQ. 0) GO TO 140
      C = (S1*W1 + S2*W2)/S
      D = (S1*W2 - S2*W1)/S
      W1 = C
      W2 = D
      GO TO 140
C
C     CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO IS NONZERO.
C     THE ANGLE W2 IS REDUCED TO THE INTERVAL -PI .LT. W2 .LE. PI.
C
  110 IF (W2 .GT. PI) GO TO 111
         K = 0.5 - W2/PI2
         W2 = W2 + PI2*K
         GO TO 140
  111 K = W2/PI2 - 0.5
      W2 = W2 - PI2*FLOAT(K + 1)
      IF (W2 .LE. -PI) W2 = PI
      GO TO 140
C
C     CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO IS NONZERO
C
  120 IF (MO .EQ. 0) GO TO 130
      W1 = H1 - W1
      W2 = H2 - W2
      GO TO 110
C
C     CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO = 0
C
  130 A = EXP(-W1)
      T1 = A * COS(-W2)
      T2 = A * SIN(-W2)
      W1 = H1*T1 - H2*T2
      W2 = H1*T2 + H2*T1
      IF (N .EQ. 0) GO TO 140
      C = W1*S1 - W2*S2
      D = W1*S2 + W2*S1
      W1 = C
      W2 = D
C
C     TERMINATION
C
  140 W = CMPLX(W1,W2)
      RETURN
C-----------------------------------------------------------------------
C             THE REQUESTED VALUE CANNOT BE COMPUTED
C-----------------------------------------------------------------------
  200 W = (0.0, 0.0)
      RETURN
      END
      COMPLEX FUNCTION CGAM0 (Z)
C-----------------------------------------------------------------------
C          EVALUATION OF 1/GAMMA(1 + Z)  FOR ABS(Z) .LT. 1.0
C-----------------------------------------------------------------------
      COMPLEX Z, W
      REAL A(25)
C-----------------------
      DATA A(1)  / .577215664901533E+00/, A(2)  /-.655878071520254E+00/,
     *     A(3)  /-.420026350340952E-01/, A(4)  / .166538611382291E+00/,
     *     A(5)  /-.421977345555443E-01/, A(6)  /-.962197152787697E-02/,
     *     A(7)  / .721894324666310E-02/, A(8)  /-.116516759185907E-02/,
     *     A(9)  /-.215241674114951E-03/, A(10) / .128050282388116E-03/,
     *     A(11) /-.201348547807882E-04/, A(12) /-.125049348214267E-05/,
     *     A(13) / .113302723198170E-05/, A(14) /-.205633841697761E-06/,
     *     A(15) / .611609510448142E-08/, A(16) / .500200764446922E-08/,
     *     A(17) /-.118127457048702E-08/, A(18) / .104342671169110E-09/,
     *     A(19) / .778226343990507E-11/, A(20) /-.369680561864221E-11/
      DATA A(21) / .510037028745448E-12/, A(22) /-.205832605356651E-13/,
     *     A(23) /-.534812253942302E-14/, A(24) / .122677862823826E-14/,
     *     A(25) /-.118125930169746E-15/
C-----------------------
      N = 25
      X = REAL(Z)
      Y = AIMAG(Z)
      IF (X*X + Y*Y .LE. 0.04) N = 14
C
      K = N
      W = A(N)
      DO 10 I = 2,N
         K = K - 1
         W = A(K) + Z*W
   10 CONTINUE
      CGAM0 = 1.0 + Z*W
      RETURN
      END
      REAL FUNCTION GAMMA(A)
C-----------------------------------------------------------------------
C
C         EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS
C
C                           -----------
C
C     GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT
C     BE COMPUTED.
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C          NAVAL SURFACE WEAPONS CENTER
C          DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
      REAL P(7), Q(7)
      DOUBLE PRECISION D, G, Z, LNX, GLOG
C--------------------------
C     D = 0.5*(LN(2*PI) - 1)
C--------------------------
      DATA PI /3.1415926535898/
      DATA D /.41893853320467274178D0/
C--------------------------
      DATA P(1)/ .539637273585445E-03/,  P(2)/ .261939260042690E-02/,
     1     P(3)/ .204493667594920E-01/,  P(4)/ .730981088720487E-01/,
     2     P(5)/ .279648642639792E+00/,  P(6)/ .553413866010467E+00/,
     3     P(7)/ 1.0/
      DATA Q(1)/-.832979206704073E-03/,  Q(2)/ .470059485860584E-02/,
     1     Q(3)/ .225211131035340E-01/,  Q(4)/-.170458969313360E+00/,
     2     Q(5)/-.567902761974940E-01/,  Q(6)/ .113062953091122E+01/,
     3     Q(7)/ 1.0/
C--------------------------
      DATA R1/.820756370353826E-03/, R2/-.595156336428591E-03/,
     1     R3/.793650663183693E-03/, R4/-.277777777770481E-02/,
     2     R5/.833333333333333E-01/
C--------------------------
      GAMMA = 0.0
      X = A
      IF (ABS(A) .GE. 15.0) GO TO 60
C-----------------------------------------------------------------------
C            EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15
C-----------------------------------------------------------------------
      T = 1.0
      M = INT(A) - 1
C
C     LET T BE THE PRODUCT OF A-J WHEN A .GE. 2
C
      IF (M) 20,12,10
   10 DO 11 J = 1,M
        X = X - 1.0
   11   T = X*T
   12 X = X - 1.0
      GO TO 40
C
C     LET T BE THE PRODUCT OF A+J WHEN A .LT. 1
C
   20 T = A
      IF (A .GT. 0.0) GO TO 30
      M = - M - 1
      IF (M .EQ. 0) GO TO 22
         DO 21 J = 1,M
         X = X + 1.0
   21    T = X*T
   22 X = (X + 0.5) + 0.5
      T = X*T
      IF (T .EQ. 0.0) RETURN
C
   30 CONTINUE
C
C     THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS
C     CODE MAY BE OMITTED IF DESIRED.
C
      IF (ABS(T) .GE. 1.E-30) GO TO 40
      IF (ABS(T)*SPMPAR(3) .LE. 1.0001) RETURN
      GAMMA = 1.0/T
      RETURN
C
C     COMPUTE GAMMA(1 + X) FOR  0 .LE. X .LT. 1
C
   40 TOP = P(1)
      BOT = Q(1)
      DO 41 I = 2,7
         TOP = P(I) + X*TOP
   41    BOT = Q(I) + X*BOT
      GAMMA = TOP/BOT
C
C     TERMINATION
C
      IF (A .LT. 1.0) GO TO 50
      GAMMA = GAMMA*T
      RETURN
   50 GAMMA = GAMMA/T
      RETURN
C-----------------------------------------------------------------------
C            EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15
C-----------------------------------------------------------------------
   60 IF (ABS(A) .GE. 1.E3) RETURN
      IF (A .GT. 0.0) GO TO 70
      X = -A
      N = X
      T = X - N
      IF (T .GT. 0.9) T = 1.0 - T
      S = SIN(PI*T)/PI
      IF (MOD(N,2) .EQ. 0) S = -S
      IF (S .EQ. 0.0) RETURN
C
C     COMPUTE THE MODIFIED ASYMPTOTIC SUM
C
   70 T = 1.0/(X*X)
      G = ((((R1*T + R2)*T + R3)*T + R4)*T + R5)/X
C
C     ONE MAY REPLACE THE NEXT STATEMENT WITH  LNX = ALOG(X)
C     BUT LESS ACCURACY WILL NORMALLY BE OBTAINED.
C
      LNX = GLOG(X)
C
C     FINAL ASSEMBLY
C
      Z = X
      G = (D + G) + (Z - 0.5D0)*(LNX - 1.D0)
      W = G
      T = G - DBLE(W)
      IF (W .GT. 0.99999*EXPARG(0)) RETURN
      GAMMA = EXP(W)*(1.0 + T)
      IF (A .LT. 0.0) GAMMA = (1.0/(GAMMA*S))/X
      RETURN
      END
      DOUBLE PRECISION FUNCTION GLOG(X)
C     -------------------
C     EVALUATION OF LN(X) FOR X .GE. 15
C     -------------------
      REAL X
      DOUBLE PRECISION Z, W(163)
C     -------------------
      DATA C1/.286228750476730/, C2/.399999628131494/,
     1     C3/.666666666752663/
C     -------------------
C     W(J) = LN(J + 14) FOR EACH J
C     -------------------
      DATA W(1) /.270805020110221007D+01/,
     1 W(2) /.277258872223978124D+01/, W(3) /.283321334405621608D+01/,
     2 W(4) /.289037175789616469D+01/, W(5) /.294443897916644046D+01/,
     3 W(6) /.299573227355399099D+01/, W(7) /.304452243772342300D+01/,
     4 W(8) /.309104245335831585D+01/, W(9) /.313549421592914969D+01/,
     5 W(10)/.317805383034794562D+01/, W(11)/.321887582486820075D+01/,
     6 W(12)/.325809653802148205D+01/, W(13)/.329583686600432907D+01/,
     7 W(14)/.333220451017520392D+01/, W(15)/.336729582998647403D+01/,
     8 W(16)/.340119738166215538D+01/, W(17)/.343398720448514625D+01/,
     9 W(18)/.346573590279972655D+01/, W(19)/.349650756146648024D+01/,
     1 W(20)/.352636052461616139D+01/, W(21)/.355534806148941368D+01/,
     2 W(22)/.358351893845611000D+01/, W(23)/.361091791264422444D+01/,
     3 W(24)/.363758615972638577D+01/, W(25)/.366356164612964643D+01/,
     4 W(26)/.368887945411393630D+01/, W(27)/.371357206670430780D+01/,
     5 W(28)/.373766961828336831D+01/, W(29)/.376120011569356242D+01/,
     6 W(30)/.378418963391826116D+01/
      DATA W(31)/.380666248977031976D+01/,
     1 W(32)/.382864139648909500D+01/, W(33)/.385014760171005859D+01/,
     2 W(34)/.387120101090789093D+01/, W(35)/.389182029811062661D+01/,
     3 W(36)/.391202300542814606D+01/, W(37)/.393182563272432577D+01/,
     4 W(38)/.395124371858142735D+01/, W(39)/.397029191355212183D+01/,
     5 W(40)/.398898404656427438D+01/, W(41)/.400733318523247092D+01/,
     6 W(42)/.402535169073514923D+01/, W(43)/.404305126783455015D+01/,
     7 W(44)/.406044301054641934D+01/, W(45)/.407753744390571945D+01/,
     8 W(46)/.409434456222210068D+01/, W(47)/.411087386417331125D+01/,
     9 W(48)/.412713438504509156D+01/, W(49)/.414313472639153269D+01/,
     1 W(50)/.415888308335967186D+01/, W(51)/.417438726989563711D+01/,
     2 W(52)/.418965474202642554D+01/, W(53)/.420469261939096606D+01/,
     3 W(54)/.421950770517610670D+01/, W(55)/.423410650459725938D+01/,
     4 W(56)/.424849524204935899D+01/, W(57)/.426267987704131542D+01/,
     5 W(58)/.427666611901605531D+01/, W(59)/.429045944114839113D+01/,
     6 W(60)/.430406509320416975D+01/
      DATA W(61)/.431748811353631044D+01/,
     1 W(62)/.433073334028633108D+01/, W(63)/.434380542185368385D+01/,
     2 W(64)/.435670882668959174D+01/, W(65)/.436944785246702149D+01/,
     3 W(66)/.438202663467388161D+01/, W(67)/.439444915467243877D+01/,
     4 W(68)/.440671924726425311D+01/, W(69)/.441884060779659792D+01/,
     5 W(70)/.443081679884331362D+01/, W(71)/.444265125649031645D+01/,
     6 W(72)/.445434729625350773D+01/, W(73)/.446590811865458372D+01/,
     7 W(74)/.447733681447820647D+01/, W(75)/.448863636973213984D+01/,
     8 W(76)/.449980967033026507D+01/, W(77)/.451085950651685004D+01/,
     9 W(78)/.452178857704904031D+01/, W(79)/.453259949315325594D+01/,
     1 W(80)/.454329478227000390D+01/, W(81)/.455387689160054083D+01/,
     2 W(82)/.456434819146783624D+01/, W(83)/.457471097850338282D+01/,
     3 W(84)/.458496747867057192D+01/, W(85)/.459511985013458993D+01/,
     4 W(86)/.460517018598809137D+01/, W(87)/.461512051684125945D+01/,
     5 W(88)/.462497281328427108D+01/, W(89)/.463472898822963577D+01/,
     6 W(90)/.464439089914137266D+01/
      DATA W(91) /.465396035015752337D+01/,
     1 W(92) /.466343909411206714D+01/, W(93) /.467282883446190617D+01/,
     2 W(94) /.468213122712421969D+01/, W(95) /.469134788222914370D+01/,
     3 W(96) /.470048036579241623D+01/, W(97) /.470953020131233414D+01/,
     4 W(98) /.471849887129509454D+01/, W(99) /.472738781871234057D+01/,
     5 W(100)/.473619844839449546D+01/, W(101)/.474493212836325007D+01/,
     6 W(102)/.475359019110636465D+01/, W(103)/.476217393479775612D+01/,
     7 W(104)/.477068462446566476D+01/, W(105)/.477912349311152939D+01/,
     8 W(106)/.478749174278204599D+01/, W(107)/.479579054559674109D+01/,
     9 W(108)/.480402104473325656D+01/, W(109)/.481218435537241750D+01/,
     1 W(110)/.482028156560503686D+01/, W(111)/.482831373730230112D+01/,
     2 W(112)/.483628190695147800D+01/, W(113)/.484418708645859127D+01/,
     3 W(114)/.485203026391961717D+01/, W(115)/.485981240436167211D+01/,
     4 W(116)/.486753445045558242D+01/, W(117)/.487519732320115154D+01/,
     5 W(118)/.488280192258637085D+01/, W(119)/.489034912822175377D+01/,
     6 W(120)/.489783979995091137D+01/
      DATA W(121)/.490527477843842945D+01/,
     1 W(122)/.491265488573605201D+01/, W(123)/.491998092582812492D+01/,
     2 W(124)/.492725368515720469D+01/, W(125)/.493447393313069176D+01/,
     3 W(126)/.494164242260930430D+01/, W(127)/.494875989037816828D+01/,
     4 W(128)/.495582705760126073D+01/, W(129)/.496284463025990728D+01/,
     5 W(130)/.496981329957600062D+01/, W(131)/.497673374242057440D+01/,
     6 W(132)/.498360662170833644D+01/, W(133)/.499043258677873630D+01/,
     7 W(134)/.499721227376411506D+01/, W(135)/.500394630594545914D+01/,
     8 W(136)/.501063529409625575D+01/, W(137)/.501727983681492433D+01/,
     9 W(138)/.502388052084627639D+01/, W(139)/.503043792139243546D+01/,
     1 W(140)/.503695260241362916D+01/, W(141)/.504342511691924662D+01/,
     2 W(142)/.504985600724953705D+01/, W(143)/.505624580534830806D+01/,
     3 W(144)/.506259503302696680D+01/, W(145)/.506890420222023153D+01/,
     4 W(146)/.507517381523382692D+01/, W(147)/.508140436498446300D+01/,
     5 W(148)/.508759633523238407D+01/, W(149)/.509375020080676233D+01/,
     6 W(150)/.509986642782419842D+01/
      DATA W(151)/.510594547390058061D+01/,
     1 W(152)/.511198778835654323D+01/, W(153)/.511799381241675511D+01/,
     2 W(154)/.512396397940325892D+01/, W(155)/.512989871492307347D+01/,
     3 W(156)/.513579843705026176D+01/, W(157)/.514166355650265984D+01/,
     4 W(158)/.514749447681345304D+01/, W(159)/.515329159449777895D+01/,
     5 W(160)/.515905529921452903D+01/, W(161)/.516478597392351405D+01/,
     6 W(162)/.517048399503815178D+01/, W(163)/.517614973257382914D+01/
C
      IF (X .GE. 178.0) GO TO 10
      N = X
      T = (X - N)/(X + N)
      T2 = T*T
      Z = (((C1*T2 + C2)*T2 + C3)*T2 + 2.0)*T
      GLOG = W(N - 14) + Z
      RETURN
C
   10 GLOG = ALOG(X)
      RETURN
      END
      REAL FUNCTION GAM1(A)
C-----------------------------------------------------------------------
C     COMPUTATION OF 1/GAMMA(A+1) - 1  FOR -0.5 .LE. A .LE. 1.5
C-----------------------------------------------------------------------
      REAL P(7), Q(5), R(9)
C------------------------
      DATA P(1)/ .577215664901533E+00/, P(2)/-.409078193005776E+00/,
     *     P(3)/-.230975380857675E+00/, P(4)/ .597275330452234E-01/,
     *     P(5)/ .766968181649490E-02/, P(6)/-.514889771323592E-02/,
     *     P(7)/ .589597428611429E-03/
C------------------------
      DATA Q(1)/ .100000000000000E+01/, Q(2)/ .427569613095214E+00/,
     *     Q(3)/ .158451672430138E+00/, Q(4)/ .261132021441447E-01/,
     *     Q(5)/ .423244297896961E-02/
C------------------------
      DATA R(1)/-.422784335098468E+00/, R(2)/-.771330383816272E+00/,
     *     R(3)/-.244757765222226E+00/, R(4)/ .118378989872749E+00/,
     *     R(5)/ .930357293360349E-03/, R(6)/-.118290993445146E-01/,
     *     R(7)/ .223047661158249E-02/, R(8)/ .266505979058923E-03/,
     *     R(9)/-.132674909766242E-03/
C------------------------
      DATA S1  / .273076135303957E+00/, S2  / .559398236957378E-01/
C------------------------
      T = A
      D = A - 0.5
      IF (D .GT. 0.0) T = D - 0.5
      IF (T) 30,10,20
C
   10 GAM1 = 0.0
      RETURN
C
   20 TOP = (((((P(7)*T + P(6))*T + P(5))*T + P(4))*T + P(3))*T
     *                  + P(2))*T + P(1)
      BOT = (((Q(5)*T + Q(4))*T + Q(3))*T + Q(2))*T + 1.0
      W = TOP/BOT
      IF (D .GT. 0.0) GO TO 21
         GAM1 = A*W
         RETURN
   21 GAM1 = (T/A)*((W - 0.5) - 0.5)
      RETURN
C
   30 TOP = (((((((R(9)*T + R(8))*T + R(7))*T + R(6))*T + R(5))*T
     *                    + R(4))*T + R(3))*T + R(2))*T + R(1)
      BOT = (S2*T + S1)*T + 1.0
      W = TOP/BOT
      IF (D .GT. 0.0) GO TO 31
         GAM1 = A*((W + 0.5) + 0.5)
         RETURN
   31 GAM1 = T*W/A
      RETURN
      END
      REAL FUNCTION GAMLN (A)
C-----------------------------------------------------------------------
C            EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS
C          NAVAL SURFACE WARFARE CENTER
C          DAHLGREN, VIRGINIA
C--------------------------
C     D = 0.5*(LN(2*PI) - 1)
C--------------------------
      DATA D/.418938533204673/
C--------------------------
      DATA C0/.833333333333333E-01/, C1/-.277777777760991E-02/,
     *     C2/.793650666825390E-03/, C3/-.595202931351870E-03/,
     *     C4/.837308034031215E-03/, C5/-.165322962780713E-02/
C-----------------------------------------------------------------------
      IF (A .GT. 0.8) GO TO 10
         GAMLN = GAMLN1(A) - ALOG(A)
         RETURN
   10 IF (A .GT. 2.25) GO TO 20
         T = (A - 0.5) - 0.5
         GAMLN = GAMLN1(T)
         RETURN
C
   20 IF (A .GE. 10.0) GO TO 30
      N = A - 1.25
      T = A
      W = 1.0
      DO 21 I = 1,N
         T = T - 1.0
   21    W = T*W
      GAMLN = GAMLN1(T - 1.0) + ALOG(W)
      RETURN
C
   30 T = (1.0/A)**2
      W = (((((C5*T + C4)*T + C3)*T + C2)*T + C1)*T + C0)/A
      GAMLN = (D + W) + (A - 0.5)*(ALOG(A) - 1.0)
      END
      REAL FUNCTION GAMLN1 (A)
C-----------------------------------------------------------------------
C     EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25
C-----------------------------------------------------------------------
      DATA P0/ .577215664901533E+00/, P1/ .844203922187225E+00/,
     *     P2/-.168860593646662E+00/, P3/-.780427615533591E+00/,
     *     P4/-.402055799310489E+00/, P5/-.673562214325671E-01/,
     *     P6/-.271935708322958E-02/
      DATA Q1/ .288743195473681E+01/, Q2/ .312755088914843E+01/,
     *     Q3/ .156875193295039E+01/, Q4/ .361951990101499E+00/,
     *     Q5/ .325038868253937E-01/, Q6/ .667465618796164E-03/
C----------------------
      DATA R0/.422784335098467E+00/,  R1/.848044614534529E+00/,
     *     R2/.565221050691933E+00/,  R3/.156513060486551E+00/,
     *     R4/.170502484022650E-01/,  R5/.497958207639485E-03/
      DATA S1/.124313399877507E+01/,  S2/.548042109832463E+00/,
     *     S3/.101552187439830E+00/,  S4/.713309612391000E-02/,
     *     S5/.116165475989616E-03/
C----------------------
      IF (A .GE. 0.6) GO TO 10
      W = ((((((P6*A + P5)*A + P4)*A + P3)*A + P2)*A + P1)*A + P0)/
     *    ((((((Q6*A + Q5)*A + Q4)*A + Q3)*A + Q2)*A + Q1)*A + 1.0)
      GAMLN1 = -A*W
      RETURN
C
   10 X = (A - 0.5) - 0.5
      W = (((((R5*X + R4)*X + R3)*X + R2)*X + R1)*X + R0)/
     *    (((((S5*X + S4)*X + S3)*X + S2)*X + S1)*X + 1.0)
      GAMLN1 = X*W
      RETURN
      END
      SUBROUTINE DCGAMA (MO, Z, W)
C-----------------------------------------------------------------------
C
C        EVALUATION OF THE COMPLEX GAMMA AND LOGGAMMA FUNCTIONS
C
C                        ---------------
C
C     MO IS AN INTEGER. Z AND W ARE INTERPRETED AS DOUBLE PRECISION
C     COMPLEX NUMBERS. IT IS ASSUMED THAT Z(1) AND Z(2) ARE THE REAL
C     AND IMAGINARY PARTS OF THE COMPLEX NUMBER Z, AND THAT W(1) AND
C     W(2) ARE THE REAL AND IMAGINARY PARTS OF W.
C
C                 W = GAMMA(Z)       IF MO = 0
C                 W = LN(GAMMA(Z))   OTHERWISE
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION Z(2), W(2)
      DOUBLE PRECISION C0(30), DLPI, HL2P, PI, PI2
      DOUBLE PRECISION A, A1, A2, C, CN, CUT, D, EPS, ET, E2T, H1,
     *                 H2, Q1, Q2, S, SN, S1, S2, T, T1, T2, U, U1,
     *                 U2, V1, V2, W1, W2, X, Y, Y2
      DOUBLE PRECISION DPMPAR, DREXP
C---------------------------
C     DLPI = LOG(PI)
C     HL2P = 0.5 * LOG(2*PI)
C---------------------------
      DATA PI   /3.141592653589793238462643383279502884197D0/
      DATA PI2  /6.283185307179586476925286766559005768394D0/
      DATA DLPI /1.144729885849400174143427351353058711647D0/
      DATA HL2P /.9189385332046727417803297364056176398614D0/
C---------------------------
      DATA C0(1)  / .8333333333333333333333333333333333333333D-01/,
     *     C0(2)  /-.2777777777777777777777777777777777777778D-02/,
     *     C0(3)  / .7936507936507936507936507936507936507937D-03/,
     *     C0(4)  /-.5952380952380952380952380952380952380952D-03/,
     *     C0(5)  / .8417508417508417508417508417508417508418D-03/,
     *     C0(6)  /-.1917526917526917526917526917526917526918D-02/,
     *     C0(7)  / .6410256410256410256410256410256410256410D-02/,
     *     C0(8)  /-.2955065359477124183006535947712418300654D-01/,
     *     C0(9)  / .1796443723688305731649384900158893966944D+00/,
     *     C0(10) /-.1392432216905901116427432216905901116427D+01/
      DATA C0(11) / .1340286404416839199447895100069013112491D+02/,
     *     C0(12) /-.1568482846260020173063651324520889738281D+03/,
     *     C0(13) / .2193103333333333333333333333333333333333D+04/,
     *     C0(14) /-.3610877125372498935717326521924223073648D+05/,
     *     C0(15) / .6914722688513130671083952507756734675533D+06/,
     *     C0(16) /-.1523822153940741619228336495888678051866D+08/,
     *     C0(17) / .3829007513914141414141414141414141414141D+09/,
     *     C0(18) /-.1088226603578439108901514916552510537473D+11/,
     *     C0(19) / .3473202837650022522522522522522522522523D+12/,
     *     C0(20) /-.1236960214226927445425171034927132488108D+14/
      DATA C0(21) / .4887880647930793350758151625180229021085D+15/,
     *     C0(22) /-.2132033396091937389697505898213683855747D+17/,
     *     C0(23) / .1021775296525700077565287628053585500394D+19/,
     *     C0(24) /-.5357547217330020361082770919196920448485D+20/,
     *     C0(25) / .3061578263704883415043151051329622758194D+22/,
     *     C0(26) /-.1899991742639920405029371429306942902947D+24/,
     *     C0(27) / .1276337403382883414923495137769782597654D+26/,
     *     C0(28) /-.9252847176120416307230242348347622779519D+27/,
     *     C0(29) / .7218822595185610297836050187301637922490D+29/,
     *     C0(30) /-.6045183405995856967743148238754547286066D+31/
C---------------------------
C
C     ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS.
C            MAX IS THE LARGEST POSITIVE INTEGER THAT MAY
C            BE USED, AND EPS IS THE SMALLEST NUMBER SUCH
C            THAT  1.D0 + EPS .GT. 1.D0.
C
                      MAX = IPMPAR(3)
                      EPS = DPMPAR(1)
C
C---------------------------
      X = Z(1)
      Y = Z(2)
      IF (X .GE. 0.D0) GO TO 50
C-----------------------------------------------------------------------
C            CASE WHEN THE REAL PART OF Z IS NEGATIVE
C-----------------------------------------------------------------------
      Y = DABS(Y)
      T = -PI*Y
      ET = DEXP(T)
      E2T = ET*ET
C
C     SET  A1 = (1 + E2T)/2  AND  A2 = (1 - E2T)/2
C
      A1 = 0.5D0*(1.D0 + E2T)
      T2 = T + T
      IF (T2 .LT. -0.15D0) GO TO 10
         A2 = -0.5D0*DREXP(T2)
         GO TO 20
   10 A2 = 0.5D0*(0.5D0 + (0.5D0 - E2T))
C
C     COMPUTE SIN(PI*X) AND COS(PI*X)
C
   20 U = MAX
      IF (DABS(X) .GE. DMIN1(U, 1.D0/EPS)) GO TO 200
      K = DABS(X)
      U = X + K
      K = MOD(K,2)
      IF (U .GT. -0.5D0) GO TO 21
         U = 0.5D0 + (0.5D0 + U)
         K = K + 1
   21 U = PI*U
      SN = DSIN(U)
      CN = DCOS(U)
      IF (K .NE. 1) GO TO 30
      SN = -SN
      CN = -CN
C
C     SET  H1 + H2*I  TO  PI/SIN(PI*Z)  OR  LOG(PI/SIN(PI*Z))
C
   30 A1 = SN*A1
      A2 = CN*A2
      A = A1*A1 + A2*A2
      IF (A .EQ. 0.D0) GO TO 200
      IF (MO .NE. 0) GO TO 40
C
      H1 = A1/A
      H2 = -A2/A
      C = PI*ET
      H1 = C*H1
      H2 = C*H2
      GO TO 41
C
   40 H1 = (DLPI + T) - 0.5D0*DLOG(A)
      H2 = -DATAN2(A2,A1)
   41 IF (Z(2) .LT. 0.D0) GO TO 42
         X = 1.0 - X
         Y = -Y
         GO TO 50
   42 H2 = -H2
      X = 1.0 - X
C-----------------------------------------------------------------------
C           CASE WHEN THE REAL PART OF Z IS NONNEGATIVE
C-----------------------------------------------------------------------
   50 W1 = 0.D0
      W2 = 0.D0
      N = 0
      T = X
      Y2 = Y*Y
      A = T*T + Y2
      CUT = 225.D0
      IF (EPS .GT. 1.D-30) CUT = 144.D0
      IF (EPS .GT. 1.D-20) CUT = 64.D0
      IF (A .GE. CUT) GO TO 80
      IF (A .EQ. 0.D0) GO TO 200
   51    N = N + 1
         T = T + 1.D0
         A = T*T + Y2
         IF (A .LT. CUT) GO TO 51
C
C     LET S1 + S2*I BE THE PRODUCT OF THE TERMS (Z+J)/(Z+N)
C
      U1 = (X*T + Y2)/A
      U2 = Y/A
      S1 = U1
      S2 = N*U2
      IF (N .LT. 2) GO TO 70
      U = T/A
      NM1 = N - 1
      DO 60 J = 1,NM1
         V1 = U1 + J*U
         V2 = (N - J)*U2
         C = S1*V1 - S2*V2
         D = S1*V2 + S2*V1
         S1 = C
         S2 = D
   60 CONTINUE
C
C     SET  W1 + W2*I = LOG(S1 + S2*I)  WHEN MO IS NONZERO
C
   70 S = S1*S1 + S2*S2
      IF (MO .EQ. 0) GO TO 80
      W1 = 0.5D0 * DLOG(S)
      W2 = DATAN2(S2,S1)
C
C     SET  V1 + V2*I = (Z - 0.5) * LOG(Z + N) - Z
C
   80 T1 = 0.5D0 * DLOG(A) - 1.D0
      T2 = DATAN2(Y,T)
      U = X - 0.5D0
      V1 = (U*T1 - 0.5D0) - Y*T2
      V2 = U*T2 + Y*T1
C
C     LET A1 + A2*I BE THE ASYMPTOTIC SUM
C
      U1 = T/A
      U2 = -Y/A
      Q1 = U1*U1 - U2*U2
      Q2 = 2.D0*U1*U2
      A1 = 0.D0
      A2 = 0.D0
      DO 91 J = 1,30
         T1 = A1
         T2 = A2
         A1 = A1 + C0(J)*U1
         A2 = A2 + C0(J)*U2
         IF (A1 .NE. T1) GO TO 90
         IF (A2 .EQ. T2) GO TO 100
   90    T1 = U1*Q1 - U2*Q2
         T2 = U1*Q2 + U2*Q1
         U1 = T1
         U2 = T2
   91 CONTINUE
C-----------------------------------------------------------------------
C                 GATHERING TOGETHER THE RESULTS
C-----------------------------------------------------------------------
  100 W1 = (((A1 + HL2P) - W1) + V1) - N
      W2 = (A2 - W2) + V2
      IF (Z(1) .LT. 0.D0) GO TO 120
      IF (MO .NE. 0) GO TO 110
C
C     CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO = 0
C
      A = DEXP(W1)
      W1 = A * DCOS(W2)
      W2 = A * DSIN(W2)
      IF (N .EQ. 0) GO TO 140
      C = (S1*W1 + S2*W2)/S
      D = (S1*W2 - S2*W1)/S
      W1 = C
      W2 = D
      GO TO 140
C
C     CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO IS NONZERO.
C     THE ANGLE W2 IS REDUCED TO THE INTERVAL -PI .LT. W2 .LE. PI.
C
  110 IF (W2 .GT. PI) GO TO 111
         K = 0.5D0 - W2/PI2
         W2 = W2 + PI2*K
         GO TO 140
  111 K = W2/PI2 - 0.5D0
      U = K + 1
      W2 = W2 - PI2*U
      IF (W2 .LE. -PI) W2 = PI
      GO TO 140
C
C     CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO IS NONZERO
C
  120 IF (MO .EQ. 0) GO TO 130
      W1 = H1 - W1
      W2 = H2 - W2
      GO TO 110
C
C     CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO = 0
C
  130 A = DEXP(-W1)
      T1 = A * DCOS(-W2)
      T2 = A * DSIN(-W2)
      W1 = H1*T1 - H2*T2
      W2 = H1*T2 + H2*T1
      IF (N .EQ. 0) GO TO 140
      C = W1*S1 - W2*S2
      D = W1*S2 + W2*S1
      W1 = C
      W2 = D
C
C     TERMINATION
C
  140 W(1) = W1
      W(2) = W2
      RETURN
C-----------------------------------------------------------------------
C             THE REQUESTED VALUE CANNOT BE COMPUTED
C-----------------------------------------------------------------------
  200 W(1) = 0.D0
      W(2) = 0.D0
      RETURN
      END
      DOUBLE PRECISION FUNCTION DGAMMA(A)
C-----------------------------------------------------------------------
C
C                EVALUATION OF THE GAMMA FUNCTION FOR
C                     DOUBLE PRECISION ARGUMENTS
C
C                           -----------
C
C     DGAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT
C     BE COMPUTED.
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C          NAVAL SURFACE WEAPONS CENTER
C          DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, D, PI, S, T, X, W
      DOUBLE PRECISION DPMPAR, DSIN1, DGAM1, DPDEL, DXPARG
C-----------------------------------------------------------------------
C     D = 0.5*(LN(2*PI) - 1)
C-----------------------------------------------------------------------
      DATA PI /3.14159265358979323846264338327950D0/
      DATA D  /0.41893853320467274178032973640562D0/
C-----------------------------------------------------------------------
      DGAMMA = 0.D0
      X = A
      IF (DABS(A) .GT. 20.D0) GO TO 60
C-----------------------------------------------------------------------
C             EVALUATION OF DGAMMA(A) FOR DABS(A) .LE. 20
C-----------------------------------------------------------------------
      T = 1.D0
      N = X
      N = N - 1
C
C     LET T BE THE PRODUCT OF A-J WHEN A .GE. 2
C
      IF (N) 20,12,10
   10 DO 11 J = 1,N
         X = X - 1.D0
   11    T = X*T
   12 X = X - 1.D0
      GO TO 40
C
C     LET T BE THE PRODUCT OF A+J WHEN A .LT. 1
C
   20 T = A
      IF (A .GT. 0.D0) GO TO 30
      N = - N - 1
      IF (N .EQ. 0) GO TO 22
         DO 21 J = 1,N
         X = X + 1.D0
   21    T = X*T
   22 X = (X + 0.5D0) + 0.5D0
      T = X*T
      IF (T .EQ. 0.D0) RETURN
C
   30 CONTINUE
C
C     THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS
C     CODE MAY BE OMITTED IF DESIRED.
C
      IF (DABS(T) .GE. 1.D-33) GO TO 40
      IF (DABS(T)*DPMPAR(3) .LE. 1.000000001D0) RETURN
      DGAMMA = 1.D0/T
      RETURN
C
C     COMPUTE DGAMMA(1 + X) FOR 0 .LE. X .LT. 1
C
   40 DGAMMA = 1.D0/(1.D0 + DGAM1(X))
C
C     TERMINATION
C
      IF (A .LT. 1.D0) GO TO 50
         DGAMMA = DGAMMA * T
         RETURN
   50 DGAMMA = DGAMMA / T
      RETURN
C-----------------------------------------------------------------------
C           EVALUATION OF DGAMMA(A) FOR DABS(A) .GT. 20
C-----------------------------------------------------------------------
   60 IF (DABS(A) .GE. 1.D3) RETURN
      IF (A .GT. 0.D0) GO TO 70
      S = DSIN1(A)/PI
      IF (S .EQ. 0.D0) RETURN
      X = -A
C
C     COMPUTE THE MODIFIED ASYMPTOTIC SUM
C
   70 W = DPDEL(X)
C
C     FINAL ASSEMBLY
C
      W = (D + W) + (X - 0.5D0)*(DLOG(X) - 1.D0)
      IF (W .GT. DXPARG(0)) RETURN
      DGAMMA = DEXP(W)
      IF (A .LT. 0.D0) DGAMMA = (1.D0/(DGAMMA*S))/X
      RETURN
      END
      DOUBLE PRECISION FUNCTION DPDEL(X)
C-----------------------------------------------------------------------
C
C     COMPUTATION OF THE FUNCTION DEL(X) FOR  X .GE. 10  WHERE
C     LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X)
C
C                         --------
C
C     THE SERIES FOR DPDEL ON THE INTERVAL 0.0 TO 1.0 DERIVED BY
C     A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE SLATEC LIBRARY
C     OBTAINED BY WAYNE FULLERTON (LOS ALAMOS).
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, A(15), T, W
C-----------------------------------------------------------------------
      DATA A(1)  / .833333333333333333333333333333D-01/,
     *     A(2)  /-.277777777777777777777777752282D-04/,
     *     A(3)  / .793650793650793650791732130419D-07/,
     *     A(4)  /-.595238095238095232389839236182D-09/,
     *     A(5)  / .841750841750832853294451671990D-11/,
     *     A(6)  /-.191752691751854612334149171243D-12/,
     *     A(7)  / .641025640510325475730918472625D-14/,
     *     A(8)  /-.295506514125338232839867823991D-15/,
     *     A(9)  / .179643716359402238723287696452D-16/,
     *     A(10) /-.139228964661627791231203060395D-17/
      DATA A(11) / .133802855014020915603275339093D-18/,
     *     A(12) /-.154246009867966094273710216533D-19/,
     *     A(13) / .197701992980957427278370133333D-20/,
     *     A(14) /-.234065664793997056856992426667D-21/,
     *     A(15) / .171348014966398575409015466667D-22/
C-----------------------------------------------------------------------
      T = (10.D0/X)**2
      W = A(15)
      DO 10 I = 1,14
         K = 15 - I
         W = T*W + A(K)
   10 CONTINUE
      DPDEL = W/X
      RETURN
      END
      DOUBLE PRECISION FUNCTION DGAM1 (X)
C-----------------------------------------------------------------------
C     EVALUATION OF 1/GAMMA(1 + X) - 1  FOR -0.5 .LE. X .LE. 1.5
C-----------------------------------------------------------------------
C
C     THE FOLLOWING ARE THE FIRST 49 COEFFICIENTS OF THE MACLAURIN
C     EXPANSION FOR 1/GAMMA(1 + X) - 1. THE COEFFICIENTS ARE
C     CORRECT TO 40 DIGITS. THE COEFFICIENTS WERE OBTAINED BY
C     ALFRED H. MORRIS JR. (NAVAL SURFACE WARFARE CENTER) AND ARE
C     GIVEN HERE FOR REFERENCE. ONLY THE FIRST 14 COEFFICIENTS ARE
C     USED IN THIS CODE.
C
C                           -----------
C
C     DATA A(1)  / .5772156649015328606065120900824024310422D+00/,
C    *     A(2)  /-.6558780715202538810770195151453904812798D+00/,
C    *     A(3)  /-.4200263503409523552900393487542981871139D-01/,
C    *     A(4)  / .1665386113822914895017007951021052357178D+00/,
C    *     A(5)  /-.4219773455554433674820830128918739130165D-01/,
C    *     A(6)  /-.9621971527876973562114921672348198975363D-02/,
C    *     A(7)  / .7218943246663099542395010340446572709905D-02/,
C    *     A(8)  /-.1165167591859065112113971084018388666809D-02/,
C    *     A(9)  /-.2152416741149509728157299630536478064782D-03/,
C    *     A(10) / .1280502823881161861531986263281643233949D-03/
C     DATA A(11) /-.2013485478078823865568939142102181838229D-04/,
C    *     A(12) /-.1250493482142670657345359473833092242323D-05/,
C    *     A(13) / .1133027231981695882374129620330744943324D-05/,
C    *     A(14) /-.2056338416977607103450154130020572836513D-06/,
C    *     A(15) / .6116095104481415817862498682855342867276D-08/,
C    *     A(16) / .5002007644469222930055665048059991303045D-08/,
C    *     A(17) /-.1181274570487020144588126565436505577739D-08/,
C    *     A(18) / .1043426711691100510491540332312250191401D-09/,
C    *     A(19) / .7782263439905071254049937311360777226068D-11/,
C    *     A(20) /-.3696805618642205708187815878085766236571D-11/
C     DATA A(21) / .5100370287454475979015481322863231802727D-12/,
C    *     A(22) /-.2058326053566506783222429544855237419746D-13/,
C    *     A(23) /-.5348122539423017982370017318727939948990D-14/,
C    *     A(24) / .1226778628238260790158893846622422428165D-14/,
C    *     A(25) /-.1181259301697458769513764586842297831212D-15/,
C    *     A(26) / .1186692254751600332579777242928674071088D-17/,
C    *     A(27) / .1412380655318031781555803947566709037086D-17/,
C    *     A(28) /-.2298745684435370206592478580633699260285D-18/,
C    *     A(29) / .1714406321927337433383963370267257066813D-19/,
C    *     A(30) / .1337351730493693114864781395122268022875D-21/
C     DATA A(31) /-.2054233551766672789325025351355733796682D-21/,
C    *     A(32) / .2736030048607999844831509904330982014865D-22/,
C    *     A(33) /-.1732356445910516639057428451564779799070D-23/,
C    *     A(34) /-.2360619024499287287343450735427531007926D-25/,
C    *     A(35) / .1864982941717294430718413161878666898946D-25/,
C    *     A(36) /-.2218095624207197204399716913626860379732D-26/,
C    *     A(37) / .1297781974947993668824414486330594165619D-27/,
C    *     A(38) / .1180697474966528406222745415509971518560D-29/,
C    *     A(39) /-.1124584349277088090293654674261439512119D-29/,
C    *     A(40) / .1277085175140866203990206677751124647749D-30/
C     DATA A(41) /-.7391451169615140823461289330108552823711D-32/,
C    *     A(42) / .1134750257554215760954165259469306393009D-34/,
C    *     A(43) / .4639134641058722029944804907952228463058D-34/,
C    *     A(44) /-.5347336818439198875077418196709893320905D-35/,
C    *     A(45) / .3207995923613352622861237279082794391090D-36/,
C    *     A(46) /-.4445829736550756882101590352124643637401D-38/,
C    *     A(47) /-.1311174518881988712901058494389922190237D-38/,
C    *     A(48) / .1647033352543813886818259327906394145400D-39/,
C    *     A(49) /-.1056233178503581218600561071538285049997D-40/
C
C                           -----------
C
C     C = A(1) - 1 IS ALSO FREQUENTLY NEEDED. C HAS THE VALUE ...
C
C     DATA C /-.4227843350984671393934879099175975689578D+00/
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, D, T, W, Z
      DOUBLE PRECISION A0, A1, B1, B2, B3, B4, B5, B6, B7, B8
      DOUBLE PRECISION P0, P1, P2, P3, P4, P5, P6, Q1, Q2, Q3, Q4
      DOUBLE PRECISION C, C0, C1, C2, C3, C4, C5, C6, C7, C8, C9,
     *                 C10, C11, C12, C13
C----------------------------
      DATA A0 / .611609510448141581788D-08/,
     *     A1 / .624730830116465516210D-08/
      DATA B1 / .203610414066806987300D+00/,
     *     B2 / .266205348428949217746D-01/,
     *     B3 / .493944979382446875238D-03/,
     *     B4 /-.851419432440314906588D-05/,
     *     B5 /-.643045481779353022248D-05/,
     *     B6 / .992641840672773722196D-06/,
     *     B7 /-.607761895722825260739D-07/,
     *     B8 / .195755836614639731882D-09/
C----------------------------
      DATA P0 /.6116095104481415817861D-08/,
     *     P1 /.6871674113067198736152D-08/,
     *     P2 /.6820161668496170657918D-09/,
     *     P3 /.4686843322948848031080D-10/,
     *     P4 /.1572833027710446286995D-11/,
     *     P5/-.1249441572276366213222D-12/,
     *     P6 /.4343529937408594255178D-14/
      DATA Q1 /.3056961078365221025009D+00/,
     *     Q2 /.5464213086042296536016D-01/,
     *     Q3 /.4956830093825887312020D-02/,
     *     Q4 /.2692369466186361192876D-03/
C----------------------------
C     C = C0 - 1
C----------------------------
      DATA C /-.422784335098467139393487909917598D+00/
C----------------------------
      DATA C0  / .577215664901532860606512090082402D+00/,
     *     C1  /-.655878071520253881077019515145390D+00/,
     *     C2  /-.420026350340952355290039348754298D-01/,
     *     C3  / .166538611382291489501700795102105D+00/,
     *     C4  /-.421977345555443367482083012891874D-01/,
     *     C5  /-.962197152787697356211492167234820D-02/,
     *     C6  / .721894324666309954239501034044657D-02/,
     *     C7  /-.116516759185906511211397108401839D-02/,
     *     C8  /-.215241674114950972815729963053648D-03/,
     *     C9  / .128050282388116186153198626328164D-03/
      DATA C10 /-.201348547807882386556893914210218D-04/,
     *     C11 /-.125049348214267065734535947383309D-05/,
     *     C12 / .113302723198169588237412962033074D-05/,
     *     C13 /-.205633841697760710345015413002057D-06/
C----------------------------
      T = X
      D = X - 0.5D0
      IF (D .GT. 0.D0) T = D - 0.5D0
      IF (T) 40,10,20
C
   10 DGAM1 = 0.D0
      RETURN
C------------
C
C                CASE WHEN 0 .LT. T .LE. 0.5
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C------------
   20 W = ((((((P6*T + P5)*T + P4)*T + P3)*T + P2)*T + P1)*T + P0)/
     *      ((((Q4*T + Q3)*T + Q2)*T + Q1)*T + 1.D0)
      Z = (((((((((((((W*T + C13)*T + C12)*T + C11)*T + C10)*T +
     *         C9)*T + C8)*T + C7)*T + C6)*T + C5)*T + C4)*T +
     *         C3)*T + C2)*T + C1)*T + C0
C
      IF (D .GT. 0.D0) GO TO 30
         DGAM1 = X*Z
         RETURN
   30 DGAM1 = (T/X)*((Z - 0.5D0) - 0.5D0)
      RETURN
C------------
C
C                CASE WHEN -0.5 .LE. T .LT. 0
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C------------
   40 W = (A1*T + A0)/((((((((B8*T + B7)*T + B6)*T + B5)*T +
     *       B4)*T + B3)*T + B2)*T + B1)*T + 1.D0)
      Z = (((((((((((((W*T + C13)*T + C12)*T + C11)*T + C10)*T +
     *         C9)*T + C8)*T + C7)*T + C6)*T + C5)*T + C4)*T +
     *         C3)*T + C2)*T + C1)*T + C
C
      IF (D .GT. 0.D0) GO TO 50
         DGAM1 = X*((Z + 0.5D0) + 0.5D0)
         RETURN
   50 DGAM1 = T*Z/X
      RETURN
      END
      DOUBLE PRECISION FUNCTION DGAMLN (A)
C-----------------------------------------------------------------------
C
C           EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS
C          NAVAL SURFACE WEAPONS CENTER
C          DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
C     D = 0.5*(LN(2*PI) - 1)
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, D, X, W
      DOUBLE PRECISION DGMLN1, DPDEL
C--------------------------
      DATA D /0.41893853320467274178032973640562D0/
C--------------------------
      IF (A .GE. 0.5D0) GO TO 10
         DGAMLN = DGMLN1(A) - DLOG(A)
         RETURN
   10 IF (A .GT. 2.5D0) GO TO 20
         X = A - 1.D0
         IF (A .LT. 1.D0) X = (A - 0.5D0) - 0.5D0
         DGAMLN = DGMLN1(X)
         RETURN
C
   20 IF (A .GE. 10.D0) GO TO 30
      N = A - 1.5D0
      X = A
      W = 1.D0
      DO 21 I = 1,N
         X = X - 1.D0
   21    W = X*W
      DGAMLN = DGMLN1(X - 1.D0) + DLOG(W)
      RETURN
C
   30 W = DPDEL(A)
      DGAMLN = (D + W) + (A - 0.5D0)*(DLOG(A) - 1.D0)
      END
      DOUBLE PRECISION FUNCTION DGMLN1 (X)
C-----------------------------------------------------------------------
C     EVALUATION OF LN(GAMMA(1 + X)) FOR -0.5 .LE. X .LE. 1.5
C-----------------------------------------------------------------------
      DOUBLE PRECISION X, W
      DOUBLE PRECISION DGAM1, DLNREL
C-----------------------
      W = DGAM1(X)
      DGMLN1 = - DLNREL(W)
      RETURN
      END
      SUBROUTINE CPSI (Z, W)
C-----------------------------------------------------------------------
C           EVALUATION OF THE COMPLEX DIGAMMA FUNCTION
C-----------------------------------------------------------------------
      COMPLEX Z, W
      COMPLEX ETA, ETA2, SUM
      REAL C0(12)
      DOUBLE PRECISION DS1, DS2
C----------------------------
C     PI2 = 2*PI
C----------------------------
      DATA PI/3.14159265358979324/
      DATA PI2/6.28318530717958648/
C----------------------------
      DATA C0(1) /.833333333333333E-01/, C0(2) /-.833333333333333E-02/,
     *     C0(3) /.396825396825397E-02/, C0(4) /-.416666666666667E-02/,
     *     C0(5) /.757575757575758E-02/, C0(6) /-.210927960927961E-01/,
     *     C0(7) /.833333333333333E-01/, C0(8) /-.443259803921569E+00/,
     *     C0(9) /.305395433027012E+01/, C0(10)/-.264562121212121E+02/,
     *     C0(11)/.281460144927536E+03/, C0(12)/-.360751054639805E+04/
C----------------------------
C
C     ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS.
C            MAX IS THE LARGEST POSITIVE INTEGER THAT MAY
C            BE USED, AND EPS IS THE SMALLEST REAL NUMBER
C            SUCH THAT 1.0 + EPS .GT. 1.0.
C
                      MAX = IPMPAR(3)
                      EPS = SPMPAR(1)
C
C----------------------------
      X = REAL(Z)
      Y = AIMAG(Z)
      IF (X .GE. 0.0) GO TO 40
C-----------------------------------------------------------------------
C            CASE WHEN THE REAL PART OF Z IS NEGATIVE
C-----------------------------------------------------------------------
      Y = ABS(Y)
      T = -PI2*Y
      ET = EXP(T)
C
C     SET  A1 = (1 + ET)/2  AND  A2 = (1 - ET)/2
C
      A1 = 0.5*(1.0 + ET)
      IF (T .LT. -0.15) GO TO 10
         A2 = -0.5*REXP(T)
         GO TO 20
   10 A2 = 0.5*(0.5 + (0.5 - ET))
C
C     COMPUTE SIN(PI*X) AND COS(PI*X), OR -SIN(PI*X) AND -COS(PI*X)
C
   20 IF (ABS(X) .GE. AMIN1(FLOAT(MAX), 1.0/EPS)) GO TO 100
      K = ABS(X)
      U = X + K
      IF (U .LE. -0.5) U = 0.5 + (0.5 + U)
      U = PI*U
      SN = SIN(U)
      CN = COS(U)
C
C     SET H1 + H2*I = PI*COT(PI*Z)
C
      S1 = A1*SN
      S2 = A2*CN
      C1 = A1*CN
      C2 = -A2*SN
      S = S1*S1 + S2*S2
      H1 = PI*(S1*C1 + S2*C2)/S
      H2 = PI*(S1*C2 - S2*C1)/S
C
      IF (AIMAG(Z) .LT. 0.0) GO TO 30
         X = 1.0 - X
         Y = -Y
         GO TO 40
   30 H2 = -H2
      X = 1.0 - X
C-----------------------------------------------------------------------
C           CASE WHEN THE REAL PART OF Z IS NONNEGATIVE
C-----------------------------------------------------------------------
   40 T = X
      Y2 = Y*Y
      A = X*X + Y2
      IF (A .EQ. 0.0) GO TO 100
C
C     LET S1 + S2*I BE THE SUM OF THE TERMS 1/(Z+J) FOR J = 0,1,...,N-1
C
      DS1 = 0.D0
      DS2 = 0.D0
   50    IF (A .GE. 36.0) GO TO 51
         DS1 = DS1 + DBLE(T/A)
         DS2 = DS2 - DBLE(Y/A)
         T = T + 1.0
         A = T*T + Y2
         GO TO 50
   51 S1 = DS1
      S2 = DS2
C
C     SET W1 + W2*I = LOG(Z+N)
C
      W1 = 0.5*ALOG(A)
      W2 = ATAN2(Y,T)
C
C     LET A1 + A2*I BE THE ASYMPTOTIC SUM
C
      ETA = CMPLX(T/A,-Y/A)
      ETA2 = ETA*ETA
      M = 12
      L = M
      SUM = CMPLX(C0(M),0.0)
      DO 60 J = 2,M
         L = L - 1
         SUM = CMPLX(C0(L),0.0) + SUM*ETA2
   60 CONTINUE
      SUM = CMPLX(0.5,0.0)*ETA + ETA2*SUM
      A1 = REAL(SUM)
      A2 = AIMAG(SUM)
C-----------------------------------------------------------------------
C                 GATHERING TOGETHER THE RESULTS
C-----------------------------------------------------------------------
      W1 = (W1 - S1) - A1
      W2 = (W2 - A2) - S2
      W  = CMPLX(W1,W2)
      IF (REAL(Z) .GE. 0.0) RETURN
      W = CMPLX(W1 - H1, W2 - H2)
      RETURN
C-----------------------------------------------------------------------
C             THE REQUESTED VALUE CANNOT BE COMPUTED
C-----------------------------------------------------------------------
  100 W = (0.0, 0.0)
      RETURN
      END
      REAL FUNCTION PSI(XX)
C---------------------------------------------------------------------
C
C                 EVALUATION OF THE DIGAMMA FUNCTION
C
C                           -----------
C
C     PSI(XX) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT
C     BE COMPUTED.
C
C     THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV
C     APPROXIMATIONS PUBLISHED IN MATH. COMP. 27, 123-127(1973) BY
C     CODY, STRECOK AND THACHER.
C
C---------------------------------------------------------------------
C     PSI WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR THE FUNPACK
C     PACKAGE OF SPECIAL FUNCTION SUBROUTINES. PSI WAS MODIFIED BY
C     A.H. MORRIS (NSWC).
C---------------------------------------------------------------------
      REAL P1(7), P2(4), Q1(6), Q2(4)
      DOUBLE PRECISION DX0
C---------------------------------------------------------------------
C
C     PIOV4 = PI/4
C     DX0 = ZERO OF PSI TO EXTENDED PRECISION
C
C---------------------------------------------------------------------
      DATA PIOV4/.785398163397448E0/
      DATA DX0/1.461632144968362341262659542325721325D0/
C---------------------------------------------------------------------
C
C     COEFFICIENTS FOR RATIONAL APPROXIMATION OF
C     PSI(X) / (X - X0),  0.5 .LE. X .LE. 3.0
C
C---------------------------------------------------------------------
      DATA P1(1)/.895385022981970E-02/,  P1(2)/.477762828042627E+01/,
     *     P1(3)/.142441585084029E+03/,  P1(4)/.118645200713425E+04/,
     *     P1(5)/.363351846806499E+04/,  P1(6)/.413810161269013E+04/,
     *     P1(7)/.130560269827897E+04/
      DATA Q1(1)/.448452573429826E+02/,  Q1(2)/.520752771467162E+03/,
     *     Q1(3)/.221000799247830E+04/,  Q1(4)/.364127349079381E+04/,
     *     Q1(5)/.190831076596300E+04/,  Q1(6)/.691091682714533E-05/
C---------------------------------------------------------------------
C
C     COEFFICIENTS FOR RATIONAL APPROXIMATION OF
C     PSI(X) - LN(X) + 1 / (2*X),  X .GT. 3.0
C
C---------------------------------------------------------------------
      DATA P2(1)/-.212940445131011E+01/, P2(2)/-.701677227766759E+01/,
     *     P2(3)/-.448616543918019E+01/, P2(4)/-.648157123766197E+00/
      DATA Q2(1)/ .322703493791143E+02/, Q2(2)/ .892920700481861E+02/,
     *     Q2(3)/ .546117738103215E+02/, Q2(4)/ .777788548522962E+01/
C---------------------------------------------------------------------
C
C     MACHINE DEPENDENT CONSTANTS ...
C
C        XMAX1  = THE SMALLEST POSITIVE FLOATING POINT CONSTANT
C                 WITH ENTIRELY INTEGER REPRESENTATION.  ALSO USED
C                 AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE
C                 ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH
C                 PSI MAY BE REPRESENTED AS ALOG(X).
C
C        XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X)
C                 MAY BE REPRESENTED BY 1/X.
C
C---------------------------------------------------------------------
      XMAX1 = IPMPAR(3)
      XMAX1 = AMIN1(XMAX1, 1.0/SPMPAR(1))
      XSMALL = 1.E-9
C---------------------------------------------------------------------
      X = XX
      AUG = 0.0E0
      IF (X .GE. 0.5E0) GO TO 200
C---------------------------------------------------------------------
C     X .LT. 0.5,  USE REFLECTION FORMULA
C     PSI(1-X) = PSI(X) + PI * COTAN(PI*X)
C---------------------------------------------------------------------
      IF (ABS(X) .GT. XSMALL) GO TO 100
      IF (X .EQ. 0.0E0) GO TO 400
C---------------------------------------------------------------------
C     0 .LT. ABS(X) .LE. XSMALL.  USE 1/X AS A SUBSTITUTE
C     FOR  PI*COTAN(PI*X)
C---------------------------------------------------------------------
      AUG = -1.0E0 / X
      GO TO 150
C---------------------------------------------------------------------
C     REDUCTION OF ARGUMENT FOR COTAN
C---------------------------------------------------------------------
  100 W = - X
      SGN = PIOV4
      IF (W .GT. 0.0E0) GO TO 120
      W = - W
      SGN = -SGN
C---------------------------------------------------------------------
C     MAKE AN ERROR EXIT IF X .LE. -XMAX1
C---------------------------------------------------------------------
  120 IF (W .GE. XMAX1) GO TO 400
      NQ = INT(W)
      W = W - FLOAT(NQ)
      NQ = INT(W*4.0E0)
      W = 4.0E0 * (W - FLOAT(NQ) * .25E0)
C---------------------------------------------------------------------
C     W IS NOW RELATED TO THE FRACTIONAL PART OF  4.0 * X.
C     ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST
C     QUADRANT AND DETERMINE SIGN
C---------------------------------------------------------------------
      N = NQ / 2
      IF ((N+N) .NE. NQ) W = 1.0E0 - W
      Z = PIOV4 * W
      M = N / 2
      IF ((M+M) .NE. N) SGN = - SGN
C---------------------------------------------------------------------
C     DETERMINE FINAL VALUE FOR  -PI*COTAN(PI*X)
C---------------------------------------------------------------------
      N = (NQ + 1) / 2
      M = N / 2
      M = M + M
      IF (M .NE. N) GO TO 140
C---------------------------------------------------------------------
C     CHECK FOR SINGULARITY
C---------------------------------------------------------------------
      IF (Z .EQ. 0.0E0) GO TO 400
C---------------------------------------------------------------------
C     USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND
C     SIN/COS AS A SUBSTITUTE FOR TAN
C---------------------------------------------------------------------
      AUG = SGN * ((COS(Z) / SIN(Z)) * 4.0E0)
      GO TO 150
  140 AUG = SGN * ((SIN(Z) / COS(Z)) * 4.0E0)
  150 X = 1.0E0 - X
  200 IF (X .GT. 3.0E0) GO TO 300
C---------------------------------------------------------------------
C     0.5 .LE. X .LE. 3.0
C---------------------------------------------------------------------
      DEN = X
      UPPER = P1(1) * X
C
      DO 210 I = 1, 5
         DEN = (DEN + Q1(I)) * X
         UPPER = (UPPER + P1(I+1)) * X
  210 CONTINUE
C
      DEN = (UPPER + P1(7)) / (DEN + Q1(6))
      XMX0 = DBLE(X) - DX0
      PSI = DEN * XMX0 + AUG
      RETURN
C---------------------------------------------------------------------
C     IF X .GE. XMAX1, PSI = LN(X)
C---------------------------------------------------------------------
  300 IF (X .GE. XMAX1) GO TO 350
C---------------------------------------------------------------------
C     3.0 .LT. X .LT. XMAX1
C---------------------------------------------------------------------
      W = 1.0E0 / (X * X)
      DEN = W
      UPPER = P2(1) * W
C
      DO 310 I = 1, 3
         DEN = (DEN + Q2(I)) * W
         UPPER = (UPPER + P2(I+1)) * W
  310 CONTINUE
C
      AUG = UPPER / (DEN + Q2(4)) - 0.5E0 / X + AUG
  350 PSI = AUG + ALOG(X)
      RETURN
C---------------------------------------------------------------------
C     ERROR RETURN
C---------------------------------------------------------------------
  400 PSI = 0.0E0
      RETURN
      END
      SUBROUTINE DCPSI (Z, W)
C-----------------------------------------------------------------------
C           EVALUATION OF THE COMPLEX DIGAMMA FUNCTION
C-----------------------------------------------------------------------
      DOUBLE PRECISION Z(2), W(2)
      DOUBLE PRECISION C0(30), PI, PI2
      DOUBLE PRECISION A, A1, A2, CN, CUT, C1, C2, EPS, ET, H1, H2,
     *                 Q1, Q2, S, SN, S1, S2, T, T1, T2, U, U1, U2,
     *                 V1, V2, W1, W2, X, Y, Y2
      DOUBLE PRECISION DREXP, DPMPAR
C----------------------------
C     PI2 = 2*PI
C----------------------------
      DATA PI   /3.141592653589793238462643383279502884197D0/
      DATA PI2  /6.283185307179586476925286766559005768394D0/
C----------------------------
      DATA C0(1)  / .8333333333333333333333333333333333333333D-01/,
     *     C0(2)  /-.8333333333333333333333333333333333333333D-02/,
     *     C0(3)  / .3968253968253968253968253968253968253968D-02/,
     *     C0(4)  /-.4166666666666666666666666666666666666667D-02/,
     *     C0(5)  / .7575757575757575757575757575757575757576D-02/,
     *     C0(6)  /-.2109279609279609279609279609279609279609D-01/,
     *     C0(7)  / .8333333333333333333333333333333333333333D-01/,
     *     C0(8)  /-.4432598039215686274509803921568627450980D+00/,
     *     C0(9)  / .3053954330270119743803954330270119743804D+01/,
     *     C0(10) /-.2645621212121212121212121212121212121212D+02/
      DATA C0(11) / .2814601449275362318840579710144927536232D+03/,
     *     C0(12) /-.3607510546398046398046398046398046398046D+04/,
     *     C0(13) / .5482758333333333333333333333333333333333D+05/,
     *     C0(14) /-.9749368238505747126436781609195402298851D+06/,
     *     C0(15) / .2005269579668807894614346227249453055905D+08/,
     *     C0(16) /-.4723848677216299019607843137254901960784D+09/,
     *     C0(17) / .1263572479591666666666666666666666666667D+11/,
     *     C0(18) /-.3808793112524536881155302207933786881155D+12/,
     *     C0(19) / .1285085049930508333333333333333333333333D+14/,
     *     C0(20) /-.4824144835485017037158167036215816703622D+15/
      DATA C0(21) / .2004031065651625273810842166323893898645D+17/,
     *     C0(22) /-.9167743603195330775699275362318840579710D+18/,
     *     C0(23) / .4597988834365650349043794326241134751773D+20/,
     *     C0(24) /-.2518047192145109569708902332022552610788D+22/,
     *     C0(25) / .1500173349215392873371144015151515151515D+24/,
     *     C0(26) /-.9689957887463594065649794289465408805031D+25/,
     *     C0(27) / .6764588237929282099094524230179847767567D+27/,
     *     C0(28) /-.5089065946866228968976633291591192528736D+29/,
     *     C0(29) / .4114728879255797869766548606761933615819D+31/,
     *     C0(30) /-.3566658209537555610968457460865182898779D+33/
C----------------------------
C
C     ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS.
C            MAX IS THE LARGEST POSITIVE INTEGER THAT MAY
C            BE USED, AND EPS IS THE SMALLEST REAL NUMBER
C            SUCH THAT 1.D0 + EPS .GT. 1.D0.
C
                      MAX = IPMPAR(3)
                      EPS = DPMPAR(1)
C
C----------------------------
      X = Z(1)
      Y = Z(2)
      IF (X .GE. 0.D0) GO TO 40
C-----------------------------------------------------------------------
C            CASE WHEN THE REAL PART OF Z IS NEGATIVE
C-----------------------------------------------------------------------
      Y = DABS(Y)
      T = -PI2*Y
      ET = DEXP(T)
C
C     SET  A1 = (1 + ET)/2  AND  A2 = (1 - ET)/2
C
      A1 = 0.5D0*(1.D0 + ET)
      IF (T .LT. -0.15D0) GO TO 10
         A2 = -0.5D0*DREXP(T)
         GO TO 20
   10 A2 = 0.5D0*(0.5D0 + (0.5D0 - ET))
C
C     COMPUTE SIN(PI*X) AND COS(PI*X), OR -SIN(PI*X) AND -COS(PI*X)
C
   20 U = MAX
      IF (DABS(X) .GE. DMIN1(U, 1.D0/EPS)) GO TO 100
      K = DABS(X)
      U = X + K
      IF (U .LE. -0.5D0) U = 0.5D0 + (0.5D0 + U)
      U = PI*U
      SN = DSIN(U)
      CN = DCOS(U)
C
C     SET H1 + H2*I = PI*COT(PI*Z)
C
      S1 = A1*SN
      S2 = A2*CN
      C1 = A1*CN
      C2 = -A2*SN
      S = S1*S1 + S2*S2
      H1 = PI*(S1*C1 + S2*C2)/S
      H2 = PI*(S1*C2 - S2*C1)/S
C
      IF (Z(2) .LT. 0.D0) GO TO 30
         X = 1.D0 - X
         Y = -Y
         GO TO 40
   30 H2 = -H2
      X = 1.D0 - X
C-----------------------------------------------------------------------
C           CASE WHEN THE REAL PART OF Z IS NONNEGATIVE
C-----------------------------------------------------------------------
   40 T = X
      Y2 = Y*Y
      A = X*X + Y2
      IF (A .EQ. 0.D0) GO TO 100
      CUT = 225.D0
      IF (EPS .GT. 1.D-30) CUT = 144.D0
C
C     LET S1 + S2*I BE THE SUM OF THE TERMS 1/(Z+J) FOR J = 0,1,...,N-1
C
      S1 = 0.D0
      S2 = 0.D0
   50    IF (A .GE. CUT) GO TO 51
         S1 = S1 + T/A
         S2 = S2 - Y/A
         T = T + 1.D0
         A = T*T + Y2
         GO TO 50
   51 CONTINUE
C
C     SET W1 + W2*I = LOG(Z+N)
C
      W1 = 0.5D0*DLOG(A)
      W2 = DATAN2(Y,T)
C
C     LET A1 + A2*I BE THE ASYMPTOTIC SUM
C
      U1 = T/A
      U2 = -Y/A
      Q1 = U1*U1 - U2*U2
      Q2 = 2.D0*U1*U2
      V1 = Q1
      V2 = Q2
      A1 = 0.D0
      A2 = 0.D0
      M = 30
      IF (EPS .GT. 1.D-30) M = 25
      DO 61 J = 1,M
         T1 = A1
         T2 = A2
         A1 = A1 + C0(J)*V1
         A2 = A2 + C0(J)*V2
         IF (A1 .NE. T1) GO TO 60
         IF (A2 .EQ. T2) GO TO 70
   60    T1 = V1*Q1 - V2*Q2
         T2 = V1*Q2 + V2*Q1
         V1 = T1
   61    V2 = T2
C-----------------------------------------------------------------------
C                 GATHERING TOGETHER THE RESULTS
C-----------------------------------------------------------------------
   70 A1 = A1 + 0.5D0*U1
      A2 = A2 + 0.5D0*U2
      W(1) = (W1 - A1) - S1
      W(2) = (W2 - A2) - S2
      IF (Z(1) .GE. 0.D0) RETURN
      W(1) = W(1) - H1
      W(2) = W(2) - H2
      RETURN
C-----------------------------------------------------------------------
C             THE REQUESTED VALUE CANNOT BE COMPUTED
C-----------------------------------------------------------------------
  100 W(1) = 0.D0
      W(2) = 0.D0
      RETURN
      END
      DOUBLE PRECISION FUNCTION DPSI(A)
C-----------------------------------------------------------------------
C
C               EVALUATION OF THE DIGAMMA FUNCTION FOR
C                     DOUBLE PRECISION ARGUMENTS
C
C                           -----------
C
C     DPSI(A) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT
C     BE COMPUTED.
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C          NAVAL SURFACE WARFARE CENTER
C          DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
C
C     THE SERIES FOR DPSI ON THE INTERVAL 0.0 TO 1.0 WAS DERIVED
C     BY WAYNE FULLERTON (LOS ALAMOS NATIONAL LABORATORY).
C
C                                  WITH WEIGHTED ERROR   5.79E-32
C                                   LOG WEIGHTED ERROR  31.24
C                         SIGNIFICANT FIGURES REQUIRED  30.93
C                              DECIMAL PLACES REQUIRED  32.05
C
C     THE SERIES FOR  A .GE. 10  WAS DERIVED BY A.H. MORRIS FROM
C     THE CHEBYSHEV SERIES IN THE SLATEC LIBRARY OBTAINED BY WAYNE
C     FULLERTON (LOS ALAMOS).
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, C(42), EPS, P(15), PI, S, T, X, X0, XMAX, W
      DOUBLE PRECISION DCSEVL, DPSI0, DPMPAR
C----------------------------
      DATA PI /3.1415926535897932384626433832795D0/
      DATA X0 /.46163214496836234126265954232572D0/
C----------------------------
      DATA C(1)  / -.38057080835217921520437677667039D-01/,
     *     C(2)  /  .49141539302938712748204699654277D+00/,
     *     C(3)  / -.56815747821244730242892064734081D-01/,
     *     C(4)  /  .83578212259143131362775650747862D-02/,
     *     C(5)  / -.13332328579943425998079274172393D-02/,
     *     C(6)  /  .22031328706930824892872397979521D-03/,
     *     C(7)  / -.37040238178456883592889086949229D-04/,
     *     C(8)  /  .62837936548549898933651418717690D-05/,
     *     C(9)  / -.10712639085061849855283541747074D-05/,
     *     C(10) /  .18312839465484165805731589810378D-06/
      DATA C(11) / -.31353509361808509869005779796885D-07/,
     *     C(12) /  .53728087762007766260471919143615D-08/,
     *     C(13) / -.92116814159784275717880632624730D-09/,
     *     C(14) /  .15798126521481822782252884032823D-09/,
     *     C(15) / -.27098646132380443065440589409707D-10/,
     *     C(16) /  .46487228599096834872947319529549D-11/,
     *     C(17) / -.79752725638303689726504797772737D-12/,
     *     C(18) /  .13682723857476992249251053892838D-12/,
     *     C(19) / -.23475156060658972717320677980719D-13/,
     *     C(20) /  .40276307155603541107907925006281D-14/
      DATA C(21) / -.69102518531179037846547422974771D-15/,
     *     C(22) /  .11856047138863349552929139525768D-15/,
     *     C(23) / -.20341689616261559308154210484223D-16/,
     *     C(24) /  .34900749686463043850374232932351D-17/,
     *     C(25) / -.59880146934976711003011081393493D-18/,
     *     C(26) /  .10273801628080588258398005712213D-18/,
     *     C(27) / -.17627049424561071368359260105386D-19/,
     *     C(28) /  .30243228018156920457454035490133D-20/,
     *     C(29) / -.51889168302092313774286088874666D-21/,
     *     C(30) /  .89027730345845713905005887487999D-22/
      DATA C(31) / -.15274742899426728392894971904000D-22/,
     *     C(32) /  .26207314798962083136358318079999D-23/,
     *     C(33) / -.44964642738220696772598388053333D-24/,
     *     C(34) /  .77147129596345107028919364266666D-25/,
     *     C(35) / -.13236354761887702968102638933333D-25/,
     *     C(36) /  .22709994362408300091277311999999D-26/,
     *     C(37) / -.38964190215374115954491391999999D-27/,
     *     C(38) /  .66851981388855302310679893333333D-28/,
     *     C(39) / -.11469986654920864872529919999999D-28/,
     *     C(40) /  .19679385886541405920515413333333D-29/
      DATA C(41) / -.33764488189750979801907200000000D-30/,
     *     C(42) /  .57930703193214159246677333333333D-31/
C----------------------------
      DATA P(1)  / .833333333333333333333333333147D-03/,
     *     P(2)  /-.833333333333333333333317475057D-06/,
     *     P(3)  / .396825396825396825343072884056D-08/,
     *     P(4)  /-.416666666666666570859890514548D-10/,
     *     P(5)  / .757575757575654146210665696401D-12/,
     *     P(6)  /-.210927960920616064592099772274D-13/,
     *     P(7)  / .833333329719356554828382131321D-15/,
     *     P(8)  /-.443259676504784387819140445894D-16/,
     *     P(9)  / .305392145578967948828783519552D-17/,
     *     P(10) /-.264499326810660590871410866039D-18/
      DATA P(11) / .280568932535744579536244004181D-19/,
     *     P(12) /-.351388195869099967789469969066D-20/,
     *     P(13) / .476233402067211507540059750399D-21/,
     *     P(14) /-.575024569953144855161645738666D-22/,
     *     P(15) / .416180125797657207803740160000D-23/
C----------------------------
C
C     ****** XMAX, MAX, AND EPS ARE MACHINE DEPENDENT CONSTANTS.
C            XMAX IS THE LARGEST POSITIVE REAL NUMBER THAT MAY
C            BE USED, MAX IS THE LARGEST POSITIVE INTEGER THAT
C            MAY BE USED, AND EPS IS THE SMALLEST REAL NUMBER
C            SUCH THAT 1.D0 + EPS .GT. 1.D0.
C
                      MAX  = IPMPAR(3)
                      EPS  = DPMPAR(1)
                      XMAX = DPMPAR(3)
C
C----------------------------
      DPSI = 0.D0
      X = A
      IF (DABS(A) .GE. 10.D0) GO TO 60
C-----------------------------------------------------------------------
C             EVALUATION OF DPSI(A) FOR DABS(A) .LT. 10
C-----------------------------------------------------------------------
      T = 0.D0
      N = X
      N = N - 1
C
C     LET T BE THE SUM OF 1/(A-J) WHEN A .GE. 2
C
      IF (N) 20,12,10
   10 DO 11 J = 1,N
         X = X - 1.D0
         T = 1.D0/X + T
   11 CONTINUE
   12 X = X - 1.D0
      GO TO 40
C
C     CHECK IF 1/A CAN OVERFLOW
C
   20 IF (DABS(A) .GE. 1.D-35) GO TO 30
      IF (DABS(A)*XMAX .LE. 1.000000001D0) RETURN
C
C     LET T BE THE SUM OF -1/(A+J) WHEN A .LT. 1
C
   30 T = -1.D0/A
      IF (A .GT. 0.D0) GO TO 40
      N = - N - 1
      IF (N .EQ. 0) GO TO 32
      DO 31 J = 1,N
         X = X + 1.D0
         IF (X .EQ. 0.D0) RETURN
         T = T - 1.D0/X
   31 CONTINUE
   32 X = (X + 0.5D0) + 0.5D0
      IF (X .EQ. 0.D0) RETURN
      T = T - 1.D0/X
C
C     COMPUTE  T + DPSI(1 + X)  FOR 0 .LE. X .LT. 1
C
   40 IF (DABS(X - X0) .GT. 2.D-2) GO TO 50
         DPSI = T + DPSI0(1.D0 + X)
         RETURN
   50 K = 42
      IF (EPS .GT. 1.D-20) K = 28
      DPSI = T + DCSEVL (2.D0*X - 1.D0, C, K)
      RETURN
C-----------------------------------------------------------------------
C           EVALUATION OF DPSI(A) FOR DABS(A) .GE. 10
C-----------------------------------------------------------------------
   60 IF (A .GT. 0.D0) GO TO 70
      T = MAX
      IF (DABS(A) .GE. DMIN1(T, 1.D0/EPS)) RETURN
C
C     SET W = PI*COT(PI*A) WHEN A IS NEGATIVE
C
      K = DABS(A)
      T = A + K
      IF (T .EQ. 0.D0) RETURN
      IF (T .LE. -0.5D0) T = 1.D0 + T
      T = PI*T
      W = PI*(DCOS(T)/DSIN(T))
      X = 1.D0 - X
C
C     COMPUTE THE MODIFIED ASYMPTOTIC SUM
C
   70 T = (10.D0/X)**2
      S = P(15)
      DO 71 J = 1,14
         L = 15 - J
         S = P(L) + T*S
   71 CONTINUE
      S = 0.5D0/X + T*S
C
C     FINAL ASSEMBLY
C
      DPSI = DLOG(X) - S
      IF (A .LT. 0.D0) DPSI = DPSI - W
      RETURN
      END
      DOUBLE PRECISION FUNCTION DPSI0 (X)
C-----------------------------------------------------------------------
C
C            TAYLOR SERIES EXPANSION OF PSI(X) AROUND X0,
C                  WHERE X0 IS THE ZERO OF PSI(X).
C
C-------------------------
C     WRITTEN BY A.H. MORRIS
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(20), H, X, W
      DOUBLE PRECISION DK1, DK2, DK3, DB, DB2, DX
C-------------------------
      DATA DK1 /100442596182.D0/, DK2 /51069247913.D0/,
     *     DK3 /53827985572.D0/
      DATA DB  /68719476736.D0/
      DATA DX  /.28939299282041499433886199389507989269636D-32/
C-------------------------
      DATA A(1)  / .967672245447621170427444761710D+00/,
     *     A(2)  /-.442763168983592106092865281853D+00/,
     *     A(3)  / .258499760955651010624401385701D+00/,
     *     A(4)  /-.163942705442406527504251292747D+00/,
     *     A(5)  / .107824050691262365757182948867D+00/,
     *     A(6)  /-.721995612564547109261217836051D-01/,
     *     A(7)  / .488042881641431072250925255079D-01/,
     *     A(8)  /-.331611264748473592922583984045D-01/,
     *     A(9)  / .225976482322181046596248251178D-01/,
     *     A(10) /-.154247659049489591388003168412D-01/
      DATA A(11) / .105387916166121753881240498824D-01/,
     *     A(12) /-.720453438635686824097047437040D-02/,
     *     A(13) / .492678139572985344635426640268D-02/,
     *     A(14) /-.336980165543932808279285672353D-02/,
     *     A(15) / .230512632673492783693838028298D-02/,
     *     A(16) /-.157693677143019725927093497173D-02/,
     *     A(17) / .107882520191629658069191777474D-02/,
     *     A(18) /-.738070938996005129566047389379D-03/,
     *     A(19) / .504953265834602035177398177463D-03/,
     *     A(20) /-.345468025106307699555567970882D-03/
C-------------------------
C
C     SET  H = X - X0  WHERE X0 IS THE ZERO OF PSI(X). X0 HAS THE
C     APPROXIMATE 60 DIGIT VALUE ...
C
C      1.4616321449683623412 62659542325721328468 19620400644635129598
C
C     A MORE ACCURATE VALUE IS GIVEN BY ...
C
C            X0 = DK1/8**12 + DK2/8**24 + DK3/8**36 + DX
C
C     THE FOLLOWING CODE SHOULD YIELD THE CORRECT VALUE FOR H IF A
C     BINARY, OCTAL, OR HEXADECIMAL DOUBLE PRECISION ARITHMETIC IS
C     BEING USED.
C
      DB2 = DB*DB
      H = (((X - DK1/DB) - DK2/DB2) - DK3/(DB*DB2)) - DX
C
C-------------------------
C
      N = 20
      NM1 = N - 1
      W = A(N)
      DO 10 I = 1,NM1
         L = N - I
         W = A(L) + H*W
   10 CONTINUE
      DPSI0 = H*W
      RETURN
      END
      SUBROUTINE PSIDF (X, N, M, ANS, IFLAG)
C-----------------------------------------------------------------------
C
C         PSIDF COMPUTES M MEMBER SEQUENCES OF SCALED DERIVATIVES OF
C         THE PSI FUNCTION
C
C                W(K,X)=(-1)**(K+1)*PSI(K,X)/GAMMA(K+1)
C
C         K=N,...,N+M-1 WHERE PSI(K,X) IS THE K-TH DERIVATIVE OF THE
C         PSI FUNCTION.
C
C         THE BASIC METHOD OF EVALUATION IS THE ASYMPTOTIC EXPANSION
C         FOR LARGE X.GE.XMIN FOLLOWED BY BACKWARD RECURSION ON A TWO
C         TERM RECURSION RELATION
C
C                  W(X+1) + X**(-N-1) = W(X).
C
C         THIS IS SUPPLEMENTED BY A SERIES
C
C                  SUM( (X+K)**(-N-1) , K=0,1,2,... )
C
C         WHICH CONVERGES RAPIDLY FOR LARGE N. BOTH XMIN AND THE
C         NUMBER OF TERMS OF THE SERIES ARE CALCULATED FROM THE UNIT
C         ROUND OFF OF THE MACHINE ENVIRONMENT.
C
C         THE NOMINAL COMPUTATIONAL ACCURACY IS THE MAXIMUM OF UNIT
C         ROUNDOFF (=SPMPAR(1)) AND 1.0E-18 SINCE CRITICAL CONSTANTS
C         ARE GIVEN TO ONLY 18 DIGITS.
C
C     DESCRIPTION OF ARGUMENTS
C
C         INPUT
C
C           X      - ARGUMENT, X .GT. 0.0
C
C           N      - FIRST MEMBER OF THE SEQUENCE, N .GE. 0
C
C           M      - NUMBER OF MEMBERS OF THE SEQUENCE, M .GE. 1
C
C         OUTPUT
C
C           ANS    - A VECTOR OF LENGTH AT LEAST M WHOSE FIRST M
C                    COMPONENTS ARE THE SCALED DERIVATIVES.
C
C           IFLAG  - A VARIABLE WHICH REPORTS THE STATUS OF THE
C                    RESULTS.
C                    IFLAG = 0 THE DESIRED VALUES WERE OBTAINED.
C                    IFLAG = 1 AN INPUT ERROR WAS DETECTED.
C                    IFLAG = 2 OVERFLOW. X TOO SMALL OR N+M-1
C                              TOO LARGE.
C                    IFLAG = 3 UNDERFLOW. X TOO LARGE OR N+M-1
C                              TOO LARGE.
C                    IFLAG = 4 N+M-1 IS TOO LARGE FOR THE CURRENT
C                              VALUE OF X. THIS SETTING WILL NOT
C                              OCCUR WHEN N+M-1 .LE. 100.
C
C-----------------------------------------------------------------------
C     WRITTEN BY DONALD E. AMOS
C         SANDIA LABORATORIES
C         JUNE 1982
C     MODIFIED BY A. H. MORRIS (NSWC), 1990.
C
C     REFERENCES ...
C
C     (1) ACM TRANS. MATH SOFTWARE, 1983.
C     (2) HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55, NATIONAL BUREAU
C         OF STANDARDS BY M. ABRAMOWITZ AND I.A. STEGUN, 1964, PP.
C         258-260, EQUATIONS 6.3.5, 6.3.18, 6.4.6, 6.4.9, 6.4.10.
C-----------------------------------------------------------------------
      REAL ALPHA, ARG, BETA, C, DEN, ELIM, EPS, FLN, FN, FNP, FNS,
     *     FX, ND, RXSQ, S, T, TA, TK, TOL, TOLS, TSS, TST, TT, T1,
     *     T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, XM, XMIN
      REAL ANS(M), B(22), TRM(22), TRMR(100)
      REAL EPSLN, EXPARG, SPMPAR
C------------------------
C     C = 1/LN(10)
C------------------------
      DATA C /.43429/
      DATA NMAX /100/
C-----------------------------------------------------------------------
C                        BERNOULLI NUMBERS
C-----------------------------------------------------------------------
      DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10),
     * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19),
     * B(20), B(21), B(22) /1.0,
     * -5.00000000000000000E-01,1.66666666666666667E-01,
     * -3.33333333333333333E-02,2.38095238095238095E-02,
     * -3.33333333333333333E-02,7.57575757575757576E-02,
     * -2.53113553113553114E-01,1.16666666666666667E+00,
     * -7.09215686274509804E+00,5.49711779448621554E+01,
     * -5.29124242424242424E+02,6.19212318840579710E+03,
     * -8.65802531135531136E+04,1.42551716666666667E+06,
     * -2.72982310678160920E+07,6.01580873900642368E+08,
     * -1.51163157670921569E+10,4.29614643061166667E+11,
     * -1.37116552050883328E+13,4.88332318973593167E+14,
     * -1.92965793419400681E+16/
C------------------------
      IFLAG = 0
      IF (X .LE. 0.0 .OR. N .LT. 0 .OR. M .LT. 1) GO TO 300
C
      NN = N + M - 1
      FN = FLOAT(NN)
      FNP = FN + 1.0
      EPS = SPMPAR(1)
      WDTOL = AMAX1(0.5*EPS, 0.5E-18)
C-----------------------------------------------------------------------
C     ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT
C-----------------------------------------------------------------------
      ELIM = AMIN1(EXPARG(0), ABS(EXPARG(1))) - 6.906
      XLN = ALOG(X)
      T = FNP*XLN
C-----------------------------------------------------------------------
C     OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X
C-----------------------------------------------------------------------
      IF (ABS(T) .GT. ELIM) GO TO 310
      IF (X .LT. WDTOL) GO TO 260
C-----------------------------------------------------------------------
C     COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1
C-----------------------------------------------------------------------
      ND = -C*EPSLN(0)
      ND = AMIN1(ND,18.0)
      FLN = ND - 3.0
      ALPHA = 3.5 + 0.4*FLN
      BETA = 0.21 + FLN*(0.0006038*FLN + 0.008677)
      XM = ALPHA + BETA*FN
      MX = INT(XM) + 1
      XMIN = FLOAT(MX)
C
      IF (N .EQ. 0) GO TO 50
      XM = -2.302*ND - AMIN1(0.0,XLN)
      FNS = FLOAT(N)
      ARG = XM/FNS
      ARG = AMIN1(0.0,ARG)
      EPS = EXP(ARG)
      XM = 1.0 - EPS
      IF (ABS(ARG) .LT. 1.0E-3) XM = -ARG
      FLN = X*XM/EPS
      XM = XMIN - X
      IF (XM .GT. 7.0 .AND. FLN .LT. 15.0) GO TO 200
C
   50 XDMY = X
      XDMLN = XLN
      XINC = 0.0
      IF (X .GE. XMIN) GO TO 60
         NX = INT(X)
         XINC = XMIN - FLOAT(NX)
         XDMY = X + XINC
         XDMLN = ALOG(XDMY)
   60 CONTINUE
C-----------------------------------------------------------------------
C     GENERATE W(N+M-1,X) BY THE ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      T = FN*XDMLN
      T1 = XDMLN + XDMLN
      T2 = T + XDMLN
      TK = AMAX1(ABS(T),ABS(T1),ABS(T2))
      IF (TK .GT. ELIM) GO TO 320
C
      TSS = EXP(-T)
      TT = 0.5/XDMY
      T1 = TT
      TST = WDTOL*TT
      IF (NN .NE. 0) T1 = TT + 1.0/FN
      RXSQ = 1.0/(XDMY*XDMY)
      TA = 0.5*RXSQ
      T = FNP*TA
      S = T*B(3)
      IF (ABS(S) .LT. TST) GO TO 80
C
      TK = 2.0
      DO 70 K = 4,22
         T = T*((TK+FN + 1.0)/(TK + 1.0))*((TK+FN)/(TK + 2.0))*RXSQ
         TRM(K) = T*B(K)
         IF (ABS(TRM(K)) .LT. TST) GO TO 80
         S = S + TRM(K)
         TK = TK + 2.0
   70 CONTINUE
C
   80 S = (S + T1)*TSS
      IF (XINC .EQ. 0.0) GO TO 100
C-----------------------------------------------------------------------
C     BACKWARD RECUR FROM XDMY TO X
C-----------------------------------------------------------------------
      NX = INT(XINC)
      NP = NN + 1
      IF (NX .GT. NMAX) GO TO 330
      IF (NN .EQ. 0) GO TO 160
      XM = XINC - 1.0
      FX = X + XM
C-----------------------------------------------------------------------
C     THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL
C-----------------------------------------------------------------------
      DO 90 I = 1,NX
         TRMR(I) = FX**(-NP)
         S = S + TRMR(I)
         XM = XM - 1.0
         FX = X + XM
   90 CONTINUE
C
  100 ANS(M) = S
      IF (FN .EQ. 0.0) GO TO 180
C-----------------------------------------------------------------------
C     GENERATE LOWER DERIVATIVES, J.LT.N+M-1
C-----------------------------------------------------------------------
      IF (M .EQ. 1) RETURN
      DO 150 J = 2,M
         FNP = FN
         FN = FN - 1.0
         TSS = TSS*XDMY
         T1 = TT
         IF (FN .NE. 0.0) T1 = TT + 1.0/FN
         T = FNP*TA
         S = T*B(3)
         IF (ABS(S) .LT. TST) GO TO 120
C
         TK = 3.0E0 + FNP
         DO 110 K = 4,22
            TRM(K) = TRM(K)*FNP/TK
            IF (ABS(TRM(K)) .LT. TST) GO TO 120
            S = S + TRM(K)
            TK = TK + 2.0
  110    CONTINUE
C
  120    S = (S + T1)*TSS
         IF (XINC .EQ. 0.0) GO TO 140
         IF (FN .EQ. 0.0) GO TO 160
         XM = XINC - 1.0
         FX = X + XM
         DO 130 I = 1,NX
            TRMR(I) = TRMR(I)*FX
            S = S + TRMR(I)
            XM = XM - 1.0
            FX = X + XM
  130    CONTINUE
C
  140    MX = M - J + 1
         ANS(MX) = S
         IF (FN .EQ. 0.0) GO TO 180
  150 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     RECURSION FOR N = 0
C-----------------------------------------------------------------------
  160 DO 170 I = 1,NX
         S = S + 1.0/(X + FLOAT(NX-I))
  170 CONTINUE
C
  180 ANS(1) = S - XDMLN
      RETURN
C-----------------------------------------------------------------------
C     COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,...
C-----------------------------------------------------------------------
  200 NN = INT(FLN) + 1
      NP = N + 1
      T1 = (FNS + 1.0)*XLN
      T = EXP(-T1)
      S = T
      DEN = X
      DO 210 I = 1,NN
         DEN = DEN + 1.0
         TRM(I) = DEN**(-NP)
         S = S + TRM(I)
  210 CONTINUE
      ANS(1) = S
      IF (M .EQ. 1) RETURN
C-----------------------------------------------------------------------
C     GENERATE HIGHER DERIVATIVES, J .GT. N
C-----------------------------------------------------------------------
      TOL = WDTOL/5.0
      DO 250 J = 2,M
         T = T/X
         S = T
         TOLS = T*TOL
         DEN = X
         DO 230 I = 1,NN
            DEN = DEN + 1.0
            TRM(I) = TRM(I)/DEN
            S = S + TRM(I)
            IF (TRM(I) .LT. TOLS) GO TO 240
  230    CONTINUE
  240    ANS(J) = S
  250 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     SMALL X .LT. UNIT ROUND OFF
C-----------------------------------------------------------------------
  260 ANS(1) = X**(-N-1)
      IF (M .EQ. 1) RETURN
      K = 1
      DO 270 I = 2,M
         ANS(K+1) = ANS(K)/X
         K = K + 1
  270 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     ERROR RETURN
C-----------------------------------------------------------------------
  300 IFLAG = 1
      RETURN
C
  310 IF (T .GT. 0.0) GO TO 320
      IFLAG = 2
      RETURN
C
  320 IFLAG = 3
      RETURN
C                            INCREASE THE DIMENSION OF TRMR(NMAX)
  330 IFLAG = 4
      RETURN
      END
      REAL FUNCTION BETALN (A0, B0)
C-----------------------------------------------------------------------
C     EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION
C-----------------------------------------------------------------------
C     E = 0.5*LN(2*PI)
C--------------------------
      DATA E /.918938533204673/
C--------------------------
      A = AMIN1(A0,B0)
      B = AMAX1(A0,B0)
      IF (A .GE. 8.0) GO TO 60
      IF (A .GE. 1.0) GO TO 20
C-----------------------------------------------------------------------
C                   PROCEDURE WHEN A .LT. 1
C-----------------------------------------------------------------------
      IF (B .GE. 8.0) GO TO 10
         BETALN = GAMLN(A) + (GAMLN(B) - GAMLN(A + B))
         RETURN
   10 BETALN = GAMLN(A) + ALGDIV(A,B)
      RETURN
C-----------------------------------------------------------------------
C                PROCEDURE WHEN 1 .LE. A .LT. 8
C-----------------------------------------------------------------------
   20 IF (A .GT. 2.0) GO TO 30
      IF (B .GT. 2.0) GO TO 21
         BETALN = GAMLN(A) + GAMLN(B) - GSUMLN(A,B)
         RETURN
   21 W = 0.0
      IF (B .LT. 8.0) GO TO 40
         BETALN = GAMLN(A) + ALGDIV(A,B)
         RETURN
C
C                REDUCTION OF A WHEN B .LE. 1000
C
   30 IF (B .GT. 1000.0) GO TO 50
      N = A - 1.0
      W = 1.0
      DO 31 I = 1,N
         A = A - 1.0
         H = A/B
         W = W * (H/(1.0 + H))
   31 CONTINUE
      W = ALOG(W)
      IF (B .LT. 8.0) GO TO 40
      BETALN = W + GAMLN(A) + ALGDIV(A,B)
      RETURN
C
C                 REDUCTION OF B WHEN B .LT. 8
C
   40 N = B - 1.0
      Z = 1.0
      DO 41 I = 1,N
         B = B - 1.0
         Z = Z * (B/(A + B))
   41 CONTINUE
      BETALN = W + ALOG(Z) + (GAMLN(A) + (GAMLN(B) - GSUMLN(A,B)))
      RETURN
C
C                REDUCTION OF A WHEN B .GT. 1000
C
   50 N = A - 1.0
      W = 1.0
      DO 51 I = 1,N
         A = A - 1.0
         W = W * (A/(1.0 + A/B))
   51 CONTINUE
      BETALN = (ALOG(W) - N*ALOG(B)) + (GAMLN(A) + ALGDIV(A,B))
      RETURN
C-----------------------------------------------------------------------
C                   PROCEDURE WHEN A .GE. 8
C-----------------------------------------------------------------------
   60 W = BCORR(A,B)
      H = A/B
      C = H/(1.0 + H)
      U = -(A - 0.5)*ALOG(C)
      V = B*ALNREL(H)
      IF (U .LE. V) GO TO 61
         BETALN = (((-0.5*ALOG(B) + E) + W) - V) - U
         RETURN
   61 BETALN = (((-0.5*ALOG(B) + E) + W) - U) - V
      RETURN
      END
      REAL FUNCTION GSUMLN (A, B)
C-----------------------------------------------------------------------
C          EVALUATION OF THE FUNCTION LN(GAMMA(A + B))
C          FOR 1 .LE. A .LE. 2  AND  1 .LE. B .LE. 2
C-----------------------------------------------------------------------
      X = DBLE(A) + DBLE(B) - 2.D0
      IF (X .GT. 0.25) GO TO 10
         GSUMLN = GAMLN1(1.0 + X)
         RETURN
   10 IF (X .GT. 1.25) GO TO 20
         GSUMLN = GAMLN1(X) + ALNREL(X)
         RETURN
   20 GSUMLN = GAMLN1(X - 1.0) + ALOG(X*(1.0 + X))
      RETURN
      END
      REAL FUNCTION BCORR (A0, B0)
C-----------------------------------------------------------------------
C
C     EVALUATION OF  DEL(A0) + DEL(B0) - DEL(A0 + B0)  WHERE
C     LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A).
C     IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8.
C
C-----------------------------------------------------------------------
      DATA C0/.833333333333333E-01/, C1/-.277777777760991E-02/,
     *     C2/.793650666825390E-03/, C3/-.595202931351870E-03/,
     *     C4/.837308034031215E-03/, C5/-.165322962780713E-02/
C------------------------
      A = AMIN1(A0, B0)
      B = AMAX1(A0, B0)
C
      H = A/B
      C = H/(1.0 + H)
      X = 1.0/(1.0 + H)
      X2 = X*X
C
C                SET SN = (1 - X**N)/(1 - X)
C
      S3 = 1.0 + (X + X2)
      S5 = 1.0 + (X + X2*S3)
      S7 = 1.0 + (X + X2*S5)
      S9 = 1.0 + (X + X2*S7)
      S11 = 1.0 + (X + X2*S9)
C
C                SET W = DEL(B) - DEL(A + B)
C
      T = (1.0/B)**2
      W = ((((C5*S11*T + C4*S9)*T + C3*S7)*T + C2*S5)*T + C1*S3)*T + C0
      W = W*(C/B)
C
C                   COMPUTE  DEL(A) + W
C
      T = (1.0/A)**2
      BCORR = (((((C5*T + C4)*T + C3)*T + C2)*T + C1)*T + C0)/A + W
      RETURN
      END
      REAL FUNCTION ALGDIV (A, B)
C-----------------------------------------------------------------------
C
C     COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8
C
C                         --------
C
C     IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY
C     LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X).
C
C-----------------------------------------------------------------------
      DATA C0/.833333333333333E-01/, C1/-.277777777760991E-02/,
     *     C2/.793650666825390E-03/, C3/-.595202931351870E-03/,
     *     C4/.837308034031215E-03/, C5/-.165322962780713E-02/
C------------------------
      IF (A .LE. B) GO TO 10
         H = B/A
         C = 1.0/(1.0 + H)
         X = H/(1.0 + H)
         D = A + (B - 0.5)
         GO TO 20
   10 H = A/B
      C = H/(1.0 + H)
      X = 1.0/(1.0 + H)
      D = B + (A - 0.5)
C
C                SET SN = (1 - X**N)/(1 - X)
C
   20 X2 = X*X
      S3 = 1.0 + (X + X2)
      S5 = 1.0 + (X + X2*S3)
      S7 = 1.0 + (X + X2*S5)
      S9 = 1.0 + (X + X2*S7)
      S11 = 1.0 + (X + X2*S9)
C
C                SET W = DEL(B) - DEL(A + B)
C
      T = (1.0/B)**2
      W = ((((C5*S11*T + C4*S9)*T + C3*S7)*T + C2*S5)*T + C1*S3)*T + C0
      W = W*(C/B)
C
C                    COMBINE THE RESULTS
C
      U = D*ALNREL(A/B)
      V = A*(ALOG(B) - 1.0)
      IF (U .LE. V) GO TO 30
         ALGDIV = (W - V) - U
         RETURN
   30 ALGDIV = (W - U) - V
      RETURN
      END
      DOUBLE PRECISION FUNCTION DBETLN (A0, B0)
C-----------------------------------------------------------------------
C     EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION
C-----------------------------------------------------------------------
      DOUBLE PRECISION A0, B0
      DOUBLE PRECISION A, B, C, E, H, SN, U, V, W, Z
      DOUBLE PRECISION DBCORR, DGAMLN, DGSMLN, DLGDIV, DLNREL
C--------------------------
C     E = 0.5*LN(2*PI)
C--------------------------
      DATA E /.9189385332046727417803297364056D0/
C--------------------------
      A = DMIN1(A0,B0)
      B = DMAX1(A0,B0)
      IF (A .GE. 10.D0) GO TO 60
      IF (A .GE. 1.D0) GO TO 20
C-----------------------------------------------------------------------
C                   PROCEDURE WHEN A .LT. 1
C-----------------------------------------------------------------------
      IF (B .GE. 10.D0) GO TO 10
         DBETLN = DGAMLN(A) + (DGAMLN(B) - DGAMLN(A + B))
         RETURN
   10 DBETLN = DGAMLN(A) + DLGDIV(A,B)
      RETURN
C-----------------------------------------------------------------------
C               PROCEDURE WHEN 1 .LE. A .LT. 10
C-----------------------------------------------------------------------
   20 IF (A .GT. 2.D0) GO TO 30
      IF (B .GT. 2.D0) GO TO 21
         DBETLN = DGAMLN(A) + DGAMLN(B) - DGSMLN(A,B)
         RETURN
   21 W = 0.D0
      IF (B .LT. 10.D0) GO TO 40
         DBETLN = DGAMLN(A) + DLGDIV(A,B)
         RETURN
C
C               REDUCTION OF A WHEN B .LE. 1000
C
   30 IF (B .GT. 1.D3) GO TO 50
      N = A - 1.D0
      W = 1.D0
      DO 31 I = 1,N
         A = A - 1.D0
         H = A/B
         W = W * (H/(1.D0 + H))
   31 CONTINUE
      W = DLOG(W)
      IF (B .LT. 10.D0) GO TO 40
      DBETLN = W + DGAMLN(A) + DLGDIV(A,B)
      RETURN
C
C                REDUCTION OF B WHEN B .LT. 10
C
   40 N = B - 1.D0
      Z = 1.D0
      DO 41 I = 1,N
         B = B - 1.D0
         Z = Z * (B/(A + B))
   41 CONTINUE
      DBETLN = W + DLOG(Z) + (DGAMLN(A) + (DGAMLN(B) - DGSMLN(A,B)))
      RETURN
C
C               REDUCTION OF A WHEN B .GT. 1000
C
   50 N = A - 1.D0
      W = 1.D0
      DO 51 I = 1,N
         A = A - 1.D0
         W = W*(A/(1.D0 + A/B))
   51 CONTINUE
      SN = N
      DBETLN = (DLOG(W) - SN*DLOG(B)) + (DGAMLN(A) + DLGDIV(A,B))
      RETURN
C-----------------------------------------------------------------------
C                  PROCEDURE WHEN A .GE. 10
C-----------------------------------------------------------------------
   60 W = DBCORR(A,B)
      H = A/B
      C = H/(1.D0 + H)
      U = -(A - 0.5D0)*DLOG(C)
      V = B*DLNREL(H)
      IF (U .LE. V) GO TO 61
         DBETLN = (((-0.5D0*DLOG(B) + E) + W) - V) - U
         RETURN
   61 DBETLN = (((-0.5D0*DLOG(B) + E) + W) - U) - V
      RETURN
      END
      DOUBLE PRECISION FUNCTION DGSMLN (A, B)
C-----------------------------------------------------------------------
C          EVALUATION OF THE FUNCTION LN(GAMMA(A + B))
C          FOR 1 .LE. A .LE. 2  AND  1 .LE. B .LE. 2
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, B, X
      DOUBLE PRECISION DGMLN1, DLNREL
C
      X = (A - 1.D0) + (B - 1.D0)
      IF (X .GT. 0.5D0) GO TO 10
         DGSMLN = DGMLN1(1.D0 + X)
         RETURN
   10 IF (X .GT. 1.5D0) GO TO 20
         DGSMLN = DGMLN1(X) + DLNREL(X)
         RETURN
   20 DGSMLN = DGMLN1(X - 1.D0) + DLOG(X*(1.D0 + X))
      RETURN
      END
      DOUBLE PRECISION FUNCTION DBCORR (A0, B0)
C-----------------------------------------------------------------------
C
C     EVALUATION OF DEL(A) + DEL(B0) - DEL(A) + B0) WHERE
C     LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X).
C     IT IS ASSUMED THAT A0 .GE. 10 AND B0 .GE. 10.
C
C                         --------
C
C     THE SERIES FOR DEL(X), WHICH APPLIES FOR X .GE. 10, WAS
C     DERIVED BY A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE
C     SLATEC LIBRARY OBTAINED BY WAYNE FULLERTON (LOS ALAMOS).
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A0, B0
      DOUBLE PRECISION A, B, C, E(15), H, S(15), T, W, X, X2, Z
C--------------------------
      DATA E(1)  / .833333333333333333333333333333D-01/,
     *     E(2)  /-.277777777777777777777777752282D-04/,
     *     E(3)  / .793650793650793650791732130419D-07/,
     *     E(4)  /-.595238095238095232389839236182D-09/,
     *     E(5)  / .841750841750832853294451671990D-11/,
     *     E(6)  /-.191752691751854612334149171243D-12/,
     *     E(7)  / .641025640510325475730918472625D-14/,
     *     E(8)  /-.295506514125338232839867823991D-15/,
     *     E(9)  / .179643716359402238723287696452D-16/,
     *     E(10) /-.139228964661627791231203060395D-17/
      DATA E(11) / .133802855014020915603275339093D-18/,
     *     E(12) /-.154246009867966094273710216533D-19/,
     *     E(13) / .197701992980957427278370133333D-20/,
     *     E(14) /-.234065664793997056856992426667D-21/,
     *     E(15) / .171348014966398575409015466667D-22/
C--------------------------
      A = DMIN1(A0, B0)
      B = DMAX1(A0, B0)
C
      H = A/B
      C = H/(1.D0 + H)
      X = 1.D0/(1.D0 + H)
      X2 = X*X
C
C        COMPUTE (1 - X**N)/(1 - X) FOR N = 1,3,5,...
C            STORE THESE VALUES IN S(1),S(2),...
C
      S(1) = 1.D0
      DO 10 J = 1,14
         S(J + 1) = 1.D0 + (X + X2*S(J))
   10 CONTINUE
C
C                SET W = DEL(B) - DEL(A + B)
C
      T = (10.D0/B)**2
      W = E(15)*S(15)
      DO 20 J = 1,14
         K = 15 - J
         W = T*W + E(K)*S(K)
   20 CONTINUE
      W = W*(C/B)
C
C                    COMPUTE  DEL(A) + W
C
      T = (10.D0/A)**2
      Z = E(15)
      DO 30 J = 1,14
         K = 15 - J
         Z = T*Z + E(K)
   30 CONTINUE
      DBCORR = Z/A + W
      RETURN
      END
      DOUBLE PRECISION FUNCTION DLGDIV (A, B)
C-----------------------------------------------------------------------
C
C     COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) FOR B .GE. 10
C
C                         --------
C
C     DLGDIV USES A SERIES FOR THE FUNCTION DEL(X) WHERE
C     LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X).
C     THE SERIES FOR DEL(X), WHICH APPLIES FOR X .GE. 10, WAS
C     DERIVED BY A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE
C     SLATEC LIBRARY OBTAINED BY WAYNE FULLERTON (LOS ALAMOS).
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, B
      DOUBLE PRECISION C, D, E(15), H, S(15), T, U, V, W, X, X2
      DOUBLE PRECISION DLNREL
C--------------------------
      DATA E(1)  / .833333333333333333333333333333D-01/,
     *     E(2)  /-.277777777777777777777777752282D-04/,
     *     E(3)  / .793650793650793650791732130419D-07/,
     *     E(4)  /-.595238095238095232389839236182D-09/,
     *     E(5)  / .841750841750832853294451671990D-11/,
     *     E(6)  /-.191752691751854612334149171243D-12/,
     *     E(7)  / .641025640510325475730918472625D-14/,
     *     E(8)  /-.295506514125338232839867823991D-15/,
     *     E(9)  / .179643716359402238723287696452D-16/,
     *     E(10) /-.139228964661627791231203060395D-17/
      DATA E(11) / .133802855014020915603275339093D-18/,
     *     E(12) /-.154246009867966094273710216533D-19/,
     *     E(13) / .197701992980957427278370133333D-20/,
     *     E(14) /-.234065664793997056856992426667D-21/,
     *     E(15) / .171348014966398575409015466667D-22/
C--------------------------
      IF (A .LE. B) GO TO 10
         H = B/A
         C = 1.D0/(1.D0 + H)
         X = H/(1.D0 + H)
         D = A + (B - 0.5D0)
         GO TO 20
   10 H = A/B
      C = H/(1.D0 + H)
      X = 1.D0/(1.D0 + H)
      D = B + (A - 0.5D0)
C
C        COMPUTE (1 - X**N)/(1 - X) FOR N = 1,3,5,...
C            STORE THESE VALUES IN S(1),S(2),...
C
   20 X2 = X*X
      S(1) = 1.D0
      DO 21 J = 1,14
         S(J + 1) = 1.D0 + (X + X2*S(J))
   21 CONTINUE
C
C                SET W = DEL(B) - DEL(A + B)
C
      T = (10.D0/B)**2
      W = E(15)*S(15)
      DO 30 J = 1,14
         K = 15 - J
         W = T*W + E(K)*S(K)
   30 CONTINUE
      W = W*(C/B)
C
C                    COMBINE THE RESULTS
C
      U = D*DLNREL(A/B)
      V = A*(DLOG(B) - 1.D0)
      IF (U .LE. V) GO TO 40
         DLGDIV = (W - V) - U
         RETURN
   40 DLGDIV = (W - U) - V
      RETURN
      END
      SUBROUTINE GRATIO (A, X, ANS, QANS, IND)
C-----------------------------------------------------------------------
C
C        EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS
C                      P(A,X) AND Q(A,X)
C
C                        ----------
C
C     IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X
C     ARE NOT BOTH 0.
C
C     ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE
C     P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER.
C     IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS
C     POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF
C     IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE
C     6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY
C     IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT.
C
C     ERROR RETURN ...
C
C        ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE,
C     WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT.
C     P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN
C     X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE.
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C     REVISED ... DEC 1991
C-------------------------
      REAL J, L, ACC0(3), BIG(3), E0(3), X0(3), WK(20)
      REAL A0(4), A1(4), A2(2), A3(2), A4(2), A5(2), A6(2), A7(2),
     *     A8(2)
      REAL B0(6), B1(4), B2(5), B3(5), B4(4), B5(3), B6(2), B7(2)
      REAL D0(6), D1(4), D2(2), D3(2), D4(1), D5(1), D6(1)
C-------------------------
      DATA ACC0(1)/5.E-15/, ACC0(2)/5.E-7/, ACC0(3)/5.E-4/
      DATA BIG(1)/25.0/, BIG(2)/14.0/, BIG(3)/10.0/
      DATA E0(1)/.25E-3/, E0(2)/.25E-1/, E0(3)/.14/
      DATA X0(1)/31.0/, X0(2)/17.0/, X0(3)/9.7/
C-------------------------
C     ALOG10 = LN(10)
C     RT2PIN = 1/SQRT(2*PI)
C     RTPI   = SQRT(PI)
C-------------------------
      DATA ALOG10/2.30258509299405/
      DATA RT2PIN/.398942280401433/
      DATA RTPI  /1.77245385090552/
C-------------------------
C
C             COEFFICIENTS FOR MINIMAX APPROXIMATIONS
C                          FOR C0,...,C8
C
C-------------------------
      DATA A0(1) /-.231272501940775E-02/, A0(2)/-.335378520024220E-01/,
     *     A0(3) /-.159840143443990E+00/, A0(4)/-.333333333333333E+00/
      DATA B0(1)  /.633763414209504E-06/, B0(2)/-.939001940478355E-05/,
     *     B0(3)  /.239521354917408E-02/, B0(4)/ .376245718289389E-01/,
     *     B0(5)  /.238549219145773E+00/, B0(6)/ .729520430331981E+00/
C-------------------------
      DATA A1(1) /-.398783924370770E-05/, A1(2)/-.587926036018402E-03/,
     *     A1(3) /-.491687131726920E-02/, A1(4)/-.185185185184291E-02/
      DATA B1(1)  /.386325038602125E-02/, B1(2) /.506042559238939E-01/,
     *     B1(3)  /.283344278023803E+00/, B1(4) /.780110511677243E+00/
C-------------------------
      DATA A2(1)  /.669564126155663E-03/, A2(2) /.413359788442192E-02/
      DATA B2(1) /-.421924263980656E-03/, B2(2) /.650837693041777E-02/,
     *     B2(3) / .682034997401259E-01/, B2(4) /.339173452092224E+00/,
     *     B2(5) / .810647620703045E+00/
C-------------------------
      DATA A3(1)  /.810586158563431E-03/, A3(2) /.649434157619770E-03/
      DATA B3(1) /-.632276587352120E-03/, B3(2) /.905375887385478E-02/,
     *     B3(3) / .906610359762969E-01/, B3(4) /.406288930253881E+00/,
     *     B3(5) / .894800593794972E+00/
C-------------------------
      DATA A4(1) /-.105014537920131E-03/, A4(2)/-.861888301199388E-03/
      DATA B4(1)  /.322609381345173E-01/, B4(2) /.178295773562970E+00/,
     *     B4(3)  /.591353097931237E+00/, B4(4) /.103151890792185E+01/
C-------------------------
      DATA A5(1) /-.435211415445014E-03/, A5(2)/-.336806989710598E-03/
      DATA B5(1)  /.178716720452422E+00/, B5(2) /.600380376956324E+00/,
     *     B5(3)  /.108515217314415E+01/
C-------------------------
      DATA A6(1) /-.182503596367782E-03/, A6(2) /.531279816209452E-03/
      DATA B6(1)  /.345608222411837E+00/, B6(2) /.770341682526774E+00/
C-------------------------
      DATA A7(1)  /.443219646726422E-03/, A7(2) /.344430064306926E-03/
      DATA B7(1)  /.821824741357866E+00/, B7(2) /.115029088777769E+01/
C-------------------------
      DATA A8(1)  /.878371203603888E-03/, A8(2)/-.686013280418038E-03/
C-------------------------
C
C              COEFFICIENTS FOR THE TEMME EXPANSION
C
C-------------------------
      DATA D00   /-.333333333333333E+00/, D0(1) / .833333333333333E-01/,
     *     D0(2) /-.148148148148148E-01/, D0(3) / .115740740740741E-02/,
     *     D0(4) / .352733686067019E-03/, D0(5) /-.178755144032922E-03/,
     *     D0(6) / .391926317852244E-04/
C-------------------------
      DATA D10   /-.185185185185185E-02/, D1(1) /-.347222222222222E-02/,
     *     D1(2) / .264550264550265E-02/, D1(3) /-.990226337448560E-03/,
     *     D1(4) / .205761316872428E-03/
C-------------------------
      DATA D20   / .413359788359788E-02/, D2(1) /-.268132716049383E-02/,
     *     D2(2) / .771604938271605E-03/
C-------------------------
      DATA D30   / .649434156378601E-03/, D3(1) / .229472093621399E-03/,
     *     D3(2) /-.469189494395256E-03/
C-------------------------
      DATA D40   /-.861888290916712E-03/, D4(1) / .784039221720067E-03/
C-------------------------
      DATA D50   /-.336798553366358E-03/, D5(1) /-.697281375836586E-04/
C-------------------------
      DATA D60   / .531307936463992E-03/, D6(1) /-.592166437353694E-03/
C-------------------------
      DATA D70   / .344367606892378E-03/
C-------------------------
      DATA D80   /-.652623918595309E-03/
C-------------------------
C
C     ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST
C            FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 .
C
                    E = SPMPAR(1)
C
C-------------------------
      IF (A .LT. 0.0 .OR. X .LT. 0.0) GO TO 400
      IF (A .EQ. 0.0 .AND. X .EQ. 0.0) GO TO 400
      IF (A*X .EQ. 0.0) GO TO 331
C
      IOP = IND + 1
      IF (IOP .NE. 1 .AND. IOP .NE. 2) IOP = 3
      ACC = AMAX1(ACC0(IOP),E)
C
C            SELECT THE APPROPRIATE ALGORITHM
C
      IF (A .GE. 1.0) GO TO 10
      IF (A .EQ. 0.5) GO TO 320
      IF (X .LT. 1.1) GO TO 110
      R = RCOMP(A,X)
      IF (R .EQ. 0.0) GO TO 310
      GO TO 170
C
   10 IF (A .GE. BIG(IOP)) GO TO 20
      IF (A .GT. X .OR. X .GE. X0(IOP)) GO TO 30
      TWOA = A + A
      M = INT(TWOA)
      IF (TWOA .NE. FLOAT(M)) GO TO 30
      I = M/2
      IF (A .EQ. FLOAT(I)) GO TO 140
      GO TO 150
C
   20 L = X/A
      IF (L .EQ. 0.0) GO TO 300
      S = 0.5 + (0.5 - L)
      Z = RLOG(L)
      IF (Z .GE. 700.0/A) GO TO 330
      Y = A*Z
      RTA = SQRT(A)
      IF (ABS(S) .LE. E0(IOP)/RTA) GO TO 250
      IF (ABS(S) .LE. 0.4) GO TO 200
C
   30 R = RCOMP(A,X)
      IF (R .EQ. 0.0) GO TO 331
      IF (X .LE. AMAX1(A,ALOG10)) GO TO 50
      IF (X .LT. X0(IOP)) GO TO 170
      GO TO 80
C
C                 TAYLOR SERIES FOR P/R
C
   50 APN = A + 1.0
      T = X/APN
      WK(1) = T
      DO 51 N = 2,20
         APN = APN + 1.0
         T = T*(X/APN)
         IF (T .LE. 1.E-3) GO TO 60
         WK(N) = T
   51 CONTINUE
      N = 20
C
   60 SUM = T
      TOL = 0.5*ACC
   61    APN = APN + 1.0
         T = T*(X/APN)
         SUM = SUM + T
         IF (T .GT. TOL) GO TO 61
C
      MAX = N - 1
      DO 70 M = 1,MAX
         N = N - 1
         SUM = SUM + WK(N)
   70 CONTINUE
      ANS = (R/A)*(1.0 + SUM)
      QANS = 0.5 + (0.5 - ANS)
      RETURN
C
C                 ASYMPTOTIC EXPANSION
C
   80 AMN = A - 1.0
      T = AMN/X
      WK(1) = T
      DO 81 N = 2,20
         AMN = AMN - 1.0
         T = T*(AMN/X)
         IF (ABS(T) .LE. 1.E-3) GO TO 90
         WK(N) = T
   81 CONTINUE
      N = 20
C
   90 SUM = T
   91 IF (ABS(T) .LT. ACC) GO TO 100
      AMN = AMN - 1.0
      T = T*(AMN/X)
      SUM = SUM + T
      GO TO 91
C
  100 MAX = N - 1
      DO 101 M = 1,MAX
         N = N - 1
         SUM = SUM + WK(N)
  101 CONTINUE
      QANS = (R/X)*(1.0 + SUM)
      ANS = 0.5 + (0.5 - QANS)
      RETURN
C
C             TAYLOR SERIES FOR P(A,X)/X**A
C
  110 L = 3.0
      C = X
      SUM = X/(A + 3.0)
      TOL = 3.0*ACC/(A + 1.0)
  111    L = L + 1.0
         C = -C*(X/L)
         T = C/(A + L)
         SUM = SUM + T
         IF (ABS(T) .GT. TOL) GO TO 111
      J = A*X*((SUM/6.0 - 0.5/(A + 2.0))*X + 1.0/(A + 1.0))
C
      Z = A*ALOG(X)
      H = GAM1(A)
      G = 1.0 + H
      IF (X .LT. 0.25) GO TO 120
         IF (A .LT. X/2.59) GO TO 135
         GO TO 130
  120 IF (Z .GT. -.13394) GO TO 135
C
  130 W = EXP(Z)
      ANS = W*G*(0.5 + (0.5 - J))
      QANS = 0.5 + (0.5 - ANS)
      RETURN
C
  135 L = REXP(Z)
      W = 0.5 + (0.5 + L)
      QANS = (W*J - L)*G - H
      IF (QANS .LT. 0.0) GO TO 310
      ANS = 0.5 + (0.5 - QANS)
      RETURN
C
C             FINITE SUMS FOR Q WHEN A .GE. 1
C                 AND 2*A IS AN INTEGER
C
  140 SUM = EXP(-X)
      T = SUM
      N = 1
      C = 0.0
      GO TO 160
C
  150 RTX = SQRT(X)
      SUM = ERFC1(0,RTX)
      T = EXP(-X)/(RTPI*RTX)
      N = 0
      C = -0.5
C
  160 IF (N .EQ. I) GO TO 161
         N = N + 1
         C = C + 1.0
         T = (X*T)/C
         SUM = SUM + T
         GO TO 160
  161 QANS = SUM
      ANS = 0.5 + (0.5 - QANS)
      RETURN
C
C              CONTINUED FRACTION EXPANSION
C
  170 TOL = AMAX1(8.0*E,4.0*ACC)
      A2NM1 = 1.0
      A2N = 1.0
      B2NM1 = X
      B2N = X + (1.0 - A)
      C = 1.0
  180    A2NM1 = X*A2N + C*A2NM1
         B2NM1 = X*B2N + C*B2NM1
         C = C + 1.0
         T = C - A
         A2N = A2NM1 + T*A2N
         B2N = B2NM1 + T*B2N
C
         A2NM1 = A2NM1/B2N
         B2NM1 = B2NM1/B2N
         A2N = A2N/B2N
         B2N = 1.0
         IF (ABS(A2N - A2NM1/B2NM1) .GE. TOL*A2N) GO TO 180
C
      QANS = R*A2N
      ANS = 0.5 + (0.5 - QANS)
      RETURN
C
  200 IF (ABS(S) .LE. 2.0*E .AND. A*E*E .GT. 3.28E-3) GO TO 400
      C = EXP(-Y)
      W = 0.5*ERFC1(1,SQRT(Y))
      U = 1.0/A
      Z = SQRT(Z + Z)
      IF (L .LT. 1.0) Z = -Z
      IF (IOP - 2) 210,220,230
C
  210 IF (ABS(S) .LE. 1.E-3) GO TO 260
C
C            USING THE MINIMAX APPROXIMATIONS
C
      C0 = (((A0(1)*Z + A0(2))*Z + A0(3))*Z + A0(4)) / ((((((B0(1)*Z +
     *       B0(2))*Z + B0(3))*Z + B0(4))*Z + B0(5))*Z + B0(6))*Z + 1.0)
      C1 = (((A1(1)*Z + A1(2))*Z + A1(3))*Z + A1(4)) /
     *     ((((B1(1)*Z + B1(2))*Z + B1(3))*Z + B1(4))*Z + 1.0)
      C2 = (A2(1)*Z + A2(2))/(((((B2(1)*Z + B2(2))*Z + B2(3))*Z +
     *     B2(4))*Z + B2(5))*Z + 1.0)
      C3 = (A3(1)*Z + A3(2))/(((((B3(1)*Z + B3(2))*Z + B3(3))*Z +
     *     B3(4))*Z + B3(5))*Z + 1.0)
      C4 = (A4(1)*Z + A4(2))/((((B4(1)*Z + B4(2))*Z + B4(3))*Z +
     *     B4(4))*Z + 1.0)
      C5 = (A5(1)*Z + A5(2))/(((B5(1)*Z + B5(2))*Z + B5(3))*Z + 1.0)
      C6 = (A6(1)*Z + A6(2))/((B6(1)*Z + B6(2))*Z + 1.0)
      C7 = (A7(1)*Z + A7(2))/((B7(1)*Z + B7(2))*Z + 1.0)
      C8 = A8(1)*Z + A8(2)
      T = (((((((C8*U + C7)*U + C6)*U + C5)*U + C4)*U + C3)*U +
     *                  C2)*U + C1)*U + C0
      GO TO 240
C
C                    TEMME EXPANSION
C
  220 C0 = (((((D0(6) * Z + D0(5)) * Z + D0(4)) * Z + D0(3)) * Z
     *     + D0(2)) * Z + D0(1)) * Z + D00
      C1 = (((D1(4) * Z + D1(3)) * Z + D1(2)) * Z + D1(1)) * Z
     *     + D10
      C2 = D2(1) * Z + D20
      T  = (C2*U + C1)*U + C0
      GO TO 240
C
  230 T  = ((D0(3) * Z + D0(2)) * Z + D0(1)) * Z + D00
C
  240 IF (L .LT. 1.0) GO TO 241
         QANS = C*(W + RT2PIN*T/RTA)
         ANS = 0.5 + (0.5 - QANS)
         RETURN
  241 ANS = C*(W - RT2PIN*T/RTA)
      QANS = 0.5 + (0.5 - ANS)
      RETURN
C
C               TEMME EXPANSION FOR L = 1
C
  250 IF (A*E*E .GT. 3.28E-3) GO TO 400
      C = 0.5 + (0.5 - Y)
      W = (0.5 - SQRT(Y)*(0.5 + (0.5 - Y/3.0))/RTPI)/C
      U = 1.0/A
      Z = SQRT(Z + Z)
      IF (L .LT. 1.0) Z = -Z
      IF (IOP - 2) 260,270,280
C
  260 C0 = ((D0(3) * Z + D0(2)) * Z + D0(1)) * Z + D00
      C1 = ((D1(3) * Z + D1(2)) * Z + D1(1)) * Z + D10
      C2 = (D2(2) * Z + D2(1)) * Z + D20
      C3 = (D3(2) * Z + D3(1)) * Z + D30
      C4 = D4(1) * Z + D40
      C5 = D5(1) * Z + D50
      C6 = D6(1) * Z + D60
      T  = (((((((D80*U + D70)*U + C6)*U + C5)*U + C4)*U + C3)*U
     *                  + C2)*U + C1)*U + C0
      GO TO 240
C
  270 C0 = (D0(2) * Z + D0(1)) * Z + D00
      C1 = D1(1) * Z + D10
      T  = (D20*U + C1)*U + C0
      GO TO 240
C
  280 T  = D0(1) * Z + D00
      GO TO 240
C
C                     SPECIAL CASES
C
  300 ANS = 0.0
      QANS = 1.0
      RETURN
C
  310 ANS = 1.0
      QANS = 0.0
      RETURN
C
  320 IF (X .GE. 0.25) GO TO 321
         ANS = ERF(SQRT(X))
         QANS = 0.5 + (0.5 - ANS)
         RETURN
  321 QANS = ERFC1(0,SQRT(X))
      ANS = 0.5 + (0.5 - QANS)
      RETURN
C
  330 IF (ABS(S) .LE. 2.0*E) GO TO 400
  331 IF (X .LE. A) GO TO 300
      GO TO 310
C
C                     ERROR RETURN
C
  400 ANS = 2.0
      RETURN
      END
      REAL FUNCTION RCOMP (A, X)
C-----------------------------------------------------------------------
C                EVALUATION OF EXP(-X)*X**A/GAMMA(A)
C-----------------------------------------------------------------------
C     RT2PIN = 1/SQRT(2*PI)
C------------------------
      DATA RT2PIN/.398942280401433/
C------------------------
      RCOMP = 0.0
      IF (X .EQ. 0.0) RETURN
      IF (A .GE. 20.0) GO TO 20
C
      T = A*ALOG(X) - X
      IF (T .LT. EXPARG(1)) RETURN
      IF (A .GE. 1.0) GO TO 10
         RCOMP = (A*EXP(T))*(1.0 + GAM1(A))
         RETURN
   10 RCOMP = EXP(T)/GAMMA(A)
      RETURN
C
   20 U = X/A
      IF (U .EQ. 0.0) RETURN
      T = (1.0/A)**2
      T1 = (((0.75*T - 1.0)*T + 3.5)*T - 105.0)/(A*1260.0)
      T1 = T1 - A*RLOG(U)
      IF (T1 .GE. EXPARG(1)) RCOMP = RT2PIN*SQRT(A)*EXP(T1)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DRCOMP (A, X)
C-----------------------------------------------------------------------
C              EVALUATION OF EXP(-X)*X**A/GAMMA(A)
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, X, C, T, W
      DOUBLE PRECISION DGAMMA, DGAM1, DPDEL, DRLOG, DXPARG
C--------------------------
C     C = 1/SQRT(2*PI)
C--------------------------
      DATA C /.398942280401432677939946059934D0/
C--------------------------
      DRCOMP = 0.D0
      IF (X .EQ. 0.D0) RETURN
      IF (A .GT. 20.D0) GO TO 20
C
      T = A*DLOG(X) - X
      IF (T .LT. DXPARG(1)) RETURN
      IF (A .GE. 1.D0) GO TO 10
         DRCOMP = (A*DEXP(T))*(1.D0 + DGAM1(A))
         RETURN
   10 DRCOMP = DEXP(T)/DGAMMA(A)
      RETURN
C
   20 T = X/A
      IF (T .EQ. 0.D0) RETURN
      W = -(DPDEL(A) + A*DRLOG(T))
      IF (W .GE. DXPARG(1)) DRCOMP = C * DSQRT(A) * DEXP(W)
      RETURN
      END
      SUBROUTINE GAMINV (A, X, X0, P, Q, IERR)
C-----------------------------------------------------------------------
C
C             INVERSE INCOMPLETE GAMMA RATIO FUNCTION
C
C     GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1.
C     THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER
C     ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X
C     TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE
C     PARTICULAR COMPUTER ARITHMETIC BEING USED.
C
C                        ------------
C
C     X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0,
C     AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT
C     NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN
C     A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE
C     IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X.
C
C     X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER
C     DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET
C     X0 .LE. 0.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C     WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING
C     VALUES ...
C
C       IERR =  0    THE SOLUTION WAS OBTAINED. ITERATION WAS
C                    NOT USED.
C       IERR.GT.0    THE SOLUTION WAS OBTAINED. IERR ITERATIONS
C                    WERE PERFORMED.
C       IERR = -2    (INPUT ERROR) A .LE. 0
C       IERR = -3    NO SOLUTION WAS OBTAINED. THE RATIO Q/A
C                    IS TOO LARGE.
C       IERR = -4    (INPUT ERROR) P OR Q IS NEGATIVE, OR
C                    P + Q .NE. 1.
C       IERR = -6    20 ITERATIONS WERE PERFORMED. THE MOST
C                    RECENT VALUE OBTAINED FOR X IS GIVEN.
C                    THIS CANNOT OCCUR IF X0 .LE. 0.
C       IERR = -7    ITERATION FAILED. NO VALUE IS GIVEN FOR X.
C                    THIS MAY OCCUR WHEN X IS APPROXIMATELY 0.
C       IERR = -8    A VALUE FOR X HAS BEEN OBTAINED, BUT THE
C                    ROUTINE IS NOT CERTAIN OF ITS ACCURACY.
C                    ITERATION CANNOT BE PERFORMED IN THIS
C                    CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY
C                    WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS
C                    POSITIVE THEN THIS CAN OCCUR WHEN A IS
C                    EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY
C                    LARGE (SAY A .GE. 1.E20).
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C     REVISED ... JANUARY 1992
C------------------------
      REAL LN10, BMIN(2), EMIN(2)
C------------------------
C     LN10 = LN(10)
C     C = EULER CONSTANT
C------------------------
      DATA LN10 /2.302585/
      DATA C  /.577215664901533/
C------------------------
      DATA BMIN(1) /1.E-28/, BMIN(2) /1.E-13/
      DATA EMIN(1) /2.E-03/, EMIN(2) /6.E-03/
C------------------------
      DATA TOL /1.E-5/
C------------------------
C
C     ****** E AND XMIN ARE MACHINE DEPENDENT CONSTANTS. E IS THE
C            SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0, AND XMIN
C            IS THE SMALLEST POSITIVE NUMBER.
C
                   E = SPMPAR(1)
                   XMIN = SPMPAR(2)
C
C------------------------
      X = 0.0
      IF (A .LE. 0.0) GO TO 500
      IF (P .LT. 0.0 .OR. Q .LT. 0.0) GO TO 520
      T = ((P + Q) - 0.5) - 0.5
      IF (ABS(T) .GT. 5.0*AMAX1(E,1.E-15)) GO TO 520
C
      IERR = 0
      XMIN = XMIN/E
      IF ((P/E) .LE. XMIN) GO TO 400
      IF ((Q/E) .LE. XMIN) GO TO 560
      IF (A .EQ. 1.0) GO TO 410
C
      E2 = E + E
      AMAX = 0.4E-10/(E*E)
      EPS = AMAX1(100.0*E,1.E-10)
      IOP = 1
      IF (E .GT. 1.E-10) IOP = 2
      XN = X0
      IF (X0 .GT. 0.0) GO TO 100
C
C        SELECTION OF THE INITIAL APPROXIMATION XN OF X
C                       WHEN A .LT. 1
C
      IF (A .GT. 1.0) GO TO 50
      G = GAMMA(A + 1.0)
      QG = Q*G
      IF (QG .EQ. 0.0) GO TO 560
      B = QG/A
      IF (QG .GT. 0.6*A) GO TO 20
      IF (A .GE. 0.30 .OR. B .LT. 0.35) GO TO 10
         T = EXP(-(B + C))
         U = T*EXP(T)
         XN = T*EXP(U)
         GO TO 100
C
   10 IF (B .GE. 0.45) GO TO 20
      IF (B .EQ. 0.0) GO TO 560
      Y = -ALOG(B)
      S = 0.5 + (0.5 - A)
      Z = ALOG(Y)
      T = Y - S*Z
      IF (B .LT. 0.15) GO TO 11
         XN = Y - S*ALOG(T) - ALOG(1.0 + S/(T + 1.0))
         GO TO 200
   11 IF (B .LE. 1.E-2) GO TO 12
         U = ((T + 2.0*(3.0 - A))*T + (2.0 - A)*(3.0 - A))/
     *           ((T + (5.0 - A))*T + 2.0)
         XN = Y - S*ALOG(T) - ALOG(U)
         GO TO 200
   12 C1 = -S*Z
      C2 = -S*(1.0 + C1)
      C3 =  S*((0.5*C1 + (2.0 - A))*C1 + (2.5 - 1.5*A))
      C4 = -S*(((C1/3.0 + (2.5 - 1.5*A))*C1 + ((A - 6.0)*A + 7.0))*C1
     *           + ((11.0*A - 46.0)*A + 47.0)/6.0)
      C5 = -S*((((-C1/4.0 + (11.0*A - 17.0)/6.0)*C1
     *           + ((-3.0*A + 13.0)*A - 13.0))*C1
     *           + 0.5*(((2.0*A - 25.0)*A + 72.0)*A - 61.0))*C1
     *           + (((25.0*A - 195.0)*A + 477.0)*A - 379.0)/12.0)
      XN = ((((C5/Y + C4)/Y + C3)/Y + C2)/Y + C1) + Y
      IF (A .GT. 1.0) GO TO 200
      IF (B .GT. BMIN(IOP)) GO TO 200
      X = XN
      RETURN
C
   20 IF (B*Q .GT. 1.E-8) GO TO 21
         XN = EXP(-(Q/A + C))
         GO TO 30
   21 IF (P .LE. 0.9) GO TO 22
         XN = EXP((ALNREL(-Q) + GAMLN1(A))/A)
         GO TO 30
   22 XN = EXP(ALOG(P*G)/A)
C
   30 IF (XN .EQ. 0.0) GO TO 510
      T = 0.5 + (0.5 - XN/(A + 1.0))
      XN = XN/T
      GO TO 100
C
C        SELECTION OF THE INITIAL APPROXIMATION XN OF X
C                       WHEN A .GT. 1
C
   50 T = P - 0.5
      IF (Q .LT. 0.5) T = 0.5 - Q
      CALL PNI (P, Q, T, S, IER)
C
      RTA = SQRT(A)
      S2 = S*S
      XN = (((12.0*S2 - 243.0)*S2 - 923.0)*S2 + 1472.0)/204120.0
      XN = (XN/A + S*((9.0*S2 + 256.0)*S2 - 433.0)/(38880.0*RTA))
     *           - ((3.0*S2 + 7.0)*S2 - 16.0)/810.0
      XN = A + S*RTA + (S2 - 1.0)/3.0 + S*(S2 - 7.0)/(36.0*RTA)
     *       + XN/A
      XN = AMAX1(XN, 0.0)
C
      AMIN = 20.0
      IF (E .LT. 1.E-8) AMIN = 250.0
      IF (A .LT. AMIN) GO TO 60
         X = XN
         D = 0.5 + (0.5 - X/A)
         IF (ABS(D) .LE. 1.E-1) RETURN
C
   60 IF (P .LE. 0.5) GO TO 70
      IF (XN .LT. 3.0*A) GO TO 200
      W = ALOG(Q)
      Y = -(W + GAMLN(A))
      D = AMAX1(2.0, A*(A - 1.0))
      IF (Y .LT. LN10*D) GO TO 61
         S = 1.0 - A
         Z = ALOG(Y)
         GO TO 12
   61 T = A - 1.0
      XN = Y + T*ALOG(XN) - ALNREL(-T/(XN + 1.0))
      XN = Y + T*ALOG(XN) - ALNREL(-T/(XN + 1.0))
      GO TO 200
C
   70 AP1 = A + 1.0
      IF (XN .GT. 0.70*AP1) GO TO 101
      W = ALOG(P) + GAMLN(AP1)
      IF (XN .GT. 0.15*AP1) GO TO 80
         AP2 = A + 2.0
         AP3 = A + 3.0
         X = EXP((W + X)/A)
         X = EXP((W + X - ALOG(1.0 + (X/AP1)*(1.0 + X/AP2)))/A)
         X = EXP((W + X - ALOG(1.0 + (X/AP1)*(1.0 + X/AP2)))/A)
         X = EXP((W + X - ALOG(1.0 + (X/AP1)*(1.0 + (X/AP2)*(1.0
     *                      + X/AP3))))/A)
         XN = X
         IF (XN .GT. 1.E-2*AP1) GO TO 80
         IF (XN .LE. EMIN(IOP)*AP1) RETURN
         GO TO 101
C
   80 APN = AP1
      T = XN/APN
      SUM = 1.0 + T
   81    APN = APN + 1.0
         T = T*(XN/APN)
         SUM = SUM + T
         IF (T .GT. 1.E-4) GO TO 81
      T = W - ALOG(SUM)
      XN = EXP((XN + T)/A)
      XN = XN*(1.0 - (A*ALOG(XN) - XN - T)/(A - XN))
      GO TO 101
C
C                 SCHRODER ITERATION USING P
C
  100 IF (P .GT. 0.5) GO TO 200
  101 IF (P .LE. XMIN) GO TO 550
      AM1 = (A - 0.5) - 0.5
  102 IF (A .LE. AMAX) GO TO 110
      D = 0.5 + (0.5 - XN/A)
      IF (ABS(D) .LE. E2) GO TO 550
C
  110 IF (IERR .GE. 20) GO TO 530
      IERR = IERR + 1
      CALL GRATIO (A, XN, PN, QN, 0)
      IF (PN .EQ. 0.0 .OR. QN .EQ. 0.0) GO TO 550
      R = RCOMP(A,XN)
      IF (R .LT. XMIN) GO TO 550
      T = (PN - P)/R
      W = 0.5*(AM1 - XN)
      IF (ABS(T) .LE. 0.1 .AND. ABS(W*T) .LE. 0.1) GO TO 120
         X = XN*(1.0 - T)
         IF (X .LE. 0.0) GO TO 540
         D = ABS(T)
         GO TO 121
C
  120 H = T*(1.0 + W*T)
      X = XN*(1.0 - H)
      IF (X .LE. 0.0) GO TO 540
      IF (ABS(W) .GE. 1.0 .AND. ABS(W)*T*T .LE. EPS) RETURN
      D = ABS(H)
  121 XN = X
      IF (D .GT. TOL) GO TO 102
      IF (D .LE. EPS) RETURN
      IF (ABS(P - PN) .LE. TOL*P) RETURN
      GO TO 102
C
C                 SCHRODER ITERATION USING Q
C
  200 IF (Q .LE. XMIN) GO TO 550
      AM1 = (A - 0.5) - 0.5
  201 IF (A .LE. AMAX) GO TO 210
      D = 0.5 + (0.5 - XN/A)
      IF (ABS(D) .LE. E2) GO TO 550
C
  210 IF (IERR .GE. 20) GO TO 530
      IERR = IERR + 1
      CALL GRATIO (A, XN, PN, QN, 0)
      IF (PN .EQ. 0.0 .OR. QN .EQ. 0.0) GO TO 550
      R = RCOMP(A,XN)
      IF (R .LT. XMIN) GO TO 550
      T = (Q - QN)/R
      W = 0.5*(AM1 - XN)
      IF (ABS(T) .LE. 0.1 .AND. ABS(W*T) .LE. 0.1) GO TO 220
         X = XN*(1.0 - T)
         IF (X .LE. 0.0) GO TO 540
         D = ABS(T)
         GO TO 221
C
  220 H = T*(1.0 + W*T)
      X = XN*(1.0 - H)
      IF (X .LE. 0.0) GO TO 540
      IF (ABS(W) .GE. 1.0 .AND. ABS(W)*T*T .LE. EPS) RETURN
      D = ABS(H)
  221 XN = X
      IF (D .GT. TOL) GO TO 201
      IF (D .LE. EPS) RETURN
      IF (ABS(Q - QN) .LE. TOL*Q) RETURN
      GO TO 201
C
C                       SPECIAL CASES
C
  400 IERR = -8
      RETURN
C
  410 IF (Q .LT. 0.9) GO TO 411
         X = -ALNREL(-P)
         RETURN
  411 X = -ALOG(Q)
      RETURN
C
C                       ERROR RETURN
C
  500 IERR = -2
      RETURN
C
  510 IERR = -3
      RETURN
C
  520 IERR = -4
      RETURN
C
  530 IERR = -6
      RETURN
C
  540 IERR = -7
      RETURN
C
  550 X = XN
      IERR = -8
      RETURN
C
  560 X = SPMPAR(3)
      IERR = -8
      RETURN
      END
      SUBROUTINE DGRAT (A, X, ANS, QANS, IERR)
C-----------------------------------------------------------------------
C
C        EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS
C                      P(A,X) AND Q(A,X)
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C     REVISED ... JAN 1992
C-------------------------
      DOUBLE PRECISION A, X, ANS, QANS
      DOUBLE PRECISION AMN, ALOG10, APN, A2N, A2NM1, BIG, B2N,
     *         B2NM1, C, E, G, H, J, L, R, RTA, RTPI, RTX, S,
     *         SUM, T, TOL, TWOA, U, X0, Y, Z, WK(20)
      DOUBLE PRECISION DPMPAR, DRLOG, DREXP
      DOUBLE PRECISION DERF, DERFC1, DGAM1, DRCOMP
C-------------------------
C     ALOG10 = LN(10)
C     RTPI   = DSQRT(PI)
C-------------------------
      DATA ALOG10 /2.30258509299404568401799145468D0/
      DATA RTPI   /1.77245385090551602729816748334D0/
C-------------------------
C
C     ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST
C            FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 .
C
                    E = DPMPAR(1)
C
C-------------------------
      IF (A .LT. 0.D0 .OR. X .LT. 0.D0) GO TO 400
      IF (A .EQ. 0.D0 .AND. X .EQ. 0.D0) GO TO 410
      IERR = 0
      IF (A*X .EQ. 0.D0) GO TO 331
C
      E = DMAX1(E,1.D-30)
      BIG = 30.D0
      IF (E .LT. 1.D-17) BIG = 50.D0
      X0 = 45.D0
      IF (E .LT. 1.D-17) X0 = 68.D0
C
C            SELECT THE APPROPRIATE ALGORITHM
C
      IF (A .GE. 1.D0) GO TO 10
      IF (A .EQ. 0.5D0) GO TO 320
      IF (X .LE. 2.D0) GO TO 110
      R = DRCOMP(A,X)
      IF (R .EQ. 0.D0) GO TO 310
      GO TO 170
C
   10 IF (A .GE. BIG) GO TO 20
      IF (A .GT. X .OR. X .GE. X0) GO TO 30
      TWOA = A + A
      M = TWOA
      L = M
      IF (TWOA .NE. L) GO TO 30
      I = M/2
      L = I
      IF (A .EQ. L) GO TO 140
      GO TO 150
C
   20 L = X/A
      IF (L .EQ. 0.D0) GO TO 300
      S = 0.5D0 + (0.5D0 - L)
      Z = DRLOG(L)
      IF (Z .GE. 700.D0/A) GO TO 330
      Y = A*Z
      RTA = DSQRT(A)
      IF (DABS(S) .LE. 0.4D0) GO TO 200
C
   30 R = DRCOMP(A,X)
      IF (R .EQ. 0.D0) GO TO 331
      IF (X .LE. DMAX1(A,ALOG10)) GO TO 50
      IF (X .LT. X0) GO TO 170
      GO TO 80
C
C                 TAYLOR SERIES FOR P/R
C
   50 APN = A + 1.D0
      T = X/APN
      WK(1) = T
      DO 51 N = 2,20
         APN = APN + 1.D0
         T = T*(X/APN)
         IF (T .LT. 1.D-3) GO TO 60
         WK(N) = T
   51 CONTINUE
      N = 20
C
   60 SUM = T
      TOL = 0.5D0*E
   61    APN = APN + 1.D0
         T = T*(X/APN)
         SUM = SUM + T
         IF (T .GT. TOL) GO TO 61
C
      MAX = N - 1
      DO 70 M = 1,MAX
         N = N - 1
         SUM = SUM + WK(N)
   70 CONTINUE
      ANS = (R/A)*(1.D0 + SUM)
      QANS = 0.5D0 + (0.5D0 - ANS)
      RETURN
C
C                 ASYMPTOTIC EXPANSION
C
   80 AMN = A - 1.D0
      T = AMN/X
      WK(1) = T
      DO 81 N = 2,20
         AMN = AMN - 1.D0
         T = T*(AMN/X)
         IF (DABS(T) .LE. 1.D-3) GO TO 90
         WK(N) = T
   81 CONTINUE
      N = 20
C
   90 SUM = T
   91 IF (DABS(T) .LT. E) GO TO 100
      AMN = AMN - 1.D0
      T = T*(AMN/X)
      SUM = SUM + T
      GO TO 91
C
  100 MAX = N - 1
      DO 101 M = 1,MAX
         N = N - 1
         SUM = SUM + WK(N)
  101 CONTINUE
      QANS = (R/X)*(1.D0 + SUM)
      ANS = 0.5D0 + (0.5D0 - QANS)
      RETURN
C
C             TAYLOR SERIES FOR P(A,X)/X**A
C
  110 L = 3.D0
      C = X
      SUM = X/(A + 3.D0)
      TOL = 3.D0*E/(A + 1.D0)
  120    L = L + 1.D0
         C = -C*(X/L)
         T = C/(A + L)
         SUM = SUM + T
         IF (DABS(T) .GT. TOL) GO TO 120
      J = A*X*((SUM/6.D0 - 0.5D0/(A + 2.D0))*X + 1.D0/(A + 1.D0))
C
      Z = A*DLOG(X)
      U = DEXP(Z)
      H = DGAM1(A)
      G = 1.D0 + H
      ANS = U*G*(0.5D0 + (0.5D0 - J))
      QANS = 0.5D0 + (0.5D0 - ANS)
      IF (ANS .LE. 0.9D0) RETURN
C
      L = DREXP(Z)
      QANS = (U*J - L)*G - H
      IF (QANS .LE. 0.D0) GO TO 310
      ANS = 0.5D0 + (0.5D0 - QANS)
      RETURN
C
C             FINITE SUMS FOR Q WHEN A .GE. 1
C                 AND 2*A IS AN INTEGER
C
  140 SUM = DEXP(-X)
      T = SUM
      N = 1
      C = 0.D0
      GO TO 160
C
  150 RTX = DSQRT(X)
      SUM = DERFC1(0,RTX)
      T = DEXP(-X)/(RTPI*RTX)
      N = 0
      C = -0.5D0
C
  160 IF (N .EQ. I) GO TO 161
         N = N + 1
         C = C + 1.D0
         T = (X*T)/C
         SUM = SUM + T
         GO TO 160
  161 QANS = SUM
      ANS = 0.5D0 + (0.5D0 - QANS)
      RETURN
C
C              CONTINUED FRACTION EXPANSION
C
  170 TOL = 8.D0*E
      A2NM1 = 1.D0
      A2N = 1.D0
      B2NM1 = X
      B2N = X + (1.D0 - A)
      C = 1.D0
  180    A2NM1 = X*A2N + C*A2NM1
         B2NM1 = X*B2N + C*B2NM1
         C = C + 1.D0
         T = C - A
         A2N = A2NM1 + T*A2N
         B2N = B2NM1 + T*B2N
C
         A2NM1 = A2NM1/B2N
         B2NM1 = B2NM1/B2N
         A2N = A2N/B2N
         B2N = 1.D0
         IF (DABS(A2N - A2NM1/B2NM1) .GE. TOL*A2N) GO TO 180
C
      QANS = R*A2N
      ANS = 0.5D0 + (0.5D0 - QANS)
      RETURN
C
C                 MINIMAX APPROXIMATIONS
C
  200 IF (DABS(S) .LE. 2.D0*E .AND. A*E*E .GT. 3.28D-3) GO TO 420
      IF (E .LT. 1.D-17) GO TO 210
         CALL DGR17 (A, Y, L, Z, RTA, ANS, QANS)
         RETURN
  210 CALL DGR29 (A, Y, L, Z, RTA, ANS, QANS)
      RETURN
C
C                     SPECIAL CASES
C
  300 ANS = 0.D0
      QANS = 1.D0
      RETURN
C
  310 ANS = 1.D0
      QANS = 0.D0
      RETURN
C
  320 IF (X .GE. 0.25D0) GO TO 321
         ANS = DERF(DSQRT(X))
         QANS = 0.5D0 + (0.5D0 - ANS)
         RETURN
  321 QANS = DERFC1(0,DSQRT(X))
      ANS = 0.5D0 + (0.5D0 - QANS)
      RETURN
C
  330 IF (DABS(S) .LE. 2.D0*E) GO TO 420
  331 IF (X .LE. A) GO TO 300
      GO TO 310
C
C                     ERROR RETURN
C
  400 IERR = 1
      ANS = 2.D0
      RETURN
C
  410 IERR = 2
      ANS = 2.D0
      RETURN
C
  420 IERR = 3
      ANS = 2.D0
      RETURN
      END
      SUBROUTINE DGR29 (A, Y, L, Z, RTA, ANS, QANS)
C-----------------------------------------------------------------------
C
C            ALGORITHM USING MINIMAX APPROXIMATIONS
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, Y, L, Z, RTA, ANS, QANS
      DOUBLE PRECISION A0(7), A1(7), A2(7), A3(7), A4(7), A5(7), A6(4),
     *                 A7(5), A8(5), A9(5), A10(4), A11(4), A12(4),
     *                 A13(3), A14(3), A15(2), A16(2), A17(1), A18(1)
      DOUBLE PRECISION B0(9), B1(9), B2(8), B3(8), B4(8), B5(7), B6(9),
     *                 B7(7), B8(7), B9(6), B10(6), B11(5), B12(4),
     *                 B13(4), B14(2), B15(2), B16(1)
      DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, C10,
     *                 C11, C12, C13, C14, C15, C16
      DOUBLE PRECISION D0(7), E, RT2PIN, T, U, W
      DOUBLE PRECISION DERFC1
C---------------------------
C     RT2PIN = 1/DSQRT(2*PI)
C---------------------------
      DATA RT2PIN /.398942280401432677939946059934D0/
C---------------------------
      DATA D0(1)  /-.333333333333333333333333333333D+00/,
     *     D0(2)  / .833333333333333333333333333333D-01/,
     *     D0(3)  /-.148148148148148148148148148148D-01/,
     *     D0(4)  / .115740740740740740740740740741D-02/,
     *     D0(5)  / .352733686067019400352733686067D-03/,
     *     D0(6)  /-.178755144032921810699588477366D-03/,
     *     D0(7)  / .391926317852243778169704095630D-04/
C---------------------------
      DATA A0(1) /-.234443848930188413698825870D-08/,
     *     A0(2) /-.408902435641223939887180303D-07/,
     *     A0(3) /-.327874000161065050049103731D-06/,
     *     A0(4) /-.145717031728609218851588740D-05/,
     *     A0(5) /-.372722892959910688597417881D-05/,
     *     A0(6) /-.490033281596113358850307112D-05/,
     *     A0(7) /-.218544851067999216147364227D-05/
      DATA B0(1) /-.129786815987713980865910767D-09/,
     *     B0(2)  /.319268409139858531586963150D-08/,
     *     B0(3)  /.597739416777031660496708557D-04/,
     *     B0(4)  /.131659965062389880196860991D-02/,
     *     B0(5)  /.138263099503103838517015533D-01/,
     *     B0(6)  /.866750030433403450681521877D-01/,
     *     B0(7)  /.349373447613102956696810725D+00/,
     *     B0(8)  /.902581259032419042347458484D+00/,
     *     B0(9)  /.139388806936391316154237713D+01/
C---------------------------
      DATA A1(1) /-.162671127226300802902860047D-05/,
     *     A1(2) /-.359791514993122440319624428D-04/,
     *     A1(3) /-.334816794629374699945489443D-03/,
     *     A1(4) /-.167787748352827199882047653D-02/,
     *     A1(5) /-.462960105006279850867332060D-02/,
     *     A1(6) /-.627269388216833251971110268D-02/,
     *     A1(7) /-.185185185185185185185185200D-02/
      DATA B1(1)  /.361538770500640888027927000D-09/,
     *     B1(2)  /.974094440943696092434381137D-05/,
     *     B1(3)  /.275463718595762102271929980D-03/,
     *     B1(4)  /.356903970692700621824901511D-02/,
     *     B1(5)  /.276755209895072417713430394D-01/,
     *     B1(6)  /.140741499324744724262767201D+00/,
     *     B1(7)  /.482173396010404307346794795D+00/,
     *     B1(8)  /.109307843990990308990473663D+01/,
     *     B1(9)  /.151225469637089956064399494D+01/
C---------------------------
      DATA A2(1)  /.100841467329617467204527243D-06/,
     *     A2(2)  /.261809837060522545971782889D-05/,
     *     A2(3)  /.351658023234640143803014403D-04/,
     *     A2(4)  /.287368655528567495658887760D-03/,
     *     A2(5)  /.138385867950361368914038461D-02/,
     *     A2(6)  /.365985331203490698463644329D-02/,
     *     A2(7)  /.413359788359788359788359644D-02/
      DATA B2(1)  /.144996224602847932479320241D-04/,
     *     B2(2)  /.378705615967233119938297206D-03/,
     *     B2(3)  /.457258679387716305283282667D-02/,
     *     B2(4)  /.333036784835643463383606186D-01/,
     *     B2(5)  /.160392471625881407829191009D+00/,
     *     B2(6)  /.524238095721639512312120765D+00/,
     *     B2(7)  /.114320896084982707537755002D+01/,
     *     B2(8)  /.153405837991415136438992306D+01/
C---------------------------
      DATA A3(1)  /.352304123782956092061364635D-06/,
     *     A3(2)  /.695396758348887902366951353D-05/,
     *     A3(3)  /.620467118988901865955998784D-04/,
     *     A3(4)  /.331552280167649130371474456D-03/,
     *     A3(5)  /.987931909328964685388525477D-03/,
     *     A3(6)  /.141844584435355290321010006D-02/,
     *     A3(7)  /.649434156378600823045102236D-03/
      DATA B3(1)  /.656342109234806261144233394D-04/,
     *     B3(2)  /.130398975231883219976260776D-02/,
     *     B3(3)  /.126418031281256648240652355D-01/,
     *     B3(4)  /.760733201461716525855765749D-01/,
     *     B3(5)  /.308149284260387354956024487D+00/,
     *     B3(6)  /.856743428738899911100227393D+00/,
     *     B3(7)  /.159678625605457556492814589D+01/,
     *     B3(8)  /.183078413578083710405050462D+01/
C---------------------------
      DATA A4(1) /-.260879135093022176005540138D-07/,
     *     A4(2) /-.470448694272734954500324169D-06/,
     *     A4(3) /-.487392507564453824976295590D-05/,
     *     A4(4) /-.337525643163070607393381432D-04/,
     *     A4(5) /-.173138093150706317400323103D-03/,
     *     A4(6) /-.619343030286408407629007048D-03/,
     *     A4(7) /-.861888290916711698604710684D-03/
      DATA B4(1)  /.561738585657138771286755470D-04/,
     *     B4(2)  /.104553622856827932853059322D-02/,
     *     B4(3)  /.990129468337836044520381371D-02/,
     *     B4(4)  /.590964360473404599955095091D-01/,
     *     B4(5)  /.241580582651643837306299024D+00/,
     *     B4(6)  /.686949677014349678482109368D+00/,
     *     B4(7)  /.133507902144433100426436242D+01/,
     *     B4(8)  /.162826466816694512158165085D+01/
C---------------------------
      DATA A5(1) /-.116166342948098688243985652D-07/,
     *     A5(2) / .506465072067030007394288471D-08/,
     *     A5(3) /-.556701576804390213081214801D-05/,
     *     A5(4) /-.332229941748769925615918550D-04/,
     *     A5(5) /-.171902547619915856635305717D-03/,
     *     A5(6) /-.548868487607991087508092013D-03/,
     *     A5(7) /-.336798553366358151161633777D-03/
      DATA B5(1)  /.106576106868815233442641444D-03/,
     *     B5(2)  /.280714123386276098548285440D-02/,
     *     B5(3)  /.254669201041872409738119341D-01/,
     *     B5(4)  /.136071713023783507468096673D+00/,
     *     B5(5)  /.462890328922621047510807887D+00/,
     *     B5(6)  /.103913867517817784825064299D+01/,
     *     B5(7)  /.142263185288429590449288300D+01/
C---------------------------
      DATA A6(1)  /.118384620224413424936260301D-04/,
     *     A6(2)  /.694345283181981060040314140D-05/,
     *     A6(3)  /.209213745619758030399432459D-03/,
     *     A6(4)  /.531307936463992224884286210D-03/
      DATA B6(1) /-.633002360430352916354621750D-05/,
     *     B6(2) /-.248639208901374031411609873D-04/,
     *     B6(3)  /.151734058829700925162000373D-03/,
     *     B6(4)  /.477475914272399601740818883D-02/,
     *     B6(5)  /.384410125775084107229541456D-01/,
     *     B6(6)  /.184699876959596092801262547D+00/,
     *     B6(7)  /.571784440733980642101712125D+00/,
     *     B6(8)  /.118432122801495778365352945D+01/,
     *     B6(9)  /.150831585220968267709550582D+01/
C---------------------------
      DATA A7(1)  /.972342656522493967167788395D-05/,
     *     A7(2)  /.462793722775687016808279009D-04/,
     *     A7(3)  /.208913588225005764102252127D-03/,
     *     A7(4)  /.605983804794748515383615779D-03/,
     *     A7(5)  /.344367606892381545765962366D-03/
      DATA B7(1)  /.215964480325937088444595990D-03/,
     *     B7(2)  /.621296161441756044580440529D-02/,
     *     B7(3)  /.497403555098433701440032746D-01/,
     *     B7(4)  /.230812334251394761909158355D+00/,
     *     B7(5)  /.682159830165959997577293001D+00/,
     *     B7(6)  /.133753662990343866552766613D+01/,
     *     B7(7)  /.160951809815647533045690195D+01/
C---------------------------
      DATA A8(1) /-.231069438570167401077137510D-05/,
     *     A8(2) /-.192877995065652524742879002D-04/,
     *     A8(3) /-.282551884312564905942488077D-04/,
     *     A8(4) /-.353272052089782073130912603D-03/,
     *     A8(5) /-.652623918595320914510590273D-03/
      DATA B8(1)  /.156052480203446255774109882D-02/,
     *     B8(2)  /.189231675289329563916597032D-01/,
     *     B8(3)  /.110127834209242088316741250D+00/,
     *     B8(4)  /.407929996207245634766606879D+00/,
     *     B8(5)  /.101702505946784412105505734D+01/,
     *     B8(6)  /.172269407630659768618234623D+01/,
     *     B8(7)  /.182765408802230546887514255D+01/
C---------------------------
      DATA A9(1) /-.203007139532451428594124139D-04/,
     *     A9(2) /-.120148495117517992204095691D-03/,
     *     A9(3) /-.377126645910917006921076652D-03/,
     *     A9(4) /-.109151697941931403194363814D-02/,
     *     A9(5) /-.596761290192642722092337263D-03/
      DATA B9(1)  /.108808775028021530146610124D-01/,
     *     B9(2)  /.803149717787956717154553908D-01/,
     *     B9(3)  /.335555306170768573903990019D+00/,
     *     B9(4)  /.881575022436158946373557744D+00/,
     *     B9(5)  /.156222230858412078350692234D+01/,
     *     B9(6)  /.170833470935668756293234818D+01/
C---------------------------
      DATA A10(1)/ .475862254251166503473724173D-04/,
     *     A10(2)/-.352503880413640910997936559D-04/,
     *     A10(3)/ .580375987713106460207815603D-03/,
     *     A10(4)/ .133244544950730832649306319D-02/
      DATA B10(1) /.161103572271541189817119144D-01/,
     *     B10(2) /.114651544043625219459951640D+00/,
     *     B10(3) /.448280675300097555552484502D+00/,
     *     B10(4) /.110810715319704031415255670D+01/,
     *     B10(5) /.183146436130501918547134176D+01/,
     *     B10(6) /.187235769169449339141968881D+01/
C---------------------------
      DATA A11(1) /.121185049262809526794966703D-03/,
     *     A11(2) /.717725173388339108430635016D-05/,
     *     A11(3) /.246371734409638623215800502D-02/,
     *     A11(4) /.157972766214718575927904484D-02/
      DATA B11(1) /.794610889405176143379963912D-02/,
     *     B11(2) /.131627017265860324219513170D+00/,
     *     B11(3) /.505939635317477779328000706D+00/,
     *     B11(4) /.116082103318559904744144217D+01/,
     *     B11(5) /.145670749780693850410866175D+01/
C---------------------------
      DATA A12(1)/-.246294151509758620837749269D-03/,
     *     A12(2)/ .650624975008642297405944869D-03/,
     *     A12(3)/-.214376520139497301154749750D-03/,
     *     A12(4)/-.407251199495291398243480255D-02/
      DATA B12(1) /.168390445944818504703640731D+00/,
     *     B12(2) /.653453590771198550320727688D+00/,
     *     B12(3) /.140298208333879535577602171D+01/,
     *     B12(4) /.162497775209192630951344224D+01/
C---------------------------
      DATA A13(1)/-.159520095187034545391135461D-02/,
     *     A13(2)/-.109727312966041723997078734D-01/,
     *     A13(3)/-.594758070915055362667114240D-02/
      DATA B13(1) /.207815761771742289849225339D+00/,
     *     B13(2) /.790935125477975506817064616D+00/,
     *     B13(3) /.158706682625067673596619095D+01/,
     *     B13(4) /.175409273929961597148916309D+01/
C---------------------------
      DATA A14(1)/ .245543970647383469794050102D-02/,
     *     A14(2)/-.119636668153843644820445054D-01/,
     *     A14(3)/ .175722793448246103440764372D-01/
      DATA B14(1) /.676925518749829493412063599D+00/,
     *     B14(2) /.100158659226079685399214158D+01/
C---------------------------
      DATA A15(1) /.588261033368548917447688791D-01/,
     *     A15(2) /.400765463491067514929787780D-01/
      DATA B15(1) /.124266359850901469771032599D+01/,
     *     B15(2) /.149189509890654955611528542D+01/
C---------------------------
      DATA A16(1)/ .119522261141925960204472459D+00/,
     *     A16(2)/-.100326700196947262548667584D+00/
      DATA B16(1) /.536462039767059451769400255D+00/
C---------------------------
      DATA A17(1)/-.259949826752497731336860753D+00/
C---------------------------
      DATA A18(1) /.724036968309299822373280436D+00/
C---------------------------
      E = DEXP(-Y)
      W = 0.5D0*DERFC1(1,DSQRT(Y))
      U = 1.D0/A
      Z = DSQRT(Z + Z)
      IF (L .LT. 1.D0) Z = -Z
C
      T = ((((((A0(1)*Z + A0(2))*Z + A0(3))*Z + A0(4))*Z + A0(5))*Z +
     *          A0(6))*Z + A0(7)) / (((((((((B0(1)*Z + B0(2))*Z +
     *          B0(3))*Z + B0(4))*Z + B0(5))*Z + B0(6))*Z + B0(7))*Z +
     *          B0(8))*Z + B0(9))*Z + 1.D0)
      C0 = ((((((T*Z + D0(7))*Z + D0(6))*Z + D0(5))*Z + D0(4))*Z +
     *                 D0(3))*Z + D0(2))*Z + D0(1)
      C1 = ((((((A1(1)*Z + A1(2))*Z + A1(3))*Z + A1(4))*Z + A1(5))*Z +
     *           A1(6))*Z + A1(7)) / (((((((((B1(1)*Z + B1(2))*Z +
     *           B1(3))*Z + B1(4))*Z + B1(5))*Z + B1(6))*Z + B1(7))*Z +
     *           B1(8))*Z + B1(9))*Z + 1.D0)
      C2 = ((((((A2(1)*Z + A2(2))*Z + A2(3))*Z + A2(4))*Z + A2(5))*Z +
     *           A2(6))*Z + A2(7)) / ((((((((B2(1)*Z + B2(2))*Z +
     *           B2(3))*Z + B2(4))*Z + B2(5))*Z + B2(6))*Z + B2(7))*Z +
     *           B2(8))*Z + 1.D0)
      C3 = ((((((A3(1)*Z + A3(2))*Z + A3(3))*Z + A3(4))*Z + A3(5))*Z +
     *           A3(6))*Z + A3(7)) / ((((((((B3(1)*Z + B3(2))*Z +
     *           B3(3))*Z + B3(4))*Z + B3(5))*Z + B3(6))*Z + B3(7))*Z +
     *           B3(8))*Z + 1.D0)
      C4 = ((((((A4(1)*Z + A4(2))*Z + A4(3))*Z + A4(4))*Z + A4(5))*Z +
     *           A4(6))*Z + A4(7)) / ((((((((B4(1)*Z + B4(2))*Z +
     *           B4(3))*Z + B4(4))*Z + B4(5))*Z + B4(6))*Z + B4(7))*Z +
     *           B4(8))*Z + 1.D0)
      C5 = ((((((A5(1)*Z + A5(2))*Z + A5(3))*Z + A5(4))*Z + A5(5))*Z +
     *           A5(6))*Z + A5(7)) / (((((((B5(1)*Z + B5(2))*Z +
     *           B5(3))*Z + B5(4))*Z + B5(5))*Z + B5(6))*Z + B5(7))*Z +
     *           1.D0)
      C6 = (((A6(1)*Z + A6(2))*Z + A6(3))*Z + A6(4)) /(((((((((B6(1)*Z +
     *           B6(2))*Z + B6(3))*Z + B6(4))*Z + B6(5))*Z + B6(6))*Z +
     *           B6(7))*Z + B6(8))*Z + B6(9))*Z + 1.D0)
      C7 = ((((A7(1)*Z + A7(2))*Z + A7(3))*Z + A7(4))*Z + A7(5)) /
     *     (((((((B7(1)*Z + B7(2))*Z + B7(3))*Z + B7(4))*Z + B7(5))*Z +
     *            B7(6))*Z + B7(7))*Z + 1.D0)
      C8 = ((((A8(1)*Z + A8(2))*Z + A8(3))*Z + A8(4))*Z + A8(5)) /
     *     (((((((B8(1)*Z + B8(2))*Z + B8(3))*Z + B8(4))*Z + B8(5))*Z +
     *            B8(6))*Z + B8(7))*Z + 1.D0)
      C9 = ((((A9(1)*Z + A9(2))*Z + A9(3))*Z + A9(4))*Z + A9(5)) /
     *     ((((((B9(1)*Z + B9(2))*Z + B9(3))*Z + B9(4))*Z + B9(5))*Z +
     *           B9(6))*Z + 1.D0)
      C10 = (((A10(1)*Z + A10(2))*Z + A10(3))*Z + A10(4)) /
     *      ((((((B10(1)*Z + B10(2))*Z + B10(3))*Z + B10(4))*Z +
     *            B10(5))*Z + B10(6))*Z + 1.D0)
      C11 = (((A11(1)*Z + A11(2))*Z + A11(3))*Z + A11(4)) /
     *      (((((B11(1)*Z + B11(2))*Z + B11(3))*Z + B11(4))*Z +
     *           B11(5))*Z + 1.D0)
      C12 = (((A12(1)*Z + A12(2))*Z + A12(3))*Z + A12(4)) /
     *      ((((B12(1)*Z + B12(2))*Z + B12(3))*Z + B12(4))*Z + 1.D0)
      C13 = ((A13(1)*Z + A13(2))*Z + A13(3)) / ((((B13(1)*Z +
     *        B13(2))*Z + B13(3))*Z + B13(4))*Z + 1.D0)
      C14 = ((A14(1)*Z + A14(2))*Z + A14(3)) / ((B14(1)*Z +
     *        B14(2))*Z + 1.D0)
      C15 = (A15(1)*Z + A15(2)) / ((B15(1)*Z + B15(2))*Z + 1.D0)
      C16 = (A16(1)*Z + A16(2)) / (B16(1)*Z + 1.D0)
C
      T = (A18(1)*U + A17(1))*U + C16
      T = (((((((((((((((T*U + C15)*U + C14)*U + C13)*U + C12)*U +
     *           C11)*U + C10)*U + C9)*U + C8)*U + C7)*U + C6)*U +
     *           C5)*U + C4)*U + C3)*U + C2)*U + C1)*U + C0
C
      IF (L .LT. 1.D0) GO TO 10
         QANS = E*(W + RT2PIN*T/RTA)
         ANS = 0.5D0 + (0.5D0 - QANS)
         RETURN
   10 ANS = E*(W - RT2PIN*T/RTA)
      QANS = 0.5D0 + (0.5D0 - ANS)
      RETURN
      END
      SUBROUTINE DGR17 (A, Y, L, Z, RTA, ANS, QANS)
C-----------------------------------------------------------------------
C
C            ALGORITHM USING MINIMAX APPROXIMATIONS
C                        FOR C0,...,C10
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, Y, L, Z, RTA, ANS, QANS
      DOUBLE PRECISION E, RT2PIN, T, U, W
      DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, C10
      DOUBLE PRECISION A0(5), A1(4), A2(4), A3(4), A4(3), A5(2),
     *                 A6(2), A7(2), A8(2), A9(3), A10(2)
      DOUBLE PRECISION B0(6), B1(6), B2(5), B3(4), B4(4), B5(4),
     *                 B6(3), B7(3), B8(2)
      DOUBLE PRECISION DERFC1
C------------------------
C     RT2PIN = 1/DSQRT(2*PI)
C------------------------
      DATA RT2PIN /.398942280401432678D0/
C------------------------
      DATA
     * A0(1) /-.73324404807556026D-03/, A0(2) /-.11758531313175796D-01/,
     * A0(3) /-.76816029947195974D-01/, A0(4) /-.24232172943558393D+00/,
     * A0(5) /-.33333333333333333D+00/
      DATA
     * B0(1)  /.10555647473018528D-06/, B0(2)  /.73121701584237188D-03/,
     * B0(3)  /.13250270182342259D-01/, B0(4)  /.10288837674434487D+00/,
     * B0(5)  /.43024494247383254D+00/, B0(6)  /.97696518830675185D+00/
C------------------------
      DATA
     * A1(1) /-.16746784557475121D-03/, A1(2) /-.16090334014223031D-02/,
     * A1(3) /-.52949366601406939D-02/, A1(4) /-.18518518518518417D-02/
      DATA
     * B1(1)  /.12328086517283227D-05/, B1(2)  /.98671953445602142D-03/,
     * B1(3)  /.15954049115266936D-01/, B1(4)  /.11439610256504704D+00/,
     * B1(5)  /.45195109694529839D+00/, B1(6)  /.98426579647613593D+00/
C------------------------
      DATA
     * A2(1)  /.12049855113125238D-04/, A2(2)  /.13743853858711134D-03/,
     * A2(3)  /.15067356806896441D-02/, A2(4)  /.41335978835983393D-02/
      DATA
     * B2(1)  /.15927093345670077D-02/, B2(2)  /.22316881460606523D-01/,
     * B2(3)  /.14009848931638062D+00/, B2(4)  /.50379606871703058D+00/,
     * B2(5)  /.10131761625405203D+01/
C------------------------
      DATA
     * A3(1)  /.46318872971699924D-05/, A3(2)  /.13012396979747783D-04/,
     * A3(3)  /.81804333975935872D-03/, A3(4)  /.64943415637082551D-03/
      DATA
     * B3(1)  /.12414068921653593D-01/, B3(2)  /.10044290377295469D+00/,
     * B3(3)  /.42226789458984594D+00/, B3(4)  /.90628317147366376D+00/
C------------------------
      DATA
     * A4(1) /-.37567394580525597D-05/, A4(2) /-.82794205648271314D-04/,
     * A4(3) /-.86188829773520181D-03/
      DATA
     * B4(1)  /.31290397554562032D-01/, B4(2)  /.16988291247058802D+00/,
     * B4(3)  /.57225859400072754D+00/, B4(4)  /.10057375981227881D+01/
C------------------------
      DATA
     * A5(1) /-.43263341886764011D-03/, A5(2) /-.33679854644784478D-03/
      DATA
     * B5(1)  /.22714615451529335D-01/, B5(2)  /.17081504060220639D+00/,
     * B5(3)  /.60019022026983067D+00/, B5(4)  /.10775200414676195D+01/
C------------------------
      DATA
     * A6(1) /-.12962670089753501D-03/, A6(2)  /.53130115408837152D-03/
      DATA
     * B6(1)  /.65929776650152292D-01/, B6(2)  /.45957439582639129D+00/,
     * B6(3)  /.87058903334443855D+00/
C------------------------
      DATA
     * A7(1)  /.47861364421780889D-03/, A7(2)  /.34438428473168988D-03/
      DATA
     * B7(1)  /.27176241899664174D+00/, B7(2)  /.78991370162247144D+00/,
     * B7(3)  /.12396875725833093D+01/
C------------------------
      DATA
     * A8(1)  /.27086391808339115D-03/, A8(2) /-.65256615574219131D-03/
      DATA
     * B8(1)  /.44207055629598579D+00/, B8(2)  /.87002402612484571D+00/
C------------------------
      DATA
     * A9(1) / .84725086921921823D-03/, A9(2) /-.14838721516118744D-03/,
     * A9(3) /-.60335050249571475D-03/
C------------------------
      DATA
     * A10(1)/-.19144384985654775D-02/, A10(2) /.13324454494800656D-02/
C------------------------
      E = DEXP(-Y)
      W = 0.5D0*DERFC1(1,DSQRT(Y))
      U = 1.D0/A
      Z = DSQRT(Z + Z)
      IF (L .LT. 1.D0) Z = -Z
C
      C0 = ((((A0(1)*Z + A0(2))*Z + A0(3))*Z + A0(4))*Z + A0(5)) /
     *     ((((((B0(1)*Z + B0(2))*Z + B0(3))*Z + B0(4))*Z + B0(5))*Z +
     *           B0(6))*Z + 1.D0)
      C1 = (((A1(1)*Z + A1(2))*Z + A1(3))*Z + A1(4)) / ((((((B1(1)*Z +
     *           B1(2))*Z + B1(3))*Z + B1(4))*Z + B1(5))*Z + B1(6))*Z +
     *           1.D0)
      C2 = (((A2(1)*Z + A2(2))*Z + A2(3))*Z + A2(4)) / (((((B2(1)*Z +
     *           B2(2))*Z + B2(3))*Z + B2(4))*Z + B2(5))*Z + 1.D0)
      C3 = (((A3(1)*Z + A3(2))*Z + A3(3))*Z + A3(4)) / ((((B3(1)*Z +
     *           B3(2))*Z + B3(3))*Z + B3(4))*Z + 1.D0)
      C4 = ((A4(1)*Z + A4(2))*Z + A4(3)) / ((((B4(1)*Z + B4(2))*Z +
     *           B4(3))*Z + B4(4))*Z + 1.D0)
      C5 = (A5(1)*Z + A5(2)) / ((((B5(1)*Z + B5(2))*Z + B5(3))*Z +
     *           B5(4))*Z + 1.D0)
      C6 = (A6(1)*Z + A6(2))/(((B6(1)*Z + B6(2))*Z + B6(3))*Z + 1.D0)
      C7 = (A7(1)*Z + A7(2))/(((B7(1)*Z + B7(2))*Z + B7(3))*Z + 1.D0)
      C8 = (A8(1)*Z + A8(2))/((B8(1)*Z + B8(2))*Z + 1.D0)
      C9 = (A9(1)*Z + A9(2))*Z + A9(3)
      C10 = A10(1)*Z + A10(2)
C
      T = (((((((((C10*U + C9)*U + C8)*U + C7)*U + C6)*U + C5)*U +
     *             C4)*U + C3)*U + C2)*U + C1)*U + C0
C
      IF (L .LT. 1.D0) GO TO 10
         QANS = E*(W + RT2PIN*T/RTA)
         ANS = 0.5D0 + (0.5D0 - QANS)
         RETURN
   10 ANS = E*(W - RT2PIN*T/RTA)
      QANS = 0.5D0 + (0.5D0 - ANS)
      RETURN
      END
      SUBROUTINE DGINV (A, X, P, Q, IERR)
C-----------------------------------------------------------------------
C
C                        DOUBLE PRECISION
C             INVERSE INCOMPLETE GAMMA RATIO FUNCTION
C
C     GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1.
C     THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER
C     ITERATION IS EMPLOYED.
C
C                        ------------
C
C     X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0,
C     AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT
C     NUMBER AVAILABLE. OTHERWISE, DGINV ATTEMPTS TO OBTAIN
C     A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE
C     IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C     WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING
C     VALUES ...
C
C       IERR =  0    THE SOLUTION WAS OBTAINED. ITERATION WAS
C                    NOT USED.
C       IERR.GT.0    THE SOLUTION WAS OBTAINED. IERR ITERATIONS
C                    WERE PERFORMED.
C       IERR = -2    (INPUT ERROR) A .LE. 0
C       IERR = -3    NO SOLUTION WAS OBTAINED. THE RATIO Q/A
C                    IS TOO LARGE.
C       IERR = -4    (INPUT ERROR) P OR Q IS NEGATIVE, OR
C                    P + Q .NE. 1.
C       IERR = -6    10 ITERATIONS WERE PERFORMED. THE MOST
C                    RECENT VALUE OBTAINED FOR X IS GIVEN.
C                    (THIS SETTING SHOULD NEVER OCCUR.)
C       IERR = -7    ITERATION FAILED. NO VALUE IS GIVEN FOR X.
C                    THIS MAY OCCUR WHEN X IS APPROXIMATELY 0.
C       IERR = -8    A VALUE FOR X HAS BEEN OBTAINED, BUT THE
C                    ROUTINE IS NOT CERTAIN OF ITS ACCURACY.
C                    ITERATION CANNOT BE PERFORMED IN THIS
C                    CASE. THIS SETTING CAN OCCUR ONLY WHEN
C                    P OR Q IS APPROXIMATELY 0.
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C     WRITTEN ... JANUARY 1992
C------------------------
      DOUBLE PRECISION A, X, P, Q
      REAL P0, Q0, X0
      DOUBLE PRECISION AM1, APN, AP1, AP2, AP3, B, C, C1, C2, C3, C4,
     *                 C5, D, E, EPS, G, H, LN10, PN, QG, QN, R, RTA,
     *                 S, SUM, S2, T, TOL, U, W, XMIN, XN, Y, Z, AMIN
      DOUBLE PRECISION DPMPAR, DLNREL, DGAMMA, DGAMLN, DGMLN1, DRCOMP
C------------------------
C     LN10 = LN(10)
C     C = EULER CONSTANT
C------------------------
      DATA LN10 /2.302585D0/
      DATA C  /.577215664901533D0/
C------------------------
      DATA TOL /1.D-10/
C------------------------
C
C     ****** E AND XMIN ARE MACHINE DEPENDENT CONSTANTS. E IS THE
C            SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0, AND XMIN
C            IS THE SMALLEST POSITIVE NUMBER.
C
                   E = DPMPAR(1)
                   XMIN = DPMPAR(2)
C
C------------------------
      X = 0.D0
      IF (A .LE. 0.D0) GO TO 500
      IF (P .LT. 0.D0 .OR. Q .LT. 0.D0) GO TO 520
      T = ((P + Q) - 0.5D0) - 0.5D0
      IF (DABS(T) .GT. 5.D0*DMAX1(E,1.D-30)) GO TO 520
C
      IERR = 0
      XMIN = XMIN/E
      IF ((P/E) .LE. XMIN) GO TO 400
      IF ((Q/E) .LE. XMIN) GO TO 560
      IF (A .EQ. 1.D0) GO TO 410
C
      E = DMAX1(E,1.D-30)
      EPS = 1.D3*E
      AMIN = 5.D3
      IF (E .LT. 1.D-17) AMIN = 2.D6
      IF (A .GE. AMIN) GO TO 50
C
C        GET AN INITIAL APPROXIMATION USING THE SINGLE
C         PRECISION ARITHMETIC (IF THIS IS POSSIBLE)
C
      P0 = P
      Q0 = Q
      IF (P0 .EQ. 0.0 .OR. Q0 .EQ. 0.0) GO TO 10
      CALL GAMINV (SNGL(A), X0, 0.0, P0, Q0, IER)
      IF (IER .LT. 0.0 .AND. IER .NE. -8) GO TO 10
      IERR = MAX0(IER,0)
      IF (X0 .GT. 1.E34) GO TO 10
         XN = X0
         GO TO 100
C
   10 IF (A .GT. 1.D0) GO TO 50
      XN = 0.D0
C
C        SELECTION OF THE INITIAL APPROXIMATION XN OF X
C                       WHEN A .LT. 1
C
      G = DGAMMA(A + 1.D0)
      QG = Q*G
      IF (QG .EQ. 0.D0) GO TO 560
      B = QG/A
      IF (QG .GT. 0.6D0*A) GO TO 30
      IF (A .GE. 0.30D0 .OR. B .LT. 0.35D0) GO TO 20
         T = DEXP(-(B + C))
         U = T*DEXP(T)
         XN = T*DEXP(U)
         GO TO 100
C
   20 IF (B .GE. 0.45D0) GO TO 30
      IF (B .EQ. 0.D0) GO TO 560
      Y = -DLOG(B)
      S = 0.5D0 + (0.5D0 - A)
      Z = DLOG(Y)
      T = Y - S*Z
      IF (B .LT. 0.15D0) GO TO 21
         XN = Y - S*DLOG(T) - DLOG(1.D0 + S/(T + 1.D0))
         GO TO 200
   21 IF (B .LE. 1.D-2) GO TO 22
         U = ((T + 2.D0*(3.D0 - A))*T + (2.D0 - A)*(3.D0 - A))/
     *            ((T + (5.D0 - A))*T + 2.D0)
         XN = Y - S*DLOG(T) - DLOG(U)
         GO TO 200
   22 C1 = -S*Z
      C2 = -S*(1.D0 + C1)
      C3 =  S*((0.5D0*C1 + (2.D0 - A))*C1 + (2.5D0 - 1.5D0*A))
      C4 = -S*(((C1/3.D0 + (2.5D0 - 1.5D0*A))*C1 + ((A - 6.D0)*A
     *           + 7.D0))*C1 + ((11.D0*A - 46.D0)*A + 47.D0)/6.D0)
      C5 = -S*((((-C1/4.D0 + (11.D0*A - 17.D0)/6.D0)*C1
     *           + ((-3.D0*A + 13.D0)*A - 13.D0))*C1
     *           + 0.5D0*(((2.D0*A - 25.D0)*A + 72.D0)*A - 61.D0))*C1
     *           + (((25.D0*A - 195.D0)*A + 477.D0)*A - 379.D0)/12.D0)
      XN = ((((C5/Y + C4)/Y + C3)/Y + C2)/Y + C1) + Y
      GO TO 200
C
   30 IF (B*Q .GT. 1.D-8) GO TO 31
         XN = DEXP(-(Q/A + C))
         GO TO 40
   31 IF (P .LE. 0.9D0) GO TO 32
         XN = DEXP((DLNREL(-Q) + DGMLN1(A))/A)
         GO TO 40
   32 XN = DEXP(DLOG(P*G)/A)
C
   40 IF (XN .EQ. 0.D0) GO TO 510
      T = 0.5D0 + (0.5D0 - XN/(A + 1.D0))
      XN = XN/T
      GO TO 100
C
C        SELECTION OF THE INITIAL APPROXIMATION XN OF X
C                       WHEN A .GT. 1
C
   50 T = P - 0.5D0
      IF (Q .LT. 0.5D0) T = 0.5D0 - Q
      CALL DPNI (P, Q, T, S, IER)
C
      RTA = DSQRT(A)
      S2 = S*S
      XN = (((12.D0*S2 - 243.D0)*S2 - 923.D0)*S2 + 1472.D0)/204120.D0
     *     - S*(((3753.D0*S2 + 4353.D0)*S2 - 289517.D0)*S2 - 289717.D0)
     *             /(146966400.D0*RTA)
      XN = (XN/A + S*((9.D0*S2 + 256.D0)*S2 - 433.D0)/(38880.D0*RTA))
     *           - ((3.D0*S2 + 7.D0)*S2 - 16.D0)/810.D0
      XN = A + S*RTA + (S2 - 1.D0)/3.D0 + S*(S2 - 7.D0)/(36.D0*RTA)
     *       + XN/A
      XN = DMAX1(XN, 0.D0)
C
      IF (A .LT. AMIN) GO TO 60
         X = XN
         D = 0.5D0 + (0.5D0 - X/A)
         IF (DABS(D) .GT. 1.D-1) GO TO 60
         IF (DABS(D) .GT. 1.D-3) GO TO 100
         RETURN
C
   60 IF (P .LE. 0.5D0) GO TO 70
      IF (XN .LT. 3.D0*A) GO TO 200
      W = DLOG(Q)
      Y = -(W + DGAMLN(A))
      D = DMAX1(2.D0, A*(A - 1.D0))
      IF (Y .LT. LN10*D) GO TO 61
         S = 1.D0 - A
         Z = DLOG(Y)
         GO TO 22
   61 T = A - 1.D0
      XN = Y + T*DLOG(XN) - DLNREL(-T/(XN + 1.D0))
      XN = Y + T*DLOG(XN) - DLNREL(-T/(XN + 1.D0))
      GO TO 200
C
   70 AP1 = A + 1.D0
      IF (XN .GT. 0.7D0*AP1) GO TO 101
      W = DLOG(P) + DGAMLN(AP1)
      IF (XN .GT. 0.15D0*AP1) GO TO 80
         AP2 = A + 2.D0
         AP3 = A + 3.D0
         X = DEXP((W + X)/A)
         X = DEXP((W + X - DLOG(1.0 + (X/AP1)*(1.D0 + X/AP2)))/A)
         X = DEXP((W + X - DLOG(1.0 + (X/AP1)*(1.D0 + X/AP2)))/A)
         X = DEXP((W + X - DLOG(1.0 + (X/AP1)*(1.D0 + (X/AP2)*(1.D0
     *                      + X/AP3))))/A)
         XN = X
         IF (XN .LE. 1.D-2*AP1) GO TO 101
C
   80 APN = AP1
      T = XN/APN
      SUM = 1.D0 + T
   81    APN = APN + 1.D0
         T = T*(XN/APN)
         SUM = SUM + T
         IF (T .GT. 1.D-4) GO TO 81
      T = W - DLOG(SUM)
      XN = DEXP((XN + T)/A)
      XN = XN*(1.D0 - (A*DLOG(XN) - XN - T)/(A - XN))
      GO TO 101
C
C                 SCHRODER ITERATION USING P
C
  100 IF (P .GT. 0.5D0) GO TO 200
  101 IF (P .LE. XMIN) GO TO 550
      AM1 = (A - 0.5D0) - 0.5D0
C
  110 IF (IERR .GE. 10) GO TO 530
      IERR = IERR + 1
      CALL DGRAT (A, XN, PN, QN, IND)
      IF (PN .EQ. 0.D0 .OR. QN .EQ. 0.D0) GO TO 550
      R = DRCOMP(A,XN)
      IF (R .LT. XMIN) GO TO 550
      T = (PN - P)/R
      W = 0.5D0*(AM1 - XN)
      IF (DABS(T) .LE. 0.1D0 .AND. DABS(W*T) .LE. 0.1D0) GO TO 120
         X = XN*(1.D0 - T)
         IF (X .LE. 0.D0) GO TO 540
         D = DABS(T)
         GO TO 121
C
  120 H = T*(1.D0 + W*T)
      X = XN*(1.D0 - H)
      IF (X .LE. 0.D0) GO TO 540
      IF (DABS(W) .GE. 1.D0 .AND. DABS(W)*T*T .LE. EPS) RETURN
      D = DABS(H)
  121 XN = X
      IF (D .GT. TOL) GO TO 110
      IF (D .LE. EPS) RETURN
      IF (DABS(P - PN) .LE. TOL*P) RETURN
      GO TO 110
C
C                 SCHRODER ITERATION USING Q
C
  200 IF (Q .LE. XMIN) GO TO 550
      AM1 = (A - 0.5D0) - 0.5D0
C
  210 IF (IERR .GE. 10) GO TO 530
      IERR = IERR + 1
      CALL DGRAT (A, XN, PN, QN, IND)
      IF (PN .EQ. 0.D0 .OR. QN .EQ. 0.D0) GO TO 550
      R = DRCOMP(A,XN)
      IF (R .LT. XMIN) GO TO 550
      T = (Q - QN)/R
      W = 0.5D0*(AM1 - XN)
      IF (DABS(T) .LE. 0.1D0 .AND. DABS(W*T) .LE. 0.1D0) GO TO 220
         X = XN*(1.D0 - T)
         IF (X .LE. 0.D0) GO TO 540
         D = DABS(T)
         GO TO 221
C
  220 H = T*(1.D0 + W*T)
      X = XN*(1.D0 - H)
      IF (X .LE. 0.D0) GO TO 540
      IF (DABS(W) .GE. 1.D0 .AND. DABS(W)*T*T .LE. EPS) RETURN
      D = DABS(H)
  221 XN = X
      IF (D .GT. TOL) GO TO 210
      IF (D .LE. EPS) RETURN
      IF (DABS(Q - QN) .LE. TOL*Q) RETURN
      GO TO 210
C
C                       SPECIAL CASES
C
  400 IERR = -8
      RETURN
C
  410 IF (Q .LT. 0.9D0) GO TO 411
         X = -DLNREL(-P)
         RETURN
  411 X = -DLOG(Q)
      RETURN
C
C                       ERROR RETURN
C
  500 IERR = -2
      RETURN
C
  510 IERR = -3
      RETURN
C
  520 IERR = -4
      RETURN
C
  530 IERR = -6
      RETURN
C
  540 IERR = -7
      RETURN
C
  550 X = XN
      IERR = -8
      RETURN
C
  560 X = DPMPAR(3)
      IERR = -8
      RETURN
      END
      SUBROUTINE BRATIO (A, B, X, Y, W, W1, IERR)
C-----------------------------------------------------------------------
C
C            EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B)
C
C                     --------------------
C
C     IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X .LE. 1
C     AND Y = 1 - X.  BRATIO ASSIGNS W AND W1 THE VALUES
C
C                      W  = IX(A,B)
C                      W1 = 1 - IX(A,B)
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C     IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND
C     W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED,
C     THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO
C     ONE OF THE FOLLOWING VALUES ...
C
C        IERR = 1  IF A OR B IS NEGATIVE
C        IERR = 2  IF A = B = 0
C        IERR = 3  IF X .LT. 0 OR X .GT. 1
C        IERR = 4  IF Y .LT. 0 OR Y .GT. 1
C        IERR = 5  IF X + Y .NE. 1
C        IERR = 6  IF X = A = 0
C        IERR = 7  IF Y = B = 0
C
C--------------------
C     WRITTEN BY ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C     REVISED ... APRIL 1993
C-----------------------------------------------------------------------
      REAL LAMBDA
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST
C            FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0
C
                       EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      W = 0.0
      W1 = 0.0
      IF (A .LT. 0.0 .OR. B .LT. 0.0) GO TO 300
      IF (A .EQ. 0.0 .AND. B .EQ. 0.0) GO TO 310
      IF (X .LT. 0.0 .OR. X .GT. 1.0) GO TO 320
      IF (Y .LT. 0.0 .OR. Y .GT. 1.0) GO TO 330
      Z = ((X + Y) - 0.5) - 0.5
      IF (ABS(Z) .GT. 3.0*EPS) GO TO 340
C
      IERR = 0
      IF (X .EQ. 0.0) GO TO 200
      IF (Y .EQ. 0.0) GO TO 210
      IF (A .EQ. 0.0) GO TO 211
      IF (B .EQ. 0.0) GO TO 201
C
      EPS = AMAX1(EPS, 1.E-15)
      IF (AMAX1(A,B) .LT. 1.E-3*EPS) GO TO 230
C
      IND = 0
      A0 = A
      B0 = B
      X0 = X
      Y0 = Y
      IF (AMIN1(A0, B0) .GT. 1.0) GO TO 30
C
C             PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1
C
      IF (X .LE. 0.5) GO TO 10
      IND = 1
      A0 = B
      B0 = A
      X0 = Y
      Y0 = X
C
   10 IF (B0 .LT. AMIN1(EPS,EPS*A0)) GO TO 80
      IF (A0 .LT. AMIN1(EPS,EPS*B0) .AND. B0*X0 .LE. 1.0) GO TO 90
      IF (AMAX1(A0, B0) .GT. 1.0) GO TO 20
      IF (A0 .GE. AMIN1(0.2, B0)) GO TO 100
      IF (X0**A0 .LE. 0.9) GO TO 100
      IF (X0 .GE. 0.3) GO TO 110
      N = 20
      GO TO 130
C
   20 IF (B0 .LE. 1.0) GO TO 100
      IF (X0 .GE. 0.3) GO TO 110
      IF (X0 .GE. 0.1) GO TO 21
      IF ((X0*B0)**A0 .LE. 0.7) GO TO 100
   21 IF (B0 .GT. 15.0) GO TO 131
      N = 20
      GO TO 130
C
C             PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1
C
   30 IF (A .GT. B) GO TO 31
         LAMBDA = A - (A + B)*X
         GO TO 32
   31 LAMBDA = (A + B)*Y - B
   32 IF (LAMBDA .GE. 0.0) GO TO 40
      IND = 1
      A0 = B
      B0 = A
      X0 = Y
      Y0 = X
      LAMBDA = ABS(LAMBDA)
C
   40 IF (B0 .LT. 40.0 .AND. B0*X0 .LE. 0.7) GO TO 100
      IF (B0 .LT. 40.0) GO TO 140
      IF (A0 .GT. B0) GO TO 50
         IF (A0 .LE. 100.0) GO TO 120
         IF (LAMBDA .GT. 0.03*A0) GO TO 120
         GO TO 180
   50 IF (B0 .LE. 100.0) GO TO 120
      IF (LAMBDA .GT. 0.03*B0) GO TO 120
      GO TO 180
C
C            EVALUATION OF THE APPROPRIATE ALGORITHM
C
   80 W = FPSER(A0, B0, X0, EPS)
      W1 = 0.5 + (0.5 - W)
      GO TO 220
C
   90 W1 = APSER(A0, B0, X0, EPS)
      W = 0.5 + (0.5 - W1)
      GO TO 220
C
  100 W = BPSER(A0, B0, X0, EPS)
      W1 = 0.5 + (0.5 - W)
      GO TO 220
C
  110 W1 = BPSER(B0, A0, Y0, EPS)
      W = 0.5 + (0.5 - W1)
      GO TO 220
C
  120 W = BFRAC(A0, B0, X0, Y0, LAMBDA, 15.0*EPS)
      W1 = 0.5 + (0.5 - W)
      GO TO 220
C
  130 W1 = BUP(B0, A0, Y0, X0, N, EPS)
      B0 = B0 + N
  131 CALL BGRAT (B0, A0, Y0, X0, W1, EPS, IERR1)
      W = 0.5 + (0.5 - W1)
      GO TO 220
C
  140 N = B0
      B0 = B0 - N
      IF (B0 .NE. 0.0) GO TO 141
         N = N - 1
         B0 = 1.0
  141 W = BUP(B0, A0, Y0, X0, N, EPS)
      IF (X0 .GT. 0.7) GO TO 150
      W = W + BPSER(A0, B0, X0, EPS)
      W1 = 0.5 + (0.5 - W)
      GO TO 220
C
  150 IF (A0 .GT. 15.0) GO TO 151
         N = 20
         W = W + BUP(A0, B0, X0, Y0, N, EPS)
         A0 = A0 + N
  151 CALL BGRAT (A0, B0, X0, Y0, W, EPS, IERR1)
      W1 = 0.5 + (0.5 - W)
      GO TO 220
C
  180 W = BASYM(A0, B0, LAMBDA, 100.0*EPS)
      W1 = 0.5 + (0.5 - W)
      GO TO 220
C
C               TERMINATION OF THE PROCEDURE
C
  200 IF (A .EQ. 0.0) GO TO 350
  201 W = 0.0
      W1 = 1.0
      RETURN
C
  210 IF (B .EQ. 0.0) GO TO 360
  211 W = 1.0
      W1 = 0.0
      RETURN
C
  220 IF (IND .EQ. 0) RETURN
      T = W
      W = W1
      W1 = T
      RETURN
C
C           PROCEDURE FOR A AND B .LT. 1.E-3*EPS
C
  230 W = B/(A + B)
      W1 = A/(A + B)
      RETURN
C
C                       ERROR RETURN
C
  300 IERR = 1
      RETURN
  310 IERR = 2
      RETURN
  320 IERR = 3
      RETURN
  330 IERR = 4
      RETURN
  340 IERR = 5
      RETURN
  350 IERR = 6
      RETURN
  360 IERR = 7
      RETURN
      END
      REAL FUNCTION FPSER (A, B, X, EPS)
C-----------------------------------------------------------------------
C
C                 EVALUATION OF I (A,B)
C                                X
C
C          FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5.
C
C-----------------------------------------------------------------------
C
C                  SET  FPSER = X**A
C
      FPSER = 1.0
      IF (A .LE. 1.E-3*EPS) GO TO 10
      FPSER = 0.0
      T = A*ALOG(X)
      IF (T .LT. EXPARG(1)) RETURN
      FPSER = EXP(T)
C
C                NOTE THAT 1/B(A,B) = B
C
   10 FPSER = (B/A)*FPSER
      TOL = EPS/A
      AN = A + 1.0
      T = X
      S = T/AN
   20    AN = AN + 1.0
         T = X*T
         C = T/AN
         S = S + C
         IF (ABS(C) .GT. TOL) GO TO 20
C
      FPSER = FPSER*(1.0 + A*S)
      RETURN
      END
      REAL FUNCTION APSER (A, B, X, EPS)
C-----------------------------------------------------------------------
C     APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR
C     A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN
C     A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED.
C-----------------------------------------------------------------------
      REAL J
C--------------------
      DATA G /.577215664901533/
C--------------------
      BX = B*X
      T = X - BX
      IF (B*EPS .GT. 2.E-2) GO TO 10
         C = ALOG(X) + PSI(B) + G + T
         GO TO 20
   10 C = ALOG(BX) + G + T
C
   20 TOL = 5.0*EPS*ABS(C)
      J = 1.0
      S = 0.0
   30    J = J + 1.0
         T = T*(X - BX/J)
         AJ = T/J
         S = S + AJ
         IF (ABS(AJ) .GT. TOL) GO TO 30
C
      APSER = -A*(C + S)
      RETURN
      END
      REAL FUNCTION BPSER (A, B, X, EPS)
C-----------------------------------------------------------------------
C     POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1
C     OR B*X .LE. 0.7.  EPS IS THE TOLERANCE USED.
C-----------------------------------------------------------------------
      REAL N
C
      BPSER = 0.0
      IF (X .EQ. 0.0) RETURN
C-----------------------------------------------------------------------
C            COMPUTE THE FACTOR X**A/(A*BETA(A,B))
C-----------------------------------------------------------------------
      A0 = AMIN1(A,B)
      IF (A0 .LT. 1.0) GO TO 10
         Z = A*ALOG(X) - BETALN(A,B)
         BPSER = EXP(Z)/A
         GO TO 70
   10 B0 = AMAX1(A,B)
      IF (B0 .GE. 8.0) GO TO 60
      IF (B0 .GT. 1.0) GO TO 40
C
C            PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1
C
      BPSER = X**A
      IF (BPSER .EQ. 0.0) RETURN
C
      APB = A + B
      IF (APB .GT. 1.0) GO TO 20
         Z = 1.0 + GAM1(APB)
         GO TO 30
   20 U = DBLE(A) + DBLE(B) - 1.D0
      Z = (1.0 + GAM1(U))/APB
C
   30 C = (1.0 + GAM1(A))*(1.0 + GAM1(B))/Z
      BPSER = BPSER*C*(B/APB)
      GO TO 70
C
C         PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8
C
   40 U = GAMLN1(A0)
      M = B0 - 1.0
      IF (M .LT. 1) GO TO 50
      C = 1.0
      DO 41 I = 1,M
         B0 = B0 - 1.0
   41    C = C*(B0/(A0 + B0))
      U = ALOG(C) + U
C
   50 Z = A*ALOG(X) - U
      B0 = B0 - 1.0
      APB = A0 + B0
      IF (APB .GT. 1.0) GO TO 51
         T = 1.0 + GAM1(APB)
         GO TO 52
   51 U = DBLE(A0) + DBLE(B0) - 1.D0
      T = (1.0 + GAM1(U))/APB
   52 BPSER = EXP(Z)*(A0/A)*(1.0 + GAM1(B0))/T
      GO TO 70
C
C            PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8
C
   60 U = GAMLN1(A0) + ALGDIV(A0,B0)
      Z = A*ALOG(X) - U
      BPSER = (A0/A)*EXP(Z)
   70 IF (BPSER .EQ. 0.0 .OR. A .LE. 0.1*EPS) RETURN
C-----------------------------------------------------------------------
C                     COMPUTE THE SERIES
C-----------------------------------------------------------------------
      SUM = 0.0
      N = 0.0
      C = 1.0
      TOL = EPS/A
  100    N = N + 1.0
         C = C*(0.5 + (0.5 - B/N))*X
         W = C/(A + N)
         SUM = SUM + W
         IF (ABS(W) .GT. TOL) GO TO 100
      BPSER = BPSER*(1.0 + A*SUM)
      RETURN
      END
      REAL FUNCTION BUP (A, B, X, Y, N, EPS)
C-----------------------------------------------------------------------
C     EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER.
C     EPS IS THE TOLERANCE USED.
C-----------------------------------------------------------------------
      REAL L
C
C          OBTAIN THE SCALING FACTOR EXP(-MU) AND
C             EXP(MU)*(X**A*Y**B/BETA(A,B))/A
C
      APB = A + B
      AP1 = A + 1.0
      MU = 0
      D = 1.0
      IF (N .EQ. 1 .OR. A .LT. 1.0) GO TO 10
      IF (APB .LT. 1.1*AP1) GO TO 10
         MU = ABS(EXPARG(1))
         K = EXPARG(0)
         IF (K .LT. MU) MU = K
         T = MU
         D = EXP(-T)
C
   10 BUP = BRCMP1(MU,A,B,X,Y)/A
      IF (N .EQ. 1 .OR. BUP .EQ. 0.0) RETURN
      NM1 = N - 1
      W = D
C
C          LET K BE THE INDEX OF THE MAXIMUM TERM
C
      K = 0
      IF (B .LE. 1.0) GO TO 40
      IF (Y .GT. 1.E-4) GO TO 20
         K = NM1
         GO TO 30
   20 R = (B - 1.0)*X/Y - A
      IF (R .LT. 1.0) GO TO 40
      K = NM1
      T = NM1
      IF (R .LT. T) K = R
C
C          ADD THE INCREASING TERMS OF THE SERIES
C
   30 DO 31 I = 1,K
         L = I - 1
         D = ((APB + L)/(AP1 + L))*X*D
         W = W + D
   31 CONTINUE
      IF (K .EQ. NM1) GO TO 50
C
C          ADD THE REMAINING TERMS OF THE SERIES
C
   40 KP1 = K + 1
      DO 41 I = KP1,NM1
         L = I - 1
         D = ((APB + L)/(AP1 + L))*X*D
         W = W + D
         IF (D .LE. EPS*W) GO TO 50
   41 CONTINUE
C
C               TERMINATE THE PROCEDURE
C
   50 BUP = BUP*W
      RETURN
      END
      REAL FUNCTION BFRAC (A, B, X, Y, LAMBDA, EPS)
C-----------------------------------------------------------------------
C     CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1.
C     IT IS ASSUMED THAT  LAMBDA = (A + B)*Y - B.
C-----------------------------------------------------------------------
      REAL LAMBDA, N
C
      BFRAC = BRCOMP(A,B,X,Y)
      IF (BFRAC .EQ. 0.0) RETURN
C
      C = 1.0 + LAMBDA
      C0 = B/A
      C1 = 1.0 + 1.0/A
      YP1 = Y + 1.0
C
      N = 0.0
      P = 1.0
      S = A + 1.0
      AN = 0.0
      BN = 1.0
      ANP1 = 1.0
      BNP1 = C/C1
      R = C1/C
C
C        CONTINUED FRACTION CALCULATION
C
   10    N = N + 1.0
         T = N/A
         W = N*(B - N)*X
         E = A/S
         ALPHA = (P*(P + C0)*E*E)*(W*X)
         IF (ALPHA .LE. 0.0) GO TO 20
         E = (1.0 + T)/(C1 + T + T)
         BETA = N + W/S + E*(C + N*YP1)
         P = 1.0 + T
         S = S + 2.0
C
C        UPDATE AN, BN, ANP1, AND BNP1
C
         T = ALPHA*AN + BETA*ANP1
         AN = ANP1
         ANP1 = T
         T = ALPHA*BN + BETA*BNP1
         BN = BNP1
         BNP1 = T
         R0 = R
         R = ANP1/BNP1
         IF (ABS(R - R0) .LE. EPS*R) GO TO 20
C
C        RESCALE AN, BN, ANP1, AND BNP1
C
         AN = AN/BNP1
         BN = BN/BNP1
         ANP1 = R
         BNP1 = 1.0
         GO TO 10
C
C                 TERMINATION
C
   20 BFRAC = BFRAC*R
      RETURN
      END
      REAL FUNCTION BRCOMP (A, B, X, Y)
C-----------------------------------------------------------------------
C               EVALUATION OF X**A*Y**B/BETA(A,B)
C-----------------------------------------------------------------------
      REAL LAMBDA, LNX, LNY
C-----------------
C     CONST = 1/SQRT(2*PI)
C-----------------
      DATA CONST /.398942280401433/
C
      BRCOMP = 0.0
      IF (X .EQ. 0.0 .OR. Y .EQ. 0.0) RETURN
      A0 = AMIN1(A,B)
      IF (A0 .GE. 8.0) GO TO 100
C
      IF (X .GT. 0.375) GO TO 10
         LNX = ALOG(X)
         LNY = ALNREL(-X)
         GO TO 20
   10 IF (Y .GT. 0.375) GO TO 11
         LNX = ALNREL(-Y)
         LNY = ALOG(Y)
         GO TO 20
   11 LNX = ALOG(X)
      LNY = ALOG(Y)
C
   20 Z = A*LNX + B*LNY
      IF (A0 .LT. 1.0) GO TO 30
      Z = Z - BETALN(A,B)
      BRCOMP = EXP(Z)
      RETURN
C-----------------------------------------------------------------------
C              PROCEDURE FOR A .LT. 1 OR B .LT. 1
C-----------------------------------------------------------------------
   30 B0 = AMAX1(A,B)
      IF (B0 .GE. 8.0) GO TO 80
      IF (B0 .GT. 1.0) GO TO 60
C
C                   ALGORITHM FOR B0 .LE. 1
C
      BRCOMP = EXP(Z)
      IF (BRCOMP .EQ. 0.0) RETURN
C
      APB = A + B
      IF (APB .GT. 1.0) GO TO 40
         Z = 1.0 + GAM1(APB)
         GO TO 50
   40 U = DBLE(A) + DBLE(B) - 1.D0
      Z = (1.0 + GAM1(U))/APB
C
   50 C = (1.0 + GAM1(A))*(1.0 + GAM1(B))/Z
      BRCOMP = BRCOMP*(A0*C)/(1.0 + A0/B0)
      RETURN
C
C                ALGORITHM FOR 1 .LT. B0 .LT. 8
C
   60 U = GAMLN1(A0)
      N = B0 - 1.0
      IF (N .LT. 1) GO TO 70
      C = 1.0
      DO 61 I = 1,N
         B0 = B0 - 1.0
         C = C*(B0/(A0 + B0))
   61 CONTINUE
      U = ALOG(C) + U
C
   70 Z = Z - U
      B0 = B0 - 1.0
      APB = A0 + B0
      IF (APB .GT. 1.0) GO TO 71
         T = 1.0 + GAM1(APB)
         GO TO 72
   71 U = DBLE(A0) + DBLE(B0) - 1.D0
      T = (1.0 + GAM1(U))/APB
   72 BRCOMP = A0*EXP(Z)*(1.0 + GAM1(B0))/T
      RETURN
C
C                   ALGORITHM FOR B0 .GE. 8
C
   80 U = GAMLN1(A0) + ALGDIV(A0,B0)
      BRCOMP = A0*EXP(Z - U)
      RETURN
C-----------------------------------------------------------------------
C              PROCEDURE FOR A .GE. 8 AND B .GE. 8
C-----------------------------------------------------------------------
  100 IF (A .GT. B) GO TO 101
         H = A/B
         X0 = H/(1.0 + H)
         Y0 = 1.0/(1.0 + H)
         LAMBDA = A - (A + B)*X
         GO TO 110
  101 H = B/A
      X0 = 1.0/(1.0 + H)
      Y0 = H/(1.0 + H)
      LAMBDA = (A + B)*Y - B
C
  110 E = -LAMBDA/A
      IF (ABS(E) .GT. 0.6) GO TO 111
         U = RLOG1(E)
         GO TO 120
  111 U = E - ALOG(X/X0)
C
  120 E = LAMBDA/B
      IF (ABS(E) .GT. 0.6) GO TO 121
         V = RLOG1(E)
         GO TO 130
  121 V = E - ALOG(Y/Y0)
C
  130 Z = EXP(-(A*U + B*V))
      BRCOMP = CONST*SQRT(B*X0)*Z*EXP(-BCORR(A,B))
      RETURN
      END
      REAL FUNCTION BRCMP1 (MU, A, B, X, Y)
C-----------------------------------------------------------------------
C          EVALUATION OF  EXP(MU) * (X**A*Y**B/BETA(A,B))
C-----------------------------------------------------------------------
      REAL LAMBDA, LNX, LNY
C-----------------
C     CONST = 1/SQRT(2*PI)
C-----------------
      DATA CONST /.398942280401433/
C
      A0 = AMIN1(A,B)
      IF (A0 .GE. 8.0) GO TO 100
C
      IF (X .GT. 0.375) GO TO 10
         LNX = ALOG(X)
         LNY = ALNREL(-X)
         GO TO 20
   10 IF (Y .GT. 0.375) GO TO 11
         LNX = ALNREL(-Y)
         LNY = ALOG(Y)
         GO TO 20
   11 LNX = ALOG(X)
      LNY = ALOG(Y)
C
   20 Z = A*LNX + B*LNY
      IF (A0 .LT. 1.0) GO TO 30
      Z = Z - BETALN(A,B)
      BRCMP1 = ESUM(MU,Z)
      RETURN
C-----------------------------------------------------------------------
C              PROCEDURE FOR A .LT. 1 OR B .LT. 1
C-----------------------------------------------------------------------
   30 B0 = AMAX1(A,B)
      IF (B0 .GE. 8.0) GO TO 80
      IF (B0 .GT. 1.0) GO TO 60
C
C                   ALGORITHM FOR B0 .LE. 1
C
      BRCMP1 = ESUM(MU,Z)
      IF (BRCMP1 .EQ. 0.0) RETURN
C
      APB = A + B
      IF (APB .GT. 1.0) GO TO 40
         Z = 1.0 + GAM1(APB)
         GO TO 50
   40 U = DBLE(A) + DBLE(B) - 1.D0
      Z = (1.0 + GAM1(U))/APB
C
   50 C = (1.0 + GAM1(A))*(1.0 + GAM1(B))/Z
      BRCMP1 = BRCMP1*(A0*C)/(1.0 + A0/B0)
      RETURN
C
C                ALGORITHM FOR 1 .LT. B0 .LT. 8
C
   60 U = GAMLN1(A0)
      N = B0 - 1.0
      IF (N .LT. 1) GO TO 70
      C = 1.0
      DO 61 I = 1,N
         B0 = B0 - 1.0
         C = C*(B0/(A0 + B0))
   61 CONTINUE
      U = ALOG(C) + U
C
   70 Z = Z - U
      B0 = B0 - 1.0
      APB = A0 + B0
      IF (APB .GT. 1.0) GO TO 71
         T = 1.0 + GAM1(APB)
         GO TO 72
   71 U = DBLE(A0) + DBLE(B0) - 1.D0
      T = (1.0 + GAM1(U))/APB
   72 BRCMP1 = A0*ESUM(MU,Z)*(1.0 + GAM1(B0))/T
      RETURN
C
C                   ALGORITHM FOR B0 .GE. 8
C
   80 U = GAMLN1(A0) + ALGDIV(A0,B0)
      BRCMP1 = A0*ESUM(MU,Z - U)
      RETURN
C-----------------------------------------------------------------------
C              PROCEDURE FOR A .GE. 8 AND B .GE. 8
C-----------------------------------------------------------------------
  100 IF (A .GT. B) GO TO 101
         H = A/B
         X0 = H/(1.0 + H)
         Y0 = 1.0/(1.0 + H)
         LAMBDA = A - (A + B)*X
         GO TO 110
  101 H = B/A
      X0 = 1.0/(1.0 + H)
      Y0 = H/(1.0 + H)
      LAMBDA = (A + B)*Y - B
C
  110 E = -LAMBDA/A
      IF (ABS(E) .GT. 0.6) GO TO 111
         U = RLOG1(E)
         GO TO 120
  111 U = E - ALOG(X/X0)
C
  120 E = LAMBDA/B
      IF (ABS(E) .GT. 0.6) GO TO 121
         V = RLOG1(E)
         GO TO 130
  121 V = E - ALOG(Y/Y0)
C
  130 Z = ESUM(MU,-(A*U + B*V))
      BRCMP1 = CONST*SQRT(B*X0)*Z*EXP(-BCORR(A,B))
      RETURN
      END
      SUBROUTINE BGRAT (A, B, X, Y, W, EPS, IERR)
C-----------------------------------------------------------------------
C     ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B.
C     THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED
C     THAT A .GE. 15 AND B .LE. 1.  EPS IS THE TOLERANCE USED.
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C-----------------------------------------------------------------------
      REAL C(30), D(30), J, L, LNX, NU, N2
C
      BM1 = (B - 0.5) - 0.5
      NU = A + 0.5*BM1
      IF (Y .GT. 0.375) GO TO 10
         LNX = ALNREL(-Y)
         GO TO 11
   10 LNX = ALOG(X)
   11 Z = -NU*LNX
      IF (B*Z .EQ. 0.0) GO TO 100
C
C                 COMPUTATION OF THE EXPANSION
C                 SET R = EXP(-Z)*Z**B/GAMMA(B)
C
      R = B*(1.0 + GAM1(B))*EXP(B*ALOG(Z))
      R = R*EXP(A*LNX)*EXP(0.5*BM1*LNX)
      U = ALGDIV(B,A) + B*ALOG(NU)
      U = R*EXP(-U)
      IF (U .EQ. 0.0) GO TO 100
      CALL GRAT1 (B, Z, R, P, Q, EPS)
C
      TOL = 15.0*EPS
      V = 0.25*(1.0/NU)**2
      T2 = 0.25*LNX*LNX
      L = W/U
      J = Q/R
      SUM = J
      T = 1.0
      CN = 1.0
      N2 = 0.0
      DO 22 N = 1,30
         BP2N = B + N2
         J = (BP2N*(BP2N + 1.0)*J + (Z + BP2N + 1.0)*T)*V
         N2 = N2 + 2.0
         T = T*T2
         CN = CN/(N2*(N2 + 1.0))
         C(N) = CN
         S = 0.0
         IF (N .EQ. 1) GO TO 21
            NM1 = N - 1
            COEF = B - N
            DO 20 I = 1,NM1
               S = S + COEF*C(I)*D(N-I)
   20          COEF = COEF + B
   21    D(N) = BM1*CN + S/N
         DJ = D(N)*J
         SUM = SUM + DJ
         IF (SUM .LE. 0.0) GO TO 100
         IF (ABS(DJ) .LE. TOL*(SUM + L)) GO TO 30
   22 CONTINUE
C
C                    ADD THE RESULTS TO W
C
   30 IERR = 0
      W = W + U*SUM
      RETURN
C
C               THE EXPANSION CANNOT BE COMPUTED
C
  100 IERR = 1
      RETURN
      END
      SUBROUTINE GRAT1 (A, X, R, P, Q, EPS)
C-----------------------------------------------------------------------
C           EVALUATION OF P(A,X) AND Q(A,X) WHERE A .LE. 1 AND
C        THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A)
C-----------------------------------------------------------------------
      REAL J, L
C--------------------
      IF (A*X .EQ. 0.0) GO TO 130
      IF (A .EQ. 0.5) GO TO 120
      IF (X .LT. 1.1) GO TO 10
      GO TO 50
C
C             TAYLOR SERIES FOR P(A,X)/X**A
C
   10 AN = 3.0
      C = X
      SUM = X/(A + 3.0)
      TOL = 3.0*EPS/(A + 1.0)
   11    AN = AN + 1.0
         C = -C*(X/AN)
         T = C/(A + AN)
         SUM = SUM + T
         IF (ABS(T) .GT. TOL) GO TO 11
      J = A*X*((SUM/6.0 - 0.5/(A + 2.0))*X + 1.0/(A + 1.0))
C
      Z = A*ALOG(X)
      H = GAM1(A)
      G = 1.0 + H
      IF (X .LT. 0.25) GO TO 20
         IF (A .LT. X/2.59) GO TO 40
         GO TO 30
   20 IF (Z .GT. -.13394) GO TO 40
C
   30 W = EXP(Z)
      P = W*G*(0.5 + (0.5 - J))
      Q = 0.5 + (0.5 - P)
      RETURN
C
   40 L = REXP(Z)
      Q = ((0.5 + (0.5 + L))*J - L)*G - H
      IF (Q .LE. 0.0) GO TO 110
      P = 0.5 + (0.5 - Q)
      RETURN
C
C              CONTINUED FRACTION EXPANSION
C
   50 TOL = 8.0*EPS
      A2NM1 = 1.0
      A2N = 1.0
      B2NM1 = X
      B2N = X + (1.0 - A)
      C = 1.0
   60    A2NM1 = X*A2N + C*A2NM1
         B2NM1 = X*B2N + C*B2NM1
         C = C + 1.0
         A2N = A2NM1 + (C - A)*A2N
         B2N = B2NM1 + (C - A)*B2N
         A2NM1 = A2NM1/B2N
         B2NM1 = B2NM1/B2N
         A2N = A2N/B2N
         B2N = 1.0
         IF (ABS(A2N - A2NM1/B2NM1) .GE. TOL*A2N) GO TO 60
C
      Q = R*A2N
      P = 0.5 + (0.5 - Q)
      RETURN
C
C                SPECIAL CASES
C
  100 P = 0.0
      Q = 1.0
      RETURN
C
  110 P = 1.0
      Q = 0.0
      RETURN
C
  120 IF (X .GE. 0.25) GO TO 121
         P = ERF(SQRT(X))
         Q = 0.5 + (0.5 - P)
         RETURN
  121 Q = ERFC1(0,SQRT(X))
      P = 0.5 + (0.5 - Q)
      RETURN
C
  130 IF (X .LE. A) GO TO 100
      GO TO 110
      END
      REAL FUNCTION BASYM (A, B, LAMBDA, EPS)
C-----------------------------------------------------------------------
C     ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B.
C     LAMBDA = (A + B)*Y - B  AND EPS IS THE TOLERANCE USED.
C     IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT
C     A AND B ARE GREATER THAN OR EQUAL TO 15.
C-----------------------------------------------------------------------
      REAL J0, J1, LAMBDA
      REAL A0(21), B0(21), C(21), D(21)
C------------------------
C     ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP
C            ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN.
C            THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1.
C
                      DATA NUM/20/
C------------------------
C     E0 = 2/SQRT(PI)
C     E1 = 2**(-3/2)
C------------------------
      DATA E0/1.12837916709551/, E1/.353553390593274/
C------------------------
      BASYM = 0.0
      IF (A .GE. B) GO TO 10
         H = A/B
         R0 = 1.0/(1.0 + H)
         R1 = (B - A)/B
         W0 = 1.0/SQRT(A*(1.0 + H))
         GO TO 20
   10 H = B/A
      R0 = 1.0/(1.0 + H)
      R1 = (B - A)/A
      W0 = 1.0/SQRT(B*(1.0 + H))
C
   20 F = A*RLOG1(-LAMBDA/A) + B*RLOG1(LAMBDA/B)
      T = EXP(-F)
      IF (T .EQ. 0.0) RETURN
      Z0 = SQRT(F)
      Z = 0.5*(Z0/E1)
      Z2 = F + F
C
      A0(1) = (2.0/3.0)*R1
      C(1) = - 0.5*A0(1)
      D(1) = - C(1)
      J0 = (0.5/E0)*ERFC1(1,Z0)
      J1 = E1
      SUM = J0 + D(1)*W0*J1
C
      S = 1.0
      H2 = H*H
      HN = 1.0
      W = W0
      ZNM1 = Z
      ZN = Z2
      DO 50 N = 2, NUM, 2
         HN = H2*HN
         A0(N) = 2.0*R0*(1.0 + H*HN)/(N + 2.0)
         NP1 = N + 1
         S = S + HN
         A0(NP1) = 2.0*R1*S/(N + 3.0)
C
         DO 41 I = N, NP1
         R = -0.5*(I + 1.0)
         B0(1) = R*A0(1)
         DO 31 M = 2, I
            BSUM = 0.0
            MM1 = M - 1
            DO 30 J = 1, MM1
               MMJ = M - J
   30          BSUM = BSUM + (J*R - MMJ)*A0(J)*B0(MMJ)
   31       B0(M) = R*A0(M) + BSUM/M
         C(I) = B0(I)/(I + 1.0)
C
         DSUM = 0.0
         IM1 = I - 1
         DO 40 J = 1, IM1
            IMJ = I - J
   40       DSUM = DSUM + D(IMJ)*C(J)
   41    D(I) = -(DSUM + C(I))
C
         J0 = E1*ZNM1 + (N - 1.0)*J0
         J1 = E1*ZN + N*J1
         ZNM1 = Z2*ZNM1
         ZN = Z2*ZN
         W = W0*W
         T0 = D(N)*W*J0
         W = W0*W
         T1 = D(NP1)*W*J1
         SUM = SUM + (T0 + T1)
         IF ((ABS(T0) + ABS(T1)) .LE. EPS*SUM) GO TO 60
   50    CONTINUE
C
   60 U = EXP(-BCORR(A,B))
      BASYM = E0*T*U*SUM
      RETURN
      END
      SUBROUTINE ISUBX (A0, B0, X0, P, IERR, EPS)
      REAL I, J, K, LAMBDA, M, N, W(10), Z(10)
C     -------------------
      DATA W(1) /6.6671344308688E-2/,  W(2) /1.4945134915058E-1/,
     1     W(3) /2.1908636251598E-1/,  W(4) /2.6926671931000E-1/,
     2     W(5) /2.9552422471475E-1/,  W(6) /2.9552422471475E-1/,
     3     W(7) /2.6926671931000E-1/,  W(8) /2.1908636251598E-1/,
     4     W(9) /1.4945134915058E-1/,  W(10)/6.6671344308688E-2/
      DATA Z(1) /1.3046735791414E-2/,  Z(2) /6.7468316655507E-2/,
     1     Z(3) /1.6029521585049E-1/,  Z(4) /2.8330230293538E-1/,
     2     Z(5) /4.2556283050918E-1/,  Z(6) /5.7443716949081E-1/,
     3     Z(7) /7.1669769706462E-1/,  Z(8) /8.3970478414951E-1/,
     4     Z(9) /9.3253168334449E-1/,  Z(10)/9.8695326420859E-1/
C     -------------------
C     RPINV = 1/SQRT(PI)
C     -------------------
      DATA PIHALF /1.5707963267949/
      DATA RPINV  /.56418958354776/
C     -------------------
C     ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE
C            LARGEST POSITIVE INTEGER THAT MAY BE USED.
C
                     MAX = IPMPAR(3)
C
C     -------------------
      A = A0
      B = B0
      X = X0
      Y = 0.5 + (0.5 - X)
C
C                        CHECK THE ARGUMENTS
C
      P = 0.0
      IERR = 1
      IF (A .LT. 0.5 .OR. B .LT. 0.5) GO TO 410
      IF (X .EQ. 0.0 .OR. X .EQ. 1.0) GO TO 300
      IF (X .LT. 0.0) GO TO 400
      M = MAX
      IF (A .GE. M .OR. B .GT. 70.0 .OR. Y .LT. 0.0) GO TO 411
      K = INT(A)
      J = INT(B)
      AFRAC = A - K
      BFRAC = B - J
      IF ((AFRAC .NE. 0.0 .AND. AFRAC .NE. 0.5) .OR.
     *    (BFRAC .NE. 0.0 .AND. BFRAC .NE. 0.5)) GO TO 420
      IF (A .GE. 5000.0 .AND. X .LT. 0.96) RETURN
C
C                      CHECK IF B IS AN INTEGER
C
      IND = 0
      TOL = 0.5*AMAX1(EPS, 1.E-11)
      IF (BFRAC .NE. 0.0) GO TO 100
      IF (AFRAC .NE. 0.0) GO TO 20
      IF (A .GE. B) GO TO 20
C
C                        INTERCHANGE A AND B
C
   10 IND = 1
      T = B
      B = A
      A = T
      T = Y
      Y = X
      X = T
      T = J
      J = K
      K = T
C
C                        COMPUTE EXPANSION 14
C
   20 AM1 = A - 1.0
      N = 1.0
      IF (AM1 .LT. 0.5) GO TO 30
      N = J
      IF (Y .GE. 2.0*J*X) GO TO 30
      T = AM1*Y/X + 1.0
      IF (T .LT. J) N = INT(T)
C
   30 I = N - 1.0
      C = (A*ALOG(X) + I*ALNREL(-X)) - BLND(A,I)
      IF (C .LE. -30) GO TO 60
      TOL = TOL/J
      AN = EXP(C)
      IF (AN .LE. TOL) GO TO 60
      IF (AN .GE. 1.0 - TOL) GO TO 330
C
      C = AN
      SUM = 0.0
   40 I = I + 1.0
      IF (I .GE. J) GO TO 50
      C = ((AM1 + I)/I)*Y*C
      SUM = SUM + C
      IF (C .GT. TOL) GO TO 40
C
   50 I = N
      C = AN
   51 I = I - 1.0
      IF (I .EQ. 0.0) GO TO 52
      C = I*C/((I + AM1)*Y)
      SUM = SUM + C
      IF (C .GT. TOL) GO TO 51
   52 P = AN + SUM
C
   60 IF (P .GE. 1.0) P = 1.0
      IF (IND .EQ. 0) RETURN
      P = 0.5 + (0.5 - P)
      IF (P .LT. 0.0) P = 0.0
      RETURN
C
C                SELECTION OF THE APPROPRIATE ALGORITHM
C
  100 AM1 = A - 1.0
      IF (A .GT. 70.0) GO TO 150
      IF (AFRAC .EQ. 0.0) GO TO 10
C
C                COMPUTE P0 = IX(A,1/2) OR P0 = IX(1/2,B)
C                           USING FORMULA 22
C
      TEMP = SQRT(X)
      RTY  = SQRT(Y)
      C = ATAN(TEMP/RTY)/PIHALF
      IF (K .EQ. 0.0) GO TO 130
      IND = J
      M = K + K
      TEMP = -TEMP
C
  110 I = 0.0
      T = 1.0
      SUM = 0.0
  111 I = I + 2.0
      IF (I .EQ. M) GO TO 120
      T = X*(I/(I + 1.0))*T
      SUM = T + SUM
      GO TO 111
C
  120 P0 = (SUM + 1.0)*TEMP*RTY/PIHALF + C
      IF (IND .NE. 0) GO TO 200
      P = P0
      RETURN
C
  130 IF (J .EQ. 0.0) GO TO 310
      M = J + J
      X = Y
      GO TO 110
C
C                  COMPUTE P0 = IX(A,1/2) FOR A .GT. 70
C                       USING EXPANSION 52 OR 53
C
  150 P0 = 0.0
      IF (X .LT. 0.7) GO TO 200
      T = TOL**(1.0/AM1)
      IF (X .LE. T) GO TO 200
C
      T = 0.5 + (0.5 - T)
      LAMBDA = SQRT(T)
      RTY = SQRT(Y)
      GAMRAT = RPINV*EXP(-ALGDIV(0.5,A))
      IF (T .GE. 4.0*Y) GO TO 170
C
      C = LAMBDA - RTY
      TEMP = 2.0*RTY
      SUM = 0.0
      DO 160 L = 1,10
         T = C*Z(L)
  160    SUM = SUM + W(L)*(X - T*(T + TEMP))**AM1
      P0 = C*GAMRAT*SUM + 0.5*TOL
      GO TO 200
C
  170 SUM = 0.0
      DO 171 L = 1,10
         T = 1.0 - Y*Z(L)*Z(L)
  171    SUM = SUM + W(L)*T**AM1
      P0 = 1.0 - RTY*GAMRAT*SUM
C
C                     COMPUTE P USING EXPANSION 21
C
  200 IF (J .EQ. 0.0) GO TO 251
      N = J
      IF (Y .GE. 2.0*J*X) GO TO 210
      T = AM1*Y/X + 0.5
      IF (T .GE. 2.0) GO TO 201
         N = 1.0
         GO TO 210
  201 IF (T .LT. J) N = INT(T)
C
  210 T = N - 0.5
      C = (A*ALOG(X) + T*ALNREL(-X)) - BLND(A,T)
      IF (C .LE. -30.0) GO TO 251
      C = EXP(C)
      IF (C .LE. TOL/J) GO TO 251
      IF (P0 + C .GE. 1.0 - TOL) GO TO 320
C
      TOL = TOL/J
      LAMBDA = C
      SUM = 0.0
  220 T = T + 1.0
      IF (T .GT. J) GO TO 240
      LAMBDA = (AM1 + T)*Y*LAMBDA/T
      SUM = SUM + LAMBDA
      IF (LAMBDA .GT. TOL) GO TO 220
C
  240 LAMBDA = C
      T = A - 0.5
      I = N
  241 I = I - 1.0
      IF (I .LE. 0.0) GO TO 250
      LAMBDA = ((I + 0.5)/(I + T))*LAMBDA/Y
      SUM = LAMBDA + SUM
      IF (LAMBDA .GT. TOL) GO TO 241
C
  250 P = C + SUM
  251 P = P + P0
      IF (P .GE. 1.0) P = 1.0
      RETURN
C
C                           SPECIAL CASES
C
  300 P = X
      RETURN
C
  310 P = C
      RETURN
C
  320 P = 1.0
      RETURN
C
  330 P = 1 - IND
      RETURN
C
C                           ERROR RETURN
C
  400 IERR = 2
      RETURN
C
  410 IF (A .LE. 0.0 .OR. B .LE. 0.0) GO TO 400
  411 IERR = 3
      RETURN
C
  420 IERR = 4
      RETURN
      END
      REAL FUNCTION BLND(A,B)
      REAL LOGAM
C
      IF (A .GT. 20.0) GO TO 10
         BLND = (LOGAM(A) - LOGAM(A + B)) + LOGAM(B + 1.0)
         RETURN
   10 BLND = ALGDIV(B,A) + LOGAM(B + 1.0)
      RETURN
      END
      REAL FUNCTION LOGAM (X)
      REAL W(200)
C     ------------------------------------------------------------------
C     COMPUTATION OF LN(GAMMA(X)) FOR X = N/2  WHERE N IS AN INTEGER
C     ------------------------------------------------------------------
C     D = 0.5*(LN(2*PI) - 1)
C     ---------------------
      DATA D/.41893853320467/
C     ---------------------
      DATA W(1)  /.57236494292470E+00/, W(2)  /0.0/,
     *     W(3) /-.12078223763525E+00/, W(4)  /0.0/,
     *     W(5)  /.28468287047292E+00/, W(6)  /.69314718055995E+00/,
     *     W(7)  /.12009736023471E+01/, W(8)  /.17917594692281E+01/,
     *     W(9)  /.24537365708424E+01/, W(10) /.31780538303479E+01/,
     *     W(11) /.39578139676187E+01/, W(12) /.47874917427820E+01/,
     *     W(13) /.56625620598571E+01/, W(14) /.65792512120101E+01/,
     *     W(15) /.75343642367587E+01/, W(16) /.85251613610654E+01/,
     *     W(17) /.95492672573010E+01/, W(18) /.10604602902745E+02/,
     *     W(19) /.11689333420797E+02/, W(20) /.12801827480081E+02/
      DATA W(21) /.13940625219404E+02/, W(22) /.15104412573076E+02/,
     *     W(23) /.16292000476567E+02/, W(24) /.17502307845874E+02/,
     *     W(25) /.18734347511936E+02/, W(26) /.19987214495662E+02/,
     *     W(27) /.21260076156245E+02/, W(28) /.22552163853123E+02/,
     *     W(29) /.23862765841689E+02/, W(30) /.25191221182739E+02/,
     *     W(31) /.26536914491116E+02/, W(32) /.27899271383841E+02/,
     *     W(33) /.29277754515041E+02/, W(34) /.30671860106081E+02/,
     *     W(35) /.32081114895947E+02/, W(36) /.33505073450137E+02/,
     *     W(37) /.34943315776877E+02/, W(38) /.36395445208033E+02/,
     *     W(39) /.37861086508961E+02/, W(40) /.39339884187199E+02/
      DATA W(41) /.40831500974531E+02/, W(42) /.42335616460753E+02/,
     *     W(43) /.43851925860675E+02/, W(44) /.45380138898477E+02/,
     *     W(45) /.46919978795809E+02/, W(46) /.48471181351835E+02/,
     *     W(47) /.50033494105019E+02/, W(48) /.51606675567764E+02/,
     *     W(49) /.53190494526169E+02/, W(50) /.54784729398112E+02/,
     *     W(51) /.56389167643720E+02/, W(52) /.58003605222981E+02/,
     *     W(53) /.59627846095884E+02/, W(54) /.61261701761002E+02/,
     *     W(55) /.62904990828877E+02/, W(56) /.64557538627006E+02/,
     *     W(57) /.66219176833549E+02/, W(58) /.67889743137182E+02/,
     *     W(59) /.69569080920824E+02/, W(60) /.71257038967168E+02/
      DATA W(61) /.72953471184169E+02/, W(62) /.74658236348830E+02/,
     *     W(63) /.76371197867783E+02/, W(64) /.78092223553315E+02/,
     *     W(65) /.79821185413614E+02/, W(66) /.81557959456115E+02/,
     *     W(67) /.83302425502950E+02/, W(68) /.85054467017582E+02/,
     *     W(69) /.86813970941781E+02/, W(70) /.88580827542198E+02/,
     *     W(71) /.90354930265818E+02/, W(72) /.92136175603687E+02/,
     *     W(73) /.93924462962300E+02/, W(74) /.95719694542143E+02/,
     *     W(75) /.97521775222888E+02/, W(76) /.99330612454787E+02/,
     *     W(77) /.10114611615586E+03/, W(78) /.10296819861451E+03/,
     *     W(79) /.10479677439716E+03/, W(80) /.10663176026064E+03/
      DATA W(81) /.10847307506907E+03/, W(82) /.11032063971476E+03/,
     *     W(83) /.11217437704318E+03/, W(84) /.11403421178146E+03/,
     *     W(85) /.11590007047041E+03/, W(86) /.11777188139975E+03/,
     *     W(87) /.11964957454634E+03/, W(88) /.12153308151544E+03/,
     *     W(89) /.12342233548444E+03/, W(90) /.12531727114936E+03/,
     *     W(91) /.12721782467361E+03/, W(92) /.12912393363913E+03/,
     *     W(93) /.13103553699957E+03/, W(94) /.13295257503562E+03/,
     *     W(95) /.13487498931216E+03/, W(96) /.13680272263733E+03/,
     *     W(97) /.13873571902320E+03/, W(98) /.14067392364823E+03/,
     *     W(99) /.14261728282115E+03/, W(100)/.14456574394634E+03/
      DATA W(101)/.14651925549072E+03/, W(102)/.14847776695177E+03/,
     *     W(103)/.15044122882700E+03/, W(104)/.15240959258450E+03/,
     *     W(105)/.15438281063467E+03/, W(106)/.15636083630308E+03/,
     *     W(107)/.15834362380427E+03/, W(108)/.16033112821663E+03/,
     *     W(109)/.16232330545817E+03/, W(110)/.16432011226320E+03/,
     *     W(111)/.16632150615984E+03/, W(112)/.16832744544843E+03/,
     *     W(113)/.17033788918059E+03/, W(114)/.17235279713916E+03/,
     *     W(115)/.17437212981875E+03/, W(116)/.17639584840700E+03/,
     *     W(117)/.17842391476655E+03/, W(118)/.18045629141754E+03/,
     *     W(119)/.18249294152079E+03/, W(120)/.18453382886145E+03/
      DATA W(121)/.18657891783334E+03/, W(122)/.18862817342367E+03/,
     *     W(123)/.19068156119837E+03/, W(124)/.19273904728784E+03/,
     *     W(125)/.19480059837319E+03/, W(126)/.19686618167289E+03/,
     *     W(127)/.19893576492993E+03/, W(128)/.20100931639928E+03/,
     *     W(129)/.20308680483583E+03/, W(130)/.20516819948264E+03/,
     *     W(131)/.20725347005963E+03/, W(132)/.20934258675254E+03/,
     *     W(133)/.21143552020227E+03/, W(134)/.21353224149456E+03/,
     *     W(135)/.21563272214993E+03/, W(136)/.21773693411395E+03/,
     *     W(137)/.21984484974781E+03/, W(138)/.22195644181913E+03/,
     *     W(139)/.22407168349308E+03/, W(140)/.22619054832373E+03/
      DATA W(141)/.22831301024565E+03/, W(142)/.23043904356578E+03/,
     *     W(143)/.23256862295547E+03/, W(144)/.23470172344282E+03/,
     *     W(145)/.23683832040517E+03/, W(146)/.23897838956183E+03/,
     *     W(147)/.24112190696703E+03/, W(148)/.24326884900298E+03/,
     *     W(149)/.24541919237325E+03/, W(150)/.24757291409619E+03/,
     *     W(151)/.24972999149863E+03/, W(152)/.25189040220972E+03/,
     *     W(153)/.25405412415489E+03/, W(154)/.25622113555001E+03/,
     *     W(155)/.25839141489572E+03/, W(156)/.26056494097186E+03/,
     *     W(157)/.26274169283208E+03/, W(158)/.26492164979855E+03/,
     *     W(159)/.26710479145687E+03/, W(160)/.26929109765102E+03/
      DATA W(161)/.27148054847853E+03/, W(162)/.27367312428569E+03/,
     *     W(163)/.27586880566295E+03/, W(164)/.27806757344037E+03/,
     *     W(165)/.28026940868320E+03/, W(166)/.28247429268763E+03/,
     *     W(167)/.28468220697654E+03/, W(168)/.28689313329543E+03/,
     *     W(169)/.28910705360840E+03/, W(170)/.29132395009427E+03/,
     *     W(171)/.29354380514276E+03/, W(172)/.29576660135076E+03/,
     *     W(173)/.29799232151870E+03/, W(174)/.30022094864701E+03/,
     *     W(175)/.30245246593264E+03/, W(176)/.30468685676567E+03/,
     *     W(177)/.30692410472600E+03/, W(178)/.30916419358015E+03/,
     *     W(179)/.31140710727802E+03/, W(180)/.31365282994988E+03/
      DATA W(181)/.31590134590330E+03/, W(182)/.31815263962021E+03/,
     *     W(183)/.32040669575401E+03/, W(184)/.32266349912673E+03/,
     *     W(185)/.32492303472629E+03/, W(186)/.32718528770378E+03/,
     *     W(187)/.32945024337081E+03/, W(188)/.33171788719693E+03/,
     *     W(189)/.33398820480710E+03/, W(190)/.33626118197920E+03/,
     *     W(191)/.33853680464160E+03/, W(192)/.34081505887080E+03/,
     *     W(193)/.34309593088909E+03/, W(194)/.34537940706227E+03/,
     *     W(195)/.34766547389743E+03/, W(196)/.34995411804077E+03/,
     *     W(197)/.35224532627544E+03/, W(198)/.35453908551944E+03/,
     *     W(199)/.35683538282361E+03/, W(200)/.35913420536958E+03/
C     ------------------------------------------------------------------
      IF (X .GT. 100.0) GO TO 10
         N = 2.0*X + 0.1
         LOGAM = W(N)
         RETURN
   10 T = (1.0/X)**2
      Z = (((-0.75*T + 1.0)*T - 3.5)*T + 105.0)/(X*1260.0)
      LOGAM = (D + Z) + (X - 0.5)*(ALOG(X) - 1.0)
      RETURN
      END
      SUBROUTINE CBSSLJ (Z, CNU, W)
C-----------------------------------------------------------------------
C
C         EVALUATION OF THE COMPLEX BESSEL FUNCTION J   (Z)
C                                                    CNU
C-----------------------------------------------------------------------
C
C     WRITTEN BY
C         ANDREW H. VAN TUYL AND ALFRED H. MORRIS, JR.
C         NAVAL SURFACE WARFARE CENTER
C         OCTOBER, 1991
C
C     A MODIFICATION OF THE PROCEDURE DEVELOPED BY ALLEN V. HERSHEY
C     (NAVAL SURFACE WARFARE CENTER) IN 1978 FOR HANDLING THE DEBYE
C     APPROXIMATION IS EMPLOYED.
C
C-----------------------------------------------------------------------
      COMPLEX Z, CNU, W
      COMPLEX C, NU, S, SM1, SM2, T, TSC, W0, W1, ZN, ZZ
      COMPLEX CDIV, CGAM0
C-----------------------
      DATA PI /3.14159265358979/
C-----------------------
      X = REAL(Z)
      Y = AIMAG(Z)
      R = CPABS(X,Y)
      CN1 = REAL(CNU)
      CN2 = AIMAG(CNU)
      RN2 = CN1*CN1 + CN2*CN2
      PN = AINT(CN1)
      FN = CN1 - PN
      SN = 1.0
C
C          CALCULATION WHEN ORDER IS AN INTEGER
C
      IF (FN .NE. 0.0 .OR. CN2 .NE. 0.0) GO TO 10
      N = PN
      PN = ABS(PN)
      CN1 = PN
      IF (N .LT. 0 .AND. N .NE. (N/2)*2) SN = -1.0
C
C          SELECTION OF METHOD
C
   10 IF (R .LE. 17.5) GO TO 20
      IF (R .GT. 17.5 + 0.5*RN2) GO TO 40
      GO TO 50
C
C          USE MACLAURIN EXPANSION AND RECURSION
C
   20 IF (CN1 .GE. 0.0) GO TO 30
      QN = -1.25*(R + 0.5*ABS(CN2) - ABS(Y - 0.5*CN2))
      IF (CN1 .GE. QN) GO TO 30
      QN = 1.25*(R - AMAX1(1.2*R,ABS(Y - CN2)))
      IF (CN1 .GE. QN) GO TO 30
      QN = AMIN1(PN, -AINT(1.25*(R - ABS(CN2))))
      GO TO 130
C
   30 R2 = R*R
      QM = 0.0625*R2*R2 - CN2*CN2
      QN = AMAX1(PN, AINT(SQRT(AMAX1(0.0, QM))))
      GO TO 130
C
C          USE ASYMPTOTIC EXPANSION
C
   40 CALL CBJA (Z, CNU, W)
      RETURN
C
C          CALCULATION FOR 17.5 .LT. ABS(Z) .LE. 17.5 + 0.5*ABS(CNU)**2
C
   50 N = 0
      IF (ABS(CN2) .GE. 0.8*ABS(Y)) GO TO 60
      QM = -1.25*(R + 0.5*ABS(CN2) - ABS(Y - 0.5*CN2))
      IF (CN1 .GE. QM) GO TO 60
      QM = 1.25*(R - AMAX1(1.2*R,ABS(Y - CN2)))
      IF (CN1 .LT. QM) N = 1
C
   60 QN = PN
      A = 4.E-3*R*R
      ZZ = Z
      IF (X .LT. 0.0) ZZ = -Z
C
C          CALCULATION OF ZONE OF EXCLUSION OF DEBYE APPROXIMATION
C
   70    NU = CMPLX(QN + FN, CN2)
         ZN = NU/Z
         T2 = AIMAG(ZN)*AIMAG(ZN)
         U = 1.0 - REAL(ZN)
         T1 = U*U + T2
         U = 1.0 + REAL(ZN)
         T2 = U*U + T2
         U = T1*T2
         V = A*U/(T1*T1 + T2*T2)
         IF (U*V*V .GT. 1.0) GO TO 80
C
C          THE ARGUMENT LIES INSIDE THE ZONE OF EXCLUSION
C
         QN = QN + 1.0
         IF (N .EQ. 0) GO TO 70
C
C          USE MACLAURIN EXPANSION WITH FORWARD RECURRENCE
C
      QN = AMIN1(PN, -AINT(1.25*(R - ABS(CN2))))
      GO TO 130
C
C          USE BACKWARD RECURRENCE STARTING FROM THE
C          ASYMPTOTIC EXPANSION
C
   80 QNP1 = QN + 1.0
      IF (ABS(QN) .GE. ABS(PN)) GO TO 100
      IF (R .LT. 17.5 + 0.5*(QNP1*QNP1 + CN2*CN2)) GO TO 100
C
      NU = CMPLX(QN + FN, CN2)
      CALL CBJA (ZZ, NU, SM1)
      NU = CMPLX(QNP1 + FN, CN2)
      CALL CBJA (ZZ, NU, SM2)
      GO TO 110
C
C          USE BACKWARD RECURRENCE STARTING FROM THE
C          DEBYE APPROXIMATION
C
  100 NU = CMPLX(QN + FN, CN2)
      CALL CBDB (ZZ, NU, FN, SM1)
      IF (QN .EQ. PN) GO TO 120
      NU = CMPLX(QNP1 + FN, CN2)
      CALL CBDB (ZZ, NU, FN, SM2)
C
  110    NU = CMPLX(QN + FN, CN2)
         TSC = 2.0*NU*SM1/ZZ - SM2
         SM2 = SM1
         SM1 = TSC
         QN = QN - 1.0
         IF (QN .NE. PN) GO TO 110
C
  120 W = SM1
      IF (SN .LT. 0.0) W = -W
      IF (X .GE. 0.0) RETURN
C
      NU = PI*CMPLX(-CN2, CN1)
      IF (Y .LT. 0.0) NU = -NU
      W = CEXP(NU)*W
      RETURN
C
C          USE MACLAURIN EXPANSION WITH FORWARD OR BACKWARD RECURRENCE.
C
  130 M = QN - PN
      IF (IABS(M) .GT. 1) GO TO 140
         NU = CMPLX(CN1, CN2)
         CALL CBJM (Z, NU, W)
         GO TO 180
  140 NU = CMPLX(QN + FN, CN2)
      CALL CBJM (Z, NU, W1)
      W0 = 0.25*Z*Z
      IF (M .GT. 0) GO TO 160
C
C          FORWARD RECURRENCE
C
      M = IABS(M)
      NU = NU + 1.0
      CALL CBJM (Z, NU, W)
      DO 150 I = 2,M
         C = NU*(NU + 1.0)
         T = (C/W0)*(W - W1)
         W1 = W
         W = T
         NU = NU + 1.0
  150 CONTINUE
      GO TO 180
C
C          BACKWARD RECURRENCE
C
  160 NU = NU - 1.0
      CALL CBJM (Z, NU, W)
      DO 170 I = 2,M
         C = NU*(NU + 1.0)
         T = (W0/C)*W1
         W1 = W
         W = W - T
         NU = NU - 1.0
  170 CONTINUE
C
C          FINAL ASSEMBLY
C
  180 IF (FN .NE. 0.0 .OR. CN2 .NE. 0.0) GO TO 190
         K = PN
         IF (K .EQ. 0) RETURN
         E = SN/GAMMA(PN + 1.0)
         W = E*W*(0.5*Z)**K
         RETURN
C
  190 S = CNU*CLOG(0.5*Z)
      W = CEXP(S)*W
      IF (RN2 .GT. 0.81) GO TO 200
         W = W*CGAM0(CNU)
         RETURN
  200 CALL CGAMMA(0, CNU, T)
      W = CDIV(W, CNU*T)
      RETURN
      END
      SUBROUTINE CBJM (Z, CNU, W)
C-----------------------------------------------------------------------
C
C       COMPUTATION OF  (Z/2)**(-CNU) * GAMMA(CNU + 1) * J(CNU,Z)
C
C                           -----------------
C
C     THE MACLAURIN EXPANSION IS USED. IT IS ASSUMED THAT CNU IS NOT
C     A NEGATIVE INTEGER.
C
C-----------------------------------------------------------------------
      COMPLEX CNU, NU, NUP1, P, S, SN, T, TI, W, Z
      REAL INU, M
      COMPLEX CDIV
C--------------------------
      ANORM(Z) = AMAX1(ABS(REAL(Z)),ABS(AIMAG(Z)))
C--------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 .
C
                      EPS = SPMPAR(1)
C
C--------------------------
      S = -0.25*(Z*Z)
      NU = CNU
      RNU = REAL(NU)
      INU = AIMAG(NU)
      A = 0.5 + (0.5 + RNU)
      NUP1 = CMPLX(A, INU)
C
      IF (A .LE. 0.0) GO TO 10
      M = 1.0
      T = S/NUP1
      W = 1.0 + T
      GO TO 70
C
C     ADD 1.0 AND THE FIRST K-1 TERMS
C
   10 K = INT(-A) + 2
      KM1 = K - 1
      W = (1.0, 0.0)
      T = W
      DO 20 I = 1,KM1
         M = I
         T = T*(S/(M*(NU + M)))
         W = W + T
         IF (ANORM(T) .LE. EPS*ANORM(W)) GO TO 30
   20 CONTINUE
      GO TO 70
C
C     CHECK IF THE (K-1)-ST AND K-TH TERMS CAN BE IGNORED.
C     IF SO THEN THE SUMMATION IS COMPLETE.
C
   30 IF (I .EQ. KM1) GO TO 70
      IMIN = I + 1
      IF (IMIN .GE. K - 5) GO TO 50
      TI = T
C
      M = KM1
      T = S/(NU + M)
      A0 = ANORM(T)/M
      T = T * (S/(NU + (M + 1.0)))
      A = ANORM(T)/(M*(M + 1.0))
      A = AMAX1(A, A0)
C
      T = (1.0, 0.0)
      KM2 = K - 2
      DO 40 I = IMIN,KM2
         M = I
         T = T*(S/(M*(NU + M)))
         IF (A*ANORM(T) .LT. 0.5) RETURN
   40 CONTINUE
      T = T*TI
      IMIN = KM2
C
C     ADD THE (K-1)-ST TERM
C
   50 A = 1.0
      P = (1.0, 0.0)
      SN = P
      DO 60 I = IMIN,KM1
         M = I
         A = A*M
         P = P*(NU + M)
         SN = S*SN
   60 CONTINUE
      T = T*(CDIV(SN,P)/A)
      W = W + T
C
C     ADD THE REMAINING TERMS
C
   70 M = M + 1.0
      T = T*(S/(M*(NU + M)))
      W = W + T
      IF (ANORM(T) .GT. EPS*ANORM(W)) GO TO 70
C
      RETURN
      END
      SUBROUTINE CBDB (CZ, CNU, FN, W)
C-----------------------------------------------------------------------
C
C         CALCULATION OF J   (CZ) BY THE DEBYE APPROXIMATION
C                         CNU
C                         ------------------
C
C     IT IS ASSUMED THAT REAL(CZ) .GE. 0 AND THAT REAL(CNU) = FN + K
C     WHERE K IS AN INTEGER.
C
C-----------------------------------------------------------------------
      COMPLEX CZ, CNU, W
      REAL A(136), IS, INU, IZN
      COMPLEX C1, C2, ETA, J, NU, P, P1, Q, R, S, S1, S2, SM, T, Z, ZN
C----------------------
C     C = 1/SQRT(2*PI)
C     BND = PI/3
C----------------------
      DATA J   /(0.0, 1.0)/
      DATA C   /.398942280401433/
      DATA PI  /3.14159265358979/
      DATA PI2 /6.28318530717959/
      DATA BND /1.04719755119660/
C----------------------
C
C             COEFFICIENTS OF THE FIRST 16 POLYNOMIALS
C                   IN THE DEBYE APPROXIMATION
C
C
      DATA A(1)  /1.0/
      DATA A(2)  /-.208333333333333E+00/, A(3)  / .125000000000000E+00/
      DATA A(4)  / .334201388888889E+00/, A(5)  /-.401041666666667E+00/,
     *     A(6)  / .703125000000000E-01/
      DATA A(7)  /-.102581259645062E+01/, A(8)  / .184646267361111E+01/,
     *     A(9)  /-.891210937500000E+00/, A(10) / .732421875000000E-01/
      DATA A(11) / .466958442342625E+01/, A(12) /-.112070026162230E+02/,
     *     A(13) / .878912353515625E+01/, A(14) /-.236408691406250E+01/,
     *     A(15) / .112152099609375E+00/
      DATA A(16) /-.282120725582002E+02/, A(17) / .846362176746007E+02/,
     *     A(18) /-.918182415432400E+02/, A(19) / .425349987453885E+02/,
     *     A(20) /-.736879435947963E+01/, A(21) / .227108001708984E+00/
      DATA A(22) / .212570130039217E+03/, A(23) /-.765252468141182E+03/,
     *     A(24) / .105999045252800E+04/, A(25) /-.699579627376133E+03/,
     *     A(26) / .218190511744212E+03/, A(27) /-.264914304869516E+02/,
     *     A(28) / .572501420974731E+00/
      DATA A(29) /-.191945766231841E+04/, A(30) / .806172218173731E+04/,
     *     A(31) /-.135865500064341E+05/, A(32) / .116553933368645E+05/,
     *     A(33) /-.530564697861340E+04/, A(34) / .120090291321635E+04/,
     *     A(35) /-.108090919788395E+03/, A(36) / .172772750258446E+01/
      DATA A(37) / .202042913309661E+05/, A(38) /-.969805983886375E+05/,
     *     A(39) / .192547001232532E+06/, A(40) /-.203400177280416E+06/,
     *     A(41) / .122200464983017E+06/, A(42) /-.411926549688976E+05/,
     *     A(43) / .710951430248936E+04/, A(44) /-.493915304773088E+03/,
     *     A(45) / .607404200127348E+01/
      DATA A(46) /-.242919187900551E+06/, A(47) / .131176361466298E+07/,
     *     A(48) /-.299801591853811E+07/, A(49) / .376327129765640E+07/,
     *     A(50) /-.281356322658653E+07/, A(51) / .126836527332162E+07/,
     *     A(52) /-.331645172484564E+06/, A(53) / .452187689813627E+05/,
     *     A(54) /-.249983048181121E+04/, A(55) / .243805296995561E+02/
      DATA A(56) / .328446985307204E+07/, A(57) /-.197068191184322E+08/,
     *     A(58) / .509526024926646E+08/, A(59) /-.741051482115327E+08/,
     *     A(60) / .663445122747290E+08/, A(61) /-.375671766607634E+08/,
     *     A(62) / .132887671664218E+08/, A(63) /-.278561812808645E+07/,
     *     A(64) / .308186404612662E+06/, A(65) /-.138860897537170E+05/,
     *     A(66) / .110017140269247E+03/
      DATA A(67) /-.493292536645100E+08/, A(68) / .325573074185766E+09/,
     *     A(69) /-.939462359681578E+09/, A(70) / .155359689957058E+10/,
     *     A(71) /-.162108055210834E+10/, A(72) / .110684281682301E+10/,
     *     A(73) /-.495889784275030E+09/, A(74) / .142062907797533E+09/,
     *     A(75) /-.244740627257387E+08/, A(76) / .224376817792245E+07/,
     *     A(77) /-.840054336030241E+05/, A(78) / .551335896122021E+03/
      DATA A(79) / .814789096118312E+09/, A(80) /-.586648149205185E+10/,
     *     A(81) / .186882075092958E+11/, A(82) /-.346320433881588E+11/,
     *     A(83) / .412801855797540E+11/, A(84) /-.330265997498007E+11/,
     *     A(85) / .179542137311556E+11/, A(86) /-.656329379261928E+10/,
     *     A(87) / .155927986487926E+10/, A(88) /-.225105661889415E+09/,
     *     A(89) / .173951075539782E+08/, A(90) /-.549842327572289E+06/,
     *     A(91) / .303809051092238E+04/
      DATA A(92) /-.146792612476956E+11/, A(93) / .114498237732026E+12/,
     *     A(94) /-.399096175224466E+12/, A(95) / .819218669548577E+12/,
     *     A(96) /-.109837515608122E+13/, A(97) / .100815810686538E+13/,
     *     A(98) /-.645364869245377E+12/, A(99) / .287900649906151E+12/,
     *     A(100)/-.878670721780233E+11/, A(101)/ .176347306068350E+11/,
     *     A(102)/-.216716498322380E+10/, A(103)/ .143157876718889E+09/,
     *     A(104)/-.387183344257261E+07/, A(105)/ .182577554742932E+05/
      DATA A(106)/ .286464035717679E+12/, A(107)/-.240629790002850E+13/,
     *     A(108)/ .910934118523990E+13/, A(109)/-.205168994109344E+14/,
     *     A(110)/ .305651255199353E+14/, A(111)/-.316670885847852E+14/,
     *     A(112)/ .233483640445818E+14/, A(113)/-.123204913055983E+14/,
     *     A(114)/ .461272578084913E+13/, A(115)/-.119655288019618E+13/,
     *     A(116)/ .205914503232410E+12/, A(117)/-.218229277575292E+11/,
     *     A(118)/ .124700929351271E+10/, A(119)/-.291883881222208E+08/,
     *     A(120)/ .118838426256783E+06/
      DATA A(121)/-.601972341723401E+13/, A(122)/ .541775107551060E+14/,
     *     A(123)/-.221349638702525E+15/, A(124)/ .542739664987660E+15/,
     *     A(125)/-.889496939881026E+15/, A(126)/ .102695519608276E+16/,
     *     A(127)/-.857461032982895E+15/, A(128)/ .523054882578445E+15/,
     *     A(129)/-.232604831188940E+15/, A(130)/ .743731229086791E+14/,
     *     A(131)/-.166348247248925E+14/, A(132)/ .248500092803409E+13/,
     *     A(133)/-.229619372968246E+12/, A(134)/ .114657548994482E+11/,
     *     A(135)/-.234557963522252E+09/, A(136)/ .832859304016289E+06/
C----------------------
      Z = CZ
      NU = CNU
      INU = AIMAG(CNU)
      IF (INU .GE. 0.0) GO TO 10
         Z = CONJG(Z)
         NU = CONJG(NU)
   10 X = REAL(Z)
      Y = AIMAG(Z)
C
C          TANH(GAMMA) = SQRT(1 - (Z/NU)**2) = W/NU
C          T = EXP(NU*(TANH(GAMMA) - GAMMA))
C
      ZN = Z/NU
      IZN = AIMAG(ZN)
      IF (ABS(IZN) .GT. 0.1*ABS(REAL(ZN))) GO TO 20
C
         S = (1.0 - ZN)*(1.0 + ZN)
         ETA = 1.0/S
         Q = CSQRT(S)
         S = 1.0/(NU*Q)
         T = ZN/(1.0 + Q)
         T = CEXP(NU*(Q + CLOG(T)))
         GO TO 30
C
   20 S = (NU - Z)*(NU + Z)
      ETA = (NU*NU)/S
      W = CSQRT(S)
      Q = W/NU
      IF (REAL(Q) .LT. 0.0) W = -W
      S = 1.0/W
      T = Z/(NU + W)
      T = CEXP(W + NU*CLOG(T))
C
   30 IS = AIMAG(S)
      R = CSQRT(S)
      C1 = R*T
      AR = REAL(R)*REAL(R) + AIMAG(R)*AIMAG(R)
      AQ = -1.0/(REAL(Q)*REAL(Q) + AIMAG(Q)*AIMAG(Q))
C
      PHI = ATAN2(Y,X)/3.0
      Q = NU - Z
      THETA = ATAN2(AIMAG(Q),REAL(Q)) - PHI
      IND = 0
      IF (ABS(THETA) .LT. 2.0*BND) GO TO 50
C
      IND = 1
      CALL CREC(REAL(T), AIMAG(T), U, V)
      C2 = -J*R*CMPLX(U, V)
      IF (IS .LT. 0.0) GO TO 40
         IF (IS .GT. 0.0) GO TO 50
         IF (REAL(S) .LE. 0.0) GO TO 50
   40 C2 = -C2
C
C          SUMMATION OF THE SERIES S1 AND S2
C
   50 SM = S*S
      P  = (A(2)*ETA + A(3))*S
      P1 = ((A(4)*ETA + A(5))*ETA + A(6))*SM
      S1 = (1.0 + P) + P1
      IF (IND .NE. 0) S2 = (1.0 - P) + P1
      SGN = 1.0
      AM = AR*AR
      M = 4
      L = 6
C
C          P = VALUE OF THE M-TH POLYNOMIAL
C
   60 L = L + 1
      ALPHA = A(L)
      P = CMPLX(A(L),0.0)
      DO 70 K = 2,M
         L = L + 1
         ALPHA = A(L) + AQ*ALPHA
         P = A(L) + ETA*P
   70 CONTINUE
C
C          ONLY THE S1 SUM IS FORMED WHEN IND = 0
C
      SM = S*SM
      P = P*SM
      S1 = S1 + P
      IF (IND .EQ. 0) GO TO 80
         SGN = -SGN
         S2 = S2 + SGN*P
   80 AM = AR*AM
      IF (1.0 + ALPHA*AM .EQ. 1.0) GO TO 100
      M = M + 1
      IF (M .LE. 16) GO TO 60
C
C          FINAL ASSEMBLY
C
  100 S1 = C*C1*S1
      IF (IND .NE. 0) GO TO 110
         W = S1
         GO TO 200
C
  110 S2 = C*C2*S2
      Q = NU + Z
      THETA = ATAN2(AIMAG(Q),REAL(Q)) - PHI
      IF (ABS(THETA) .GT. BND) GO TO 120
         W = S1 + S2
         GO TO 200
C
  120 ALPHA = PI2
      IF (IZN .LT. 0.0) ALPHA = -ALPHA
      T = ALPHA*CMPLX(ABS(INU), -FN)
      ALPHA = EXP(REAL(T))
      U = AIMAG(T)
      R = CMPLX(COS(U),SIN(U))
      T = S1 - (ALPHA*R)*S1
      IF (X .EQ. 0.0 .AND. INU .EQ. 0.0) T = -T
C
      IF (Y .GE. 0.0) GO TO 170
      IF (IZN .GE. 0.0 .AND. THETA .LE. SIGN(PI,THETA))
     *             S2 = S2*(CONJG(R)/ALPHA)
      IF (X .EQ. 0.0) GO TO 180
      IF (IZN .LT. 0.0) GO TO 170
      IF (IS .LT. 0.0) GO TO 180
C
  170 W = S2 + T
      GO TO 200
  180 W = S2 - T
C
  200 IF (INU .LT. 0.0) W = CONJG(W)
      RETURN
      END
      SUBROUTINE CBJA (CZ, CNU, W)
C-----------------------------------------------------------------------
C        COMPUTATION OF J(NU,Z) BY THE ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      COMPLEX CZ, CNU, W
      REAL INU, M
      COMPLEX A, A1, ARG, E, ETA, J, NU, P, Q, T, Z, ZR, ZZ
C--------------------------
      ANORM(Z) = AMAX1(ABS(REAL(Z)), ABS(AIMAG(Z)))
C--------------------------
C     PIHALF = PI/2
C     C = 2*PI**(-1/2)
C--------------------------
      DATA PIHALF /1.5707963267949/
      DATA C /1.12837916709551/
      DATA J /(0.0, 1.0)/
C--------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 .
C
                      EPS = SPMPAR(1)
C
C--------------------------
      Z = CZ
      X = REAL(Z)
      Y = AIMAG(Z)
      NU = CNU
      IND = 0
      IF (ABS(X) .GT. 1.E-2*ABS(Y)) GO TO 10
      IF (AIMAG(NU) .GE. 0.0 .OR. ABS(REAL(NU)) .GE.
     *            1.E-2*ABS(AIMAG(NU))) GO TO 10
         IND = 1
         NU = CONJG(NU)
         Z = CONJG(Z)
         Y = -Y
C
   10 IF (X .LT. -1.E-2*Y) Z = -Z
      ZZ = Z + Z
      CALL CREC (REAL(ZZ), AIMAG(ZZ), U, V)
      ZR = CMPLX(U, V)
      ETA = -ZR*ZR
C
      P = (0.0,0.0)
      Q = (0.0,0.0)
      A1 = NU*NU - 0.25
      A = A1
      T = A1
      M = 1.0
      TOL = EPS*ANORM(A1)
      DO 20 I = 1,16
         A = A - 2.0*M
         M = M + 1.0
         T = T*A*ETA/M
         P = P + T
         A = A - 2.0*M
         M = M + 1.0
         T = T*A/M
         Q = Q + T
         IF (ANORM(T) .LE. TOL) GO TO 30
   20 CONTINUE
C
   30 P = P + 1.0
      Q = (Q + A1)*ZR
      W = Z - PIHALF*NU
      IF (ABS(AIMAG(W)) .GT. 1.0) GO TO 40
         ARG = W - 0.5*PIHALF
         W = C*CSQRT(ZR)*(P*CCOS(ARG) - Q*CSIN(ARG))
         GO TO 50
   40 E = CEXP(-J*W)
      T = Q - J*P
      IF (AIMAG(Z) .GT. 0.0 .AND. REAL(Z) .LE. 1.E-2*AIMAG(Z) .AND.
     *    ABS(REAL(NU)) .LT. 1.E-2*AIMAG(NU)) T = 0.5*T
      CALL CREC(REAL(E), AIMAG(E), U, V)
      W = 0.5*C*CSQRT(J*ZR)*((P - J*Q)*E + T*CMPLX(U, V))
C
   50 IF (X .GE. -1.E-2*Y) GO TO 60
      IF (Y .LT. 0.0) NU = -NU
C
C     COMPUTATION OF EXP(I*PI*NU)
C
      RNU = REAL(NU)
      INU = AIMAG(NU)
      R = EXP(-2.0*PIHALF*INU)
      U = R*COS1(RNU)
      V = R*SIN1(RNU)
      W = W*CMPLX(U,V)
C
   60 IF (IND .NE. 0) W = CONJG(W)
      RETURN
      END
      SUBROUTINE BSSLJ (A, IN, W)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR ORDINARY BESSEL FUNCTION OF INTEGRAL ORDER
C     ******************************************************************
C     A  = ARGUMENT (COMPLEX NUMBER)
C     IN = ORDER (INTEGER)
C     W  = FUNCTION OF FIRST KIND (COMPLEX NUMBER)
C     -------------------
      COMPLEX A, W
      DIMENSION AZ(2), FJ(2)
      DIMENSION CD(30), CE(30)
      DIMENSION QZ(2), RZ(2), SZ(2), ZR(2)
      DIMENSION TS(2), TM(2), RM(4), SM(4), AQ(2), QF(2)
      DATA CD(1) / 0.00000000000000E00/,  CD(2) /-1.64899505142212E-2/,
     1     CD(3) /-7.18621880068536E-2/,  CD(4) /-1.67086878124866E-1/,
     2     CD(5) /-3.02582250219469E-1/,  CD(6) /-4.80613945245927E-1/,
     3     CD(7) /-7.07075239357898E-1/,  CD(8) /-9.92995790539516E-1/,
     4     CD(9) /-1.35583925612592E00/,  CD(10)/-1.82105907899132E00/,
     5     CD(11)/-2.42482175310879E00/,  CD(12)/-3.21956655708750E00/,
     6     CD(13)/-4.28658077248384E00/,  CD(14)/-5.77022816798128E00/,
     7     CD(15)/-8.01371260952526E00/
      DATA CD(16)/ 0.00000000000000E00/,  CD(17)/-5.57742429879505E-3/,
     1     CD(18)/-4.99112944172476E-2/,  CD(19)/-1.37440911652397E-1/,
     2     CD(20)/-2.67233784710566E-1/,  CD(21)/-4.40380166808682E-1/,
     3     CD(22)/-6.61813614872541E-1/,  CD(23)/-9.41861077665017E-1/,
     4     CD(24)/-1.29754130468326E00/,  CD(25)/-1.75407696719816E00/,
     5     CD(26)/-2.34755299882276E00/,  CD(27)/-3.13041332689196E00/,
     6     CD(28)/-4.18397120563729E00/,  CD(29)/-5.65251799214994E00/,
     7     CD(30)/-7.87863959810677E00/
      DATA CE(1) / 0.00000000000000E00/,  CE(2) /-4.80942336387447E-3/,
     1     CE(3) /-1.31366200347759E-2/,  CE(4) /-1.94843834008458E-2/,
     2     CE(5) /-2.19948900032003E-2/,  CE(6) /-2.09396625676519E-2/,
     3     CE(7) /-1.74600268458650E-2/,  CE(8) /-1.27937813362085E-2/,
     4     CE(9) /-8.05234421796592E-3/,  CE(10)/-4.15817375002760E-3/,
     5     CE(11)/-1.64317738747922E-3/,  CE(12)/-4.49175585314709E-4/,
     6     CE(13)/-7.28594765574007E-5/,  CE(14)/-5.38265230658285E-6/,
     7     CE(15)/-9.93779048036289E-8/
      DATA CE(16)/ 0.00000000000000E00/,  CE(17)/ 7.53805779200591E-2/,
     1     CE(18)/ 7.12293537403464E-2/,  CE(19)/ 6.33116224228200E-2/,
     2     CE(20)/ 5.28240264523301E-2/,  CE(21)/ 4.13305359441492E-2/,
     3     CE(22)/ 3.01350573947510E-2/,  CE(23)/ 2.01043439592720E-2/,
     4     CE(24)/ 1.18552223068074E-2/,  CE(25)/ 5.86055510956010E-3/,
     5     CE(26)/ 2.25465148267325E-3/,  CE(27)/ 6.08173041536336E-4/,
     6     CE(28)/ 9.84215550625747E-5/,  CE(29)/ 7.32139093038089E-6/,
     7     CE(30)/ 1.37279667384666E-7/
C     -------------------
      AZ(1)=REAL(A)
      AZ(2)=AIMAG(A)
      ZS=AZ(1)*AZ(1)+AZ(2)*AZ(2)
      ZM=SQRT(ZS)
      PN=IABS(IN)
      SN=+1.0
      IF(IN)002,003,003
  002 IF(IN.EQ.IN/2*2)GO TO 003
      SN=-1.0
  003 IF(AZ(1))004,005,005
  004 QZ(1)=-AZ(1)
      QZ(2)=-AZ(2)
      IF(IN.EQ.IN/2*2)GO TO 006
      SN=-SN
      GO TO 006
  005 QZ(1)=+AZ(1)
      QZ(2)=+AZ(2)
  006 IF(ZM.LE.17.5+0.5*PN*PN)GO TO 007
      QN=PN
      GO TO 013
  007 QN=0.5*ZM-0.5*ABS(QZ(2))+0.5*ABS(0.5*ZM-ABS(QZ(2)))
      IF(PN.LE.QN)GO TO 008
      QN=+AINT(0.0625*ZS)
      IF(PN.LE.QN)GO TO 031
      QN=PN
      GO TO 031
  008 IF(ZM.LE.17.5)GO TO 009
      QN=+AINT(SQRT(2.0*(ZM-17.5)))
      GO TO 013
  009 IF(ZS-1.0)011,010,010
  010 IF(-ABS(AZ(2))+0.096*AZ(1)*AZ(1))011,012,012
  011 QN=+AINT(0.0625*ZS)
      IF(PN.LE.QN)GO TO 031
      QN=PN
      GO TO 031
  012 QN=0.0
  013 SZ(1)=QZ(1)
      SZ(2)=QZ(2)
      QM=SN*0.797884560802865
      ZR(1)=SQRT(SZ(1)+ZM)
      ZR(2)=SZ(2)/ZR(1)
      ZR(1)=0.707106781186548*ZR(1)
      ZR(2)=0.707106781186548*ZR(2)
      QF(1)=+QM*ZR(1)/ZM
      QF(2)=-QM*ZR(2)/ZM
      IF(ZM.LE.17.5)GO TO 018
  014 RZ(1)=+0.5*QZ(1)/ZS
      RZ(2)=-0.5*QZ(2)/ZS
      AN=QN*QN-0.25
      SM(1)=0.0
      SM(2)=0.0
      SM(3)=0.0
      SM(4)=0.0
      TM(1)=1.0
      TM(2)=0.0
      PM=0.0
      GO TO 016
  015 AN=AN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=-AN*TS(1)/PM
      TM(2)=-AN*TS(2)/PM
  016 SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      AN=AN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=+AN*TS(1)/PM
      TM(2)=+AN*TS(2)/PM
      IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 017
      IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 020
  017 SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
      IF(PM.LT.35.0)GO TO 015
      GO TO 020
  018 SM(1)=1.0
      SM(2)=0.0
      SM(3)=1.0
      SM(4)=0.0
      M=15.0*QN+2.0
      N=15.0*QN+15.0
      DO 019 I=M,N
      TS(1)=+QZ(2)-CD(I)
      TS(2)=-QZ(1)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      TS(1)=-QZ(2)-CD(I)
      TS(2)=+QZ(1)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
  019 CONTINUE
      TS(1)=+0.5*(SM(2)-SM(4))
      TS(2)=-0.5*(SM(1)-SM(3))
      SM(1)=+0.5*(SM(1)+SM(3))
      SM(2)=+0.5*(SM(2)+SM(4))
      SM(3)=TS(1)
      SM(4)=TS(2)
  020 AQ(1)=QZ(1)-1.57079632679490*(QN+0.5)
      AQ(2)=QZ(2)
      TS(1)=+COS(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2)))
      TS(2)=-SIN(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2)))
      TM(1)=SM(1)*TS(1)-SM(2)*TS(2)
      TM(2)=SM(1)*TS(2)+SM(2)*TS(1)
      TS(1)=+SIN(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2)))
      TS(2)=+COS(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2)))
      RM(1)=TM(1)-SM(3)*TS(1)+SM(4)*TS(2)
      RM(2)=TM(2)-SM(3)*TS(2)-SM(4)*TS(1)
      IF(QN.EQ.PN)GO TO 030
      RM(3)=RM(1)
      RM(4)=RM(2)
      QN=QN+1.0
      IF(ZM.LE.17.5)GO TO 025
  021 AN=QN*QN-0.25
      SM(1)=0.0
      SM(2)=0.0
      SM(3)=0.0
      SM(4)=0.0
      TM(1)=1.0
      TM(2)=0.0
      PM=0.0
      GO TO 023
  022 AN=AN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=-AN*TS(1)/PM
      TM(2)=-AN*TS(2)/PM
  023 SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      AN=AN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=+AN*TS(1)/PM
      TM(2)=+AN*TS(2)/PM
      IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 024
      IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 027
  024 SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
      IF(PM.LT.35.0)GO TO 022
      GO TO 027
  025 SM(1)=1.0
      SM(2)=0.0
      SM(3)=1.0
      SM(4)=0.0
      M=15.0*QN+2.0
      N=15.0*QN+15.0
      DO 026 I=M,N
      TS(1)=+QZ(2)-CD(I)
      TS(2)=-QZ(1)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      TS(1)=-QZ(2)-CD(I)
      TS(2)=+QZ(1)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
  026 CONTINUE
      TS(1)=+0.5*(SM(2)-SM(4))
      TS(2)=-0.5*(SM(1)-SM(3))
      SM(1)=+0.5*(SM(1)+SM(3))
      SM(2)=+0.5*(SM(2)+SM(4))
      SM(3)=TS(1)
      SM(4)=TS(2)
  027 AQ(1)=QZ(1)-1.57079632679490*(QN+0.5)
      AQ(2)=QZ(2)
      TS(1)=+COS(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2)))
      TS(2)=-SIN(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2)))
      TM(1)=SM(1)*TS(1)-SM(2)*TS(2)
      TM(2)=SM(1)*TS(2)+SM(2)*TS(1)
      TS(1)=+SIN(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2)))
      TS(2)=+COS(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2)))
      RM(1)=TM(1)-SM(3)*TS(1)+SM(4)*TS(2)
      RM(2)=TM(2)-SM(3)*TS(2)-SM(4)*TS(1)
      GO TO 029
  028 TM(1)=+2.0*QN*QZ(1)/ZS
      TM(2)=-2.0*QN*QZ(2)/ZS
      TS(1)=TM(1)*RM(1)-TM(2)*RM(2)-RM(3)
      TS(2)=TM(1)*RM(2)+TM(2)*RM(1)-RM(4)
      RM(3)=RM(1)
      RM(4)=RM(2)
      RM(1)=TS(1)
      RM(2)=TS(2)
      QN=QN+1.0
  029 IF(QN.LT.PN)GO TO 028
  030 FJ(1)=QF(1)*RM(1)-QF(2)*RM(2)
      FJ(2)=QF(1)*RM(2)+QF(2)*RM(1)
      W=CMPLX(FJ(1),FJ(2))
      RETURN
  031 SZ(1)=+0.25*(QZ(1)*QZ(1)-QZ(2)*QZ(2))
      SZ(2)=+0.5*QZ(1)*QZ(2)
      AN=QN
      SM(1)=0.0
      SM(2)=0.0
      SM(3)=0.0
      SM(4)=0.0
      TM(1)=1.0
      TM(2)=0.0
      PM=0.0
  032 AN=AN+1.0
      TS(1)=+TM(1)/AN
      TS(2)=+TM(2)/AN
      SM(3)=SM(3)+TS(1)
      SM(4)=SM(4)+TS(2)
      TM(1)=-TS(1)*SZ(1)+TS(2)*SZ(2)
      TM(2)=-TS(1)*SZ(2)-TS(2)*SZ(1)
      PM=PM+1.0
      TM(1)=TM(1)/PM
      TM(2)=TM(2)/PM
      IF(ABS(SM(1))+ABS(TM(1)).NE.ABS(SM(1)))GO TO 033
      IF(ABS(SM(2))+ABS(TM(2)).EQ.ABS(SM(2)))GO TO 034
  033 SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      GO TO 032
  034 SM(1)=SM(1)+1.0
      AN=QN+1.0
      SM(3)=AN*SM(3)
      SM(4)=AN*SM(4)
      GO TO 036
  035 AN=QN*(QN+1.0)
      TM(1)=SZ(1)/AN
      TM(2)=SZ(2)/AN
      TS(1)=-TM(1)*SM(3)+TM(2)*SM(4)
      TS(2)=-TM(1)*SM(4)-TM(2)*SM(3)
      SM(3)=SM(1)
      SM(4)=SM(2)
      SM(1)=SM(1)+TS(1)
      SM(2)=SM(2)+TS(2)
      QN=QN-1.0
  036 IF(QN.GT.PN)GO TO 035
      QF(1)=SN
      QF(2)=0.0
      QN=0.0
      GO TO 038
  037 QN=QN+1.0
      TM(1)=QF(1)*QZ(1)-QF(2)*QZ(2)
      TM(2)=QF(1)*QZ(2)+QF(2)*QZ(1)
      QF(1)=0.5*TM(1)/QN
      QF(2)=0.5*TM(2)/QN
  038 IF(QN.LT.PN)GO TO 037
      FJ(1)=QF(1)*SM(1)-QF(2)*SM(2)
      FJ(2)=QF(1)*SM(2)+QF(2)*SM(1)
      W=CMPLX(FJ(1),FJ(2))
      RETURN
      END
      SUBROUTINE BESJ(X, ALPHA, N, Y, NZ)
C
C     WRITTEN BY D.E. AMOS, S.L. DANIEL AND M.K. WESTON, JANUARY, 1975.
C
C     REFERENCES
C         SAND-75-0147
C
C         CDC 6600 SUBROUTINES IBESS AND JBESS FOR BESSEL FUNCTIONS
C         I(NU,X) AND J(NU,X), X.GE.0, NU.GE.0  BY D.E. AMOS, S.L.
C         DANIEL, M.K. WESTON. ACM TRANS MATH SOFTWARE,3,PP 76-92
C         (1977)
C
C         TABLES OF BESSEL FUNCTIONS OF MODERATE OR LARGE ORDERS,
C         NPL MATHEMATICAL TABLES, VOL. 6, BY F.W.J. OLVER, HER
C         MAJESTY-S STATIONERY OFFICE, LONDON, 1962.
C
C     ABSTRACT
C         BESJ COMPUTES AN N MEMBER SEQUENCE OF J BESSEL FUNCTIONS
C         J/SUB(ALPHA+K-1)/(X), K=1,...,N FOR NON-NEGATIVE ALPHA AND X.
C         A COMBINATION OF THE POWER SERIES, THE ASYMPTOTIC EXPANSION
C         FOR X TO INFINITY AND THE UNIFORM ASYMPTOTIC EXPANSION FOR
C         NU TO INFINITY ARE APPLIED OVER SUBDIVISIONS OF THE (NU,X)
C         PLANE. FOR VALUES OF (NU,X) NOT COVERED BY ONE OF THESE
C         FORMULAE, THE ORDER IS INCREMENTED OR DECREMENTED BY INTEGER
C         VALUES INTO A REGION WHERE ONE OF THE FORMULAE APPLY. BACKWARD
C         RECURSION IS APPLIED TO REDUCE ORDERS BY INTEGER VALUES EXCEPT
C         WHERE THE ENTIRE SEQUENCE LIES IN THE OSCILLATORY REGION. IN
C         THIS CASE FORWARD RECURSION IS STABLE AND VALUES FROM THE
C         ASYMPTOTIC EXPANSION FOR X TO INFINITY START THE RECURSION
C         WHEN IT IS EFFICIENT TO DO SO. LEADING TERMS OF THE SERIES AND
C         UNIFORM EXPANSION ARE TESTED FOR UNDERFLOW. IF A SEQUENCE IS
C         REQUESTED AND THE LAST MEMBER WOULD UNDERFLOW, THE RESULT IS
C         SET TO ZERO AND THE NEXT LOWER ORDER TRIED, ETC., UNTIL A
C         MEMBER COMES ON SCALE OR ALL MEMBERS ARE SET TO ZERO. OVERFLOW
C         CANNOT OCCUR.
C
C         BESJ CALLS ASJY, JAIRY, GAMLN, SPMPAR, AND IPMPAR
C
C     DESCRIPTION OF ARGUMENTS
C
C         INPUT
C           X      - X.GE.0.0E0
C           ALPHA  - ORDER OF FIRST MEMBER OF THE SEQUENCE,
C                    ALPHA.GE.0.0E0
C           N      - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1
C
C         OUTPUT
C           Y      - A VECTOR WHOSE FIRST N COMPONENTS CONTAIN
C                    VALUES FOR J/SUB(ALPHA+K-1)/(X), K=1,...,N
C           NZ     - ERROR INDICATOR
C                    NZ=0      NORMAL RETURN - COMPUTATION COMPLETED
C                    NZ=-1     X IS LESS THAN 0.0
C                    NZ=-2     ALPHA IS LESS THAN 0.0
C                    NZ=-3     N IS LESS THAN 1
C                    NZ.GT.0   LAST NZ COMPONENTS OF Y SET TO 0.0
C                              BECAUSE OF UNDERFLOW
C
C     ERROR CONDITIONS
C         IMPROPER INPUT ARGUMENTS - A FATAL ERROR
C         UNDERFLOW  - A NON-FATAL ERROR (NZ.GT.0)
C
      EXTERNAL JAIRY
      INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN,
     1        NS,NZ
      INTEGER IPMPAR
      REAL       AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG,
     1           ELIM,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM,
     2           GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN,
     3           S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL,
     4           TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y
      REAL GAMLN, SPMPAR
      DIMENSION Y(N), TEMP(3), FNULIM(2), PP(4), WK(7)
      DATA RTWO,PDF,RTTP,PIDT                    / 1.34839972492648E+00,
     1 7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/
      DATA  PP(1),  PP(2),  PP(3),  PP(4)        / 8.72909153935547E+00,
     1 2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/
      DATA INLIM           /      150            /
      DATA FNULIM(1), FNULIM(2) /      100.0E0,     60.0E0     /
C     -------------------
C     IPMPAR(8) REPLACES IPMPAR(5) IN A DOUBLE PRECISION CODE
C     IPMPAR(9) REPLACES IPMPAR(6) IN A DOUBLE PRECISION CODE
C
C     DEFINITION OF THE TOLERANCES TOL AND ELIM
C
      TB = IPMPAR(4)
      TA = SPMPAR(1)/TB
      IF (TB.EQ.2.0E0) GO TO 1
      IF (TB.EQ.8.0E0) GO TO 2
      IF (TB.EQ.16.0E0) GO TO 3
      TB = ALOG(TB)
      GO TO 5
    1 TB = .69315E0
      GO TO 5
    2 TB = 2.07944E0
      GO TO 5
    3 TB = 2.77259E0
C
    5 TOL = AMAX1(TA,1.E-15)
      I1 = IPMPAR(5)
      I2 = IPMPAR(6)
C     LN(10**3) = 6.90776
      ELIM = FLOAT(-I2)*TB - 6.90776E0
C     TOLLN = -LN(TOL)
      TOLLN = FLOAT(I1)*TB
      TOLLN = AMIN1(TOLLN,34.5388E0)
C
C
C
      NZ = 0
      KT = 1
      IF (N-1) 720, 10, 20
   10 KT = 2
   20 NN = N
      IF (X) 730, 30, 80
   30 IF (ALPHA) 710, 40, 50
   40 Y(1) = 1.0E0
      IF (N.EQ.1) RETURN
      I1 = 2
      GO TO 60
   50 I1 = 1
   60 DO 70 I=I1,N
        Y(I) = 0.0E0
   70 CONTINUE
      RETURN
   80 CONTINUE
      IF (ALPHA.LT.0.0E0) GO TO 710
C
      IALP = INT(ALPHA)
      FNI = FLOAT(IALP+N-1)
      FNF = ALPHA - FLOAT(IALP)
      DFN = FNI + FNF
      FNU = DFN
      XO2 = X*0.5E0
      SXO2 = XO2*XO2
C
C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
C     APPLIED.
C
      IF (SXO2.LE.(FNU+1.0E0)) GO TO 90
      TA = AMAX1(20.0E0,FNU)
      IF (X.GT.TA) GO TO 120
      IF (X.GT.12.0E0) GO TO 110
      XO2L = ALOG(XO2)
      NS = INT(SXO2-FNU) + 1
      GO TO 100
   90 FN = FNU
      FNP1 = FN + 1.0E0
      XO2L = ALOG(XO2)
      IS = KT
      IF (X.LE.0.50E0) GO TO 330
      NS = 0
  100 FNI = FNI + FLOAT(NS)
      DFN = FNI + FNF
      FN = DFN
      FNP1 = FN + 1.0E0
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 330
  110 ANS = AMAX1(36.0E0-FNU,0.0E0)
      NS = INT(ANS)
      FNI = FNI + FLOAT(NS)
      DFN = FNI + FNF
      FN = DFN
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 130
  120 CONTINUE
      RTX = SQRT(X)
      TAU = RTWO*RTX
      TA = TAU + FNULIM(KT)
      IF (FNU.LE.TA) GO TO 480
      FN = FNU
      IS = KT
C
C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
C
  130 CONTINUE
      I1 = IABS(3-IS)
      I1 = MAX0(I1,1)
      FLGJY = 1.0E0
      CALL ASJY(JAIRY,X,FN,FLGJY,I1,TOL,ELIM,TEMP(IS),WK,IFLW)
      IF(IFLW.NE.0) GO TO 380
      GO TO (320, 450, 620), IS
  310 TEMP(1) = TEMP(3)
      KT = 1
  320 IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF(I1.EQ.2) GO TO 450
      GO TO 130
C
C     SERIES FOR (X/2)**2.LE.NU+1
C
  330 CONTINUE
      GLN = GAMLN(FNP1)
      ARG = FN*XO2L - GLN
      IF (ARG.LT.(-ELIM)) GO TO 400
      EARG = EXP(ARG)
  340 CONTINUE
      S = 1.0E0
      IF (X.LT.TOL) GO TO 360
      AK = 3.0E0
      T2 = 1.0E0
      T = 1.0E0
      S1 = FN
      DO 350 K=1,17
        S2 = T2 + S1
        T = -T*SXO2/S2
        S = S + T
        IF (ABS(T).LT.TOL) GO TO 360
        T2 = T2 + AK
        AK = AK + 2.0E0
        S1 = S1 + FN
  350 CONTINUE
  360 CONTINUE
      TEMP(IS) = S*EARG
      GO TO (370, 450, 610), IS
  370 EARG = EARG*FN/XO2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IS = 2
      GO TO 340
C
C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
C
  380 Y(NN) = 0.0E0
      NN = NN - 1
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 440, 390, 130
  390 KT = 2
      IS = 2
      GO TO 130
  400 Y(NN) = 0.0E0
      NN = NN - 1
      FNP1 = FN
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 440, 410, 420
  410 KT = 2
      IS = 2
  420 IF (SXO2.LE.FNP1) GO TO 430
      GO TO 130
  430 ARG = ARG - XO2L + ALOG(FNP1)
      IF (ARG.LT.(-ELIM)) GO TO 400
      GO TO 330
  440 NZ = N - NN
      RETURN
C
C     BACKWARD RECURSION SECTION
C
  450 CONTINUE
      NZ = N - NN
      IF (KT.EQ.2) GO TO 470
C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
      Y(NN) = TEMP(1)
      Y(NN-1) = TEMP(2)
      IF (NN.EQ.2) RETURN
      TRX = 2.0E0/X
      DTM = FNI
      TM = (DTM+FNF)*TRX
      K = NN + 1
      DO 460 I=3,NN
        K = K - 1
        Y(K-2) = TM*Y(K-1) - Y(K)
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  460 CONTINUE
      RETURN
  470 Y(1) = TEMP(2)
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN
C     OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER
C     OF THE SEQUENCE IS ALSO IN THE REGION.
C
  480 CONTINUE
      IN = INT(ALPHA-TAU+2.0E0)
      IF (IN.LE.0) GO TO 490
      IDALP = IALP - IN - 1
      KT = 1
      GO TO 500
  490 CONTINUE
      IDALP = IALP
      IN = 0
  500 IS = KT
      FIDAL = FLOAT(IDALP)
      DALPHA = FIDAL + FNF
      ARG = X - PIDT*DALPHA - PDF
      SA = SIN(ARG)
      SB = COS(ARG)
      COEF = RTTP/RTX
      ETX = 8.0E0*X
  510 CONTINUE
      DTM = FIDAL + FIDAL
      DTM = DTM*DTM
      TM = 0.0E0
      IF (FIDAL.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 520
      TM = 4.0E0*FNF*(FIDAL+FIDAL+FNF)
  520 CONTINUE
      TRX = DTM - 1.0E0
      T2 = (TRX+TM)/ETX
      S2 = T2
      RELB = TOL*ABS(T2)
      T1 = ETX
      S1 = 1.0E0
      FN = 1.0E0
      AK = 8.0E0
      DO 530 K=1,13
        T1 = T1 + ETX
        FN = FN + AK
        TRX = DTM - FN
        AP = TRX + TM
        T2 = -T2*AP/T1
        S1 = S1 + T2
        T1 = T1 + ETX
        AK = AK + 8.0E0
        FN = FN + AK
        TRX = DTM - FN
        AP = TRX + TM
        T2 = T2*AP/T1
        S2 = S2 + T2
        IF (ABS(T2).LE.RELB) GO TO 540
        AK = AK + 8.0E0
  530 CONTINUE
  540 TEMP(IS) = COEF*(S1*SB-S2*SA)
      IF(IS.EQ.2) GO TO 560
  550 FIDAL = FIDAL + 1.0E0
      DALPHA = FIDAL + FNF
      IS = 2
      TB = SA
      SA = -SB
      SB = TB
      GO TO 510
C
C     FORWARD RECURSION SECTION
C
  560 IF (KT.EQ.2) GO TO 470
      S1 = TEMP(1)
      S2 = TEMP(2)
      TX = 2.0E0/X
      TM = DALPHA*TX
      IF (IN.EQ.0) GO TO 580
C
C     FORWARD RECUR TO INDEX ALPHA
C
      DO 570 I=1,IN
        S = S2
        S2 = TM*S2 - S1
        TM = TM + TX
        S1 = S
  570 CONTINUE
      IF (NN.EQ.1) GO TO 600
      S = S2
      S2 = TM*S2 - S1
      TM = TM + TX
      S1 = S
  580 CONTINUE
C
C     FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1
C
      Y(1) = S1
      Y(2) = S2
      IF (NN.EQ.2) RETURN
      DO 590 I=3,NN
        Y(I) = TM*Y(I-1) - Y(I-2)
        TM = TM + TX
  590 CONTINUE
      RETURN
  600 Y(1) = S2
      RETURN
C
C     BACKWARD RECURSION WITH NORMALIZATION BY
C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
C
  610 CONTINUE
C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
      AKM = AMAX1(3.0E0-FN,0.0E0)
      KM = INT(AKM)
      TFN = FN + FLOAT(KM)
      TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
      TA = XO2L - TA
      TB = -(1.0E0-1.5E0/TFN)/TFN
      AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
      IN = KM + INT(AKM)
      GO TO 660
  620 CONTINUE
C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
      GLN = WK(3) + WK(2)
      IF (WK(6).GT.30.0E0) GO TO 640
      RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0E0
      RZDEN = PP(1) + PP(2)*WK(6)
      TA = RZDEN/RDEN
      IF (WK(1).LT.0.10E0) GO TO 630
      TB = GLN/WK(5)
      GO TO 650
  630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(1))
     1 /WK(7)
      GO TO 650
  640 CONTINUE
      TA = 0.5E0*TOLLN/WK(4)
      TA=((0.0493827160E0*TA-0.1111111111E0)*TA+0.6666666667E0)*TA*WK(6)
      IF (WK(1).LT.0.10E0) GO TO 630
      TB = GLN/WK(5)
  650 IN = INT(TA/TB+1.5E0)
      IF (IN.GT.INLIM) GO TO 310
  660 CONTINUE
      DTM = FNI + FLOAT(IN)
      TRX = 2.0E0/X
      TM = (DTM+FNF)*TRX
      TA = 0.0E0
      TB = TOL
      KK = 1
  670 CONTINUE
C
C     BACKWARD RECUR UNINDEXED
C
      DO 680 I=1,IN
        S = TB
        TB = TM*TB - TA
        TA = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  680 CONTINUE
C     NORMALIZATION
      IF (KK.NE.1) GO TO 690
      TA = (TA/TB)*TEMP(3)
      TB = TEMP(3)
      KK = 2
      IN = NS
      IF (NS.NE.0) GO TO 670
  690 Y(NN) = TB
      NZ = N - NN
      IF (NN.EQ.1) RETURN
      K = NN - 1
      Y(K) = TM*TB - TA
      IF (NN.EQ.2) RETURN
      DTM = DTM - 1.0E0
      TM = (DTM+FNF)*TRX
      KM = K - 1
C
C     BACKWARD RECUR INDEXED
C
      DO 700 I=1,KM
        Y(K-1) = TM*Y(K) - Y(K+1)
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
        K = K - 1
  700 CONTINUE
      RETURN
C
C
C
  710 CONTINUE
      NZ = -2
      RETURN
  720 CONTINUE
      NZ = -3
      RETURN
  730 CONTINUE
      NZ = -1
      RETURN
      END
      SUBROUTINE ASJY(FUNJY,X,FNU,FLGJY,IN,TOL,ELIM,Y,WK,IFLW)
C
C               ASJY COMPUTES BESSEL FUNCTIONS J AND Y
C               FOR ARGUMENTS X.GT.0.0 AND ORDERS FNU.GE.35.0
C               ON FLGJY = 1 AND FLGJY = -1 RESPECTIVELY
C
C                                  INPUT
C
C      FUNJY - EXTERNAL FUNCTION JAIRY OR YAIRY
C          X - ARGUMENT, X.GT.0.0E0
C        FNU - ORDER OF THE FIRST BESSEL FUNCTION
C      FLGJY - SELECTION FLAG
C              FLGJY =  1.0E0 GIVES THE J FUNCTION
C              FLGJY = -1.0E0 GIVES THE Y FUNCTION
C         IN - NUMBER OF FUNCTIONS DESIRED, IN = 1 OR 2
C        TOL - TOLERANCE SPECIFIED BY BESJ OR BESY
C       ELIM - TOLERANCE SPECIFIED BY BESJ OR BESY
C
C                                  OUTPUT
C
C         Y  - A VECTOR WHOSE FIRST IN COMPONENTS CONTAIN THE SEQUENCE
C       IFLW - A FLAG INDICATING UNDERFLOW OR OVERFLOW
C                    RETURN VARIABLES FOR BESJ ONLY
C      WK(1) = 1 - (X/FNU)**2 = W**2
C      WK(2) = SQRT(ABS(WK(1)))
C      WK(3) = ABS(WK(2) - ATAN(WK(2)))  OR
C              ABS(LN((1 + WK(2))/(X/FNU)) - WK(2))
C            = ABS((2/3)*ZETA**(3/2))
C      WK(4) = FNU*WK(3)
C      WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3)
C      WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3)
C      WK(7) = FNU**(1/3)
C
C                                  WRITTEN BY
C                                  D. E. AMOS
C
C     ABSTRACT
C         ASJK IMPLEMENTS THE UNIFORM ASYMPTOTIC EXPANSION OF
C         THE J AND Y BESSEL FUNCTIONS FOR FNU.GE.35 AND REAL
C         X.GT.0.0E0. THE FORMS ARE IDENTICAL EXCEPT FOR A CHANGE
C         IN SIGN OF SOME OF THE TERMS. THIS CHANGE IN SIGN IS
C         ACCOMPLISHED BY MEANS OF THE FLAG FLGJY = 1 OR -1. ON
C         FLGJY = 1 THE AIRY FUNCTIONS AI(X) AND DAI(X) ARE
C         SUPPLIED BY THE EXTERNAL FUNCTION JAIRY, AND ON
C         FLGJY = -1 THE AIRY FUNCTIONS BI(X) AND DBI(X) ARE
C         SUPPLIED BY THE EXTERNAL FUNTION YAIRY.
C
      INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1,
     * KSTEMP, L, LR, LRP1
      REAL ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ,
     * BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2,
     * CON3,CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU,
     * FN2, GAMA, PHI,  RCZ, RDEN, RELB, RFN2,  RTZ, RZDEN,
     * SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL,
     *  WK, X, XX, Y, Z, Z32
      EXTERNAL FUNJY
      DIMENSION Y(*), WK(*), C(65)
      DIMENSION ALFA(26,4), BETA(26,5)
      DIMENSION ALFA1(26,2), ALFA2(26,2)
      DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1)
      DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10)
      DIMENSION CR(10), DR(10)
      EQUIVALENCE (ALFA(1,1),ALFA1(1,1))
      EQUIVALENCE (ALFA(1,3),ALFA2(1,1))
      EQUIVALENCE (BETA(1,1),BETA1(1,1))
      EQUIVALENCE (BETA(1,3),BETA2(1,1))
      EQUIVALENCE (BETA(1,5),BETA3(1,1))
      DATA TOLS            /-6.90775527898214E+00/
      DATA CON1,CON2,CON3,CON548/
     1 6.66666666666667E-01, 3.33333333333333E-01, 1.41421356237310E+00,
     2 1.04166666666667E-01/
      DATA  AR(1),  AR(2),  AR(3),  AR(4),  AR(5),  AR(6),  AR(7),
     A      AR(8)          / 8.35503472222222E-02, 1.28226574556327E-01,
     1 2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00,
     2 1.49957629868626E+01, 7.89230130115865E+01, 4.74451538868264E+02/
      DATA  BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8),
     A      BR(9), BR(10)  /-1.45833333333333E-01,-9.87413194444444E-02,
     1-1.43312053915895E-01,-3.17227202678414E-01,-9.42429147957120E-01,
     2-3.51120304082635E+00,-1.57272636203680E+01,-8.22814390971859E+01,
     3-4.92355370523671E+02,-3.31621856854797E+03/
      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
     2     C(19), C(20), C(21), C(22), C(23), C(24)/
     3       -2.08333333333333E-01,        1.25000000000000E-01,
     4        3.34201388888889E-01,       -4.01041666666667E-01,
     5        7.03125000000000E-02,       -1.02581259645062E+00,
     6        1.84646267361111E+00,       -8.91210937500000E-01,
     7        7.32421875000000E-02,        4.66958442342625E+00,
     8       -1.12070026162230E+01,        8.78912353515625E+00,
     9       -2.36408691406250E+00,        1.12152099609375E-01,
     A       -2.82120725582002E+01,        8.46362176746007E+01,
     B       -9.18182415432400E+01,        4.25349987453885E+01,
     C       -7.36879435947963E+00,        2.27108001708984E-01,
     D        2.12570130039217E+02,       -7.65252468141182E+02,
     E        1.05999045252800E+03,       -6.99579627376133E+02/
      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
     3        2.18190511744212E+02,       -2.64914304869516E+01,
     4        5.72501420974731E-01,       -1.91945766231841E+03,
     5        8.06172218173731E+03,       -1.35865500064341E+04,
     6        1.16553933368645E+04,       -5.30564697861340E+03,
     7        1.20090291321635E+03,       -1.08090919788395E+02,
     8        1.72772750258446E+00,        2.02042913309661E+04,
     9       -9.69805983886375E+04,        1.92547001232532E+05,
     A       -2.03400177280416E+05,        1.22200464983017E+05,
     B       -4.11926549688976E+04,        7.10951430248936E+03,
     C       -4.93915304773088E+02,        6.07404200127348E+00,
     D       -2.42919187900551E+05,        1.31176361466298E+06,
     E       -2.99801591853811E+06,        3.76327129765640E+06/
      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
     2     C(65)/
     3       -2.81356322658653E+06,        1.26836527332162E+06,
     4       -3.31645172484564E+05,        4.52187689813627E+04,
     5       -2.49983048181121E+03,        2.43805296995561E+01,
     6        3.28446985307204E+06,       -1.97068191184322E+07,
     7        5.09526024926646E+07,       -7.41051482115327E+07,
     8        6.63445122747290E+07,       -3.75671766607634E+07,
     9        1.32887671664218E+07,       -2.78561812808645E+06,
     A        3.08186404612662E+05,       -1.38860897537170E+04,
     B        1.10017140269247E+02/
      DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1),
     1     ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1),
     2     ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1),
     3     ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1),
     4     ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1),
     5     ALFA1(26,1)     /-4.44444444444444E-03,-9.22077922077922E-04,
     6-8.84892884892885E-05, 1.65927687832450E-04, 2.46691372741793E-04,
     7 2.65995589346255E-04, 2.61824297061501E-04, 2.48730437344656E-04,
     8 2.32721040083232E-04, 2.16362485712365E-04, 2.00738858762752E-04,
     9 1.86267636637545E-04, 1.73060775917876E-04, 1.61091705929016E-04,
     1 1.50274774160908E-04, 1.40503497391270E-04, 1.31668816545923E-04,
     2 1.23667445598253E-04, 1.16405271474738E-04, 1.09798298372713E-04,
     3 1.03772410422993E-04, 9.82626078369363E-05, 9.32120517249503E-05,
     4 8.85710852478712E-05, 8.42963105715700E-05, 8.03497548407791E-05/
      DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2),
     1     ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2),
     2     ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2),
     3     ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2),
     4     ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2),
     5     ALFA1(26,2)     / 6.93735541354589E-04, 2.32241745182922E-04,
     6-1.41986273556691E-05,-1.16444931672049E-04,-1.50803558053049E-04,
     7-1.55121924918096E-04,-1.46809756646466E-04,-1.33815503867491E-04,
     8-1.19744975684254E-04,-1.06184319207974E-04,-9.37699549891194E-05,
     9-8.26923045588193E-05,-7.29374348155221E-05,-6.44042357721016E-05,
     1-5.69611566009369E-05,-5.04731044303562E-05,-4.48134868008883E-05,
     2-3.98688727717599E-05,-3.55400532972042E-05,-3.17414256609022E-05,
     3-2.83996793904175E-05,-2.54522720634871E-05,-2.28459297164725E-05,
     4-2.05352753106481E-05,-1.84816217627666E-05,-1.66519330021394E-05/
      DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1),
     1     ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1),
     2     ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1),
     3     ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1),
     4     ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1),
     5     ALFA2(26,1)     /-3.54211971457744E-04,-1.56161263945159E-04,
     6 3.04465503594936E-05, 1.30198655773243E-04, 1.67471106699712E-04,
     7 1.70222587683593E-04, 1.56501427608595E-04, 1.36339170977445E-04,
     8 1.14886692029825E-04, 9.45869093034688E-05, 7.64498419250898E-05,
     9 6.07570334965197E-05, 4.74394299290509E-05, 3.62757512005344E-05,
     1 2.69939714979225E-05, 1.93210938247939E-05, 1.30056674793963E-05,
     2 7.82620866744497E-06, 3.59257485819352E-06, 1.44040049814252E-07,
     3-2.65396769697939E-06,-4.91346867098486E-06,-6.72739296091248E-06,
     4-8.17269379678658E-06,-9.31304715093561E-06,-1.02011418798016E-05/
      DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2),
     1     ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2),
     2     ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2),
     3     ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2),
     4     ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2),
     5     ALFA2(26,2)     / 3.78194199201773E-04, 2.02471952761816E-04,
     6-6.37938506318862E-05,-2.38598230603006E-04,-3.10916256027362E-04,
     7-3.13680115247576E-04,-2.78950273791323E-04,-2.28564082619141E-04,
     8-1.75245280340847E-04,-1.25544063060690E-04,-8.22982872820208E-05,
     9-4.62860730588116E-05,-1.72334302366962E-05, 5.60690482304602E-06,
     1 2.31395443148287E-05, 3.62642745856794E-05, 4.58006124490189E-05,
     2 5.24595294959114E-05, 5.68396208545815E-05, 5.94349820393104E-05,
     3 6.06478527578422E-05, 6.08023907788436E-05, 6.01577894539460E-05,
     4 5.89199657344698E-05, 5.72515823777593E-05, 5.52804375585853E-05/
      DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1),
     1     BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1),
     2     BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1),
     3     BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1),
     4     BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1),
     5     BETA1(26,1)     / 1.79988721413553E-02, 5.59964911064388E-03,
     6 2.88501402231133E-03, 1.80096606761054E-03, 1.24753110589199E-03,
     7 9.22878876572938E-04, 7.14430421727287E-04, 5.71787281789705E-04,
     8 4.69431007606482E-04, 3.93232835462917E-04, 3.34818889318298E-04,
     9 2.88952148495752E-04, 2.52211615549573E-04, 2.22280580798883E-04,
     1 1.97541838033063E-04, 1.76836855019718E-04, 1.59316899661821E-04,
     2 1.44347930197334E-04, 1.31448068119965E-04, 1.20245444949303E-04,
     3 1.10449144504599E-04, 1.01828770740567E-04, 9.41998224204238E-05,
     4 8.74130545753834E-05, 8.13466262162801E-05, 7.59002269646219E-05/
      DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2),
     1     BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2),
     2     BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2),
     3     BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2),
     4     BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2),
     5     BETA1(26,2)     /-1.49282953213429E-03,-8.78204709546389E-04,
     6-5.02916549572035E-04,-2.94822138512746E-04,-1.75463996970783E-04,
     7-1.04008550460816E-04,-5.96141953046458E-05,-3.12038929076098E-05,
     8-1.26089735980230E-05,-2.42892608575730E-07, 8.05996165414274E-06,
     9 1.36507009262147E-05, 1.73964125472926E-05, 1.98672978842134E-05,
     1 2.14463263790823E-05, 2.23954659232457E-05, 2.28967783814713E-05,
     2 2.30785389811178E-05, 2.30321976080909E-05, 2.28236073720349E-05,
     3 2.25005881105292E-05, 2.20981015361991E-05, 2.16418427448104E-05,
     4 2.11507649256221E-05, 2.06388749782171E-05, 2.01165241997082E-05/
      DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1),
     1     BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1),
     2     BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1),
     3     BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1),
     4     BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1),
     5     BETA2(26,1)     / 5.52213076721293E-04, 4.47932581552385E-04,
     6 2.79520653992021E-04, 1.52468156198447E-04, 6.93271105657044E-05,
     7 1.76258683069991E-05,-1.35744996343269E-05,-3.17972413350427E-05,
     8-4.18861861696693E-05,-4.69004889379141E-05,-4.87665447413787E-05,
     9-4.87010031186735E-05,-4.74755620890087E-05,-4.55813058138628E-05,
     1-4.33309644511266E-05,-4.09230193157750E-05,-3.84822638603221E-05,
     2-3.60857167535411E-05,-3.37793306123367E-05,-3.15888560772110E-05,
     3-2.95269561750807E-05,-2.75978914828336E-05,-2.58006174666884E-05,
     4-2.41308356761280E-05,-2.25823509518346E-05,-2.11479656768913E-05/
      DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2),
     1     BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2),
     2     BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2),
     3     BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2),
     4     BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2),
     5     BETA2(26,2)     /-4.74617796559960E-04,-4.77864567147321E-04,
     6-3.20390228067038E-04,-1.61105016119962E-04,-4.25778101285435E-05,
     7 3.44571294294968E-05, 7.97092684075675E-05, 1.03138236708272E-04,
     8 1.12466775262204E-04, 1.13103642108481E-04, 1.08651634848774E-04,
     9 1.01437951597662E-04, 9.29298396593364E-05, 8.40293133016090E-05,
     1 7.52727991349134E-05, 6.69632521975731E-05, 5.92564547323195E-05,
     2 5.22169308826976E-05, 4.58539485165361E-05, 4.01445513891487E-05,
     3 3.50481730031328E-05, 3.05157995034347E-05, 2.64956119950516E-05,
     4 2.29363633690998E-05, 1.97893056664022E-05, 1.70091984636413E-05/
      DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1),
     1     BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1),
     2     BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1),
     3     BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1),
     4     BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1),
     5     BETA3(26,1)     / 7.36465810572578E-04, 8.72790805146194E-04,
     6 6.22614862573135E-04, 2.85998154194304E-04, 3.84737672879366E-06,
     7-1.87906003636972E-04,-2.97603646594555E-04,-3.45998126832656E-04,
     8-3.53382470916038E-04,-3.35715635775049E-04,-3.04321124789040E-04,
     9-2.66722723047613E-04,-2.27654214122820E-04,-1.89922611854562E-04,
     1-1.55058918599094E-04,-1.23778240761874E-04,-9.62926147717644E-05,
     2-7.25178327714425E-05,-5.22070028895634E-05,-3.50347750511901E-05,
     3-2.06489761035552E-05,-8.70106096849767E-06, 1.13698686675100E-06,
     4 9.16426474122779E-06, 1.56477785428873E-05, 2.08223629482467E-05/
      DATA GAMA(1),   GAMA(2),   GAMA(3),   GAMA(4),   GAMA(5),
     1     GAMA(6),   GAMA(7),   GAMA(8),   GAMA(9),   GAMA(10),
     2     GAMA(11),  GAMA(12),  GAMA(13),  GAMA(14),  GAMA(15),
     3     GAMA(16),  GAMA(17),  GAMA(18),  GAMA(19),  GAMA(20),
     4     GAMA(21),  GAMA(22),  GAMA(23),  GAMA(24),  GAMA(25),
     5     GAMA(26)        / 6.29960524947437E-01, 2.51984209978975E-01,
     6 1.54790300415656E-01, 1.10713062416159E-01, 8.57309395527395E-02,
     7 6.97161316958684E-02, 5.86085671893714E-02, 5.04698873536311E-02,
     8 4.42600580689155E-02, 3.93720661543510E-02, 3.54283195924455E-02,
     9 3.21818857502098E-02, 2.94646240791158E-02, 2.71581677112934E-02,
     1 2.51768272973862E-02, 2.34570755306079E-02, 2.19508390134907E-02,
     2 2.06210828235646E-02, 1.94388240897881E-02, 1.83810633800683E-02,
     3 1.74293213231963E-02, 1.65685837786612E-02, 1.57865285987918E-02,
     4 1.50729501494096E-02, 1.44193250839955E-02, 1.38184805735342E-02/
C     ------------------------------------------------------------------
      FN = FNU
      IFLW = 0
      DO 170 JN=1,IN
        XX = X/FN
        WK(1) = 1.0E0 - XX*XX
        ABW2 = ABS(WK(1))
        WK(2) = SQRT(ABW2)
        WK(7) = FN**CON2
        IF (ABW2.GT.0.27750E0) GO TO 80
C
C     ASYMPTOTIC EXPANSION
C     CASES NEAR X=FN, ABS(1.-(X/FN)**2).LE.0.2775
C     COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES
C
C     ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES
C
C     KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA)
C
        SA = 0.0E0
        IF (ABW2.EQ.0.0E0) GO TO 10
        SA = TOLS/ALOG(ABW2)
   10   SB = SA
        DO 20 I=1,5
          AKM = AMAX1(SA,2.0E0)
          KMAX(I) = INT(AKM)
          SA = SA + SB
   20   CONTINUE
        KB = KMAX(5)
        KLAST = KB - 1
        SA = GAMA(KB)
        DO 30 K=1,KLAST
          KB = KB - 1
          SA = SA*WK(1) + GAMA(KB)
   30   CONTINUE
        Z = WK(1)*SA
        AZ = ABS(Z)
        RTZ = SQRT(AZ)
        WK(3) = CON1*AZ*RTZ
        WK(4) = WK(3)*FN
        WK(5) = RTZ*WK(7)
        WK(6) = -WK(5)*WK(5)
        IF(Z.LE.0.0E0) GO TO 35
        IF(WK(4).GT.ELIM) GO TO 75
        WK(6) = -WK(6)
   35   CONTINUE
        PHI = SQRT(SQRT(SA+SA+SA+SA))
C
C     B(ZETA) FOR S=0
C
        KB = KMAX(5)
        KLAST = KB - 1
        SB = BETA(KB,1)
        DO 40 K=1,KLAST
          KB = KB - 1
          SB = SB*WK(1) + BETA(KB,1)
   40   CONTINUE
        KSP1 = 1
        FN2 = FN*FN
        RFN2 = 1.0E0/FN2
        RDEN = 1.0E0
        ASUM = 1.0E0
        RELB = TOL*ABS(SB)
        BSUM = SB
        DO 60 KS=1,4
          KSP1 = KSP1 + 1
          RDEN = RDEN*RFN2
C
C     A(ZETA) AND B(ZETA) FOR S=1,2,3,4
C
          KSTEMP = 5 - KS
          KB = KMAX(KSTEMP)
          KLAST = KB - 1
          SA = ALFA(KB,KS)
          SB = BETA(KB,KSP1)
          DO 50 K=1,KLAST
            KB = KB - 1
            SA = SA*WK(1) + ALFA(KB,KS)
            SB = SB*WK(1) + BETA(KB,KSP1)
   50     CONTINUE
          TA = SA*RDEN
          TB = SB*RDEN
          ASUM = ASUM + TA
          BSUM = BSUM + TB
          IF (ABS(TA).LE.TOL .AND. ABS(TB).LE.RELB) GO TO 70
   60   CONTINUE
   70   CONTINUE
        BSUM = BSUM/(FN*WK(7))
        GO TO 160
C
   75   CONTINUE
        IFLW = 1
        RETURN
C
   80   CONTINUE
        UPOL(1) = 1.0E0
        TAU = 1.0E0/WK(2)
        T2 = 1.0E0/WK(1)
        IF (WK(1).GE.0.0E0) GO TO 90
C
C     CASES FOR (X/FN).GT.SQRT(1.2775)
C
        WK(3) = ABS(WK(2)-ATAN(WK(2)))
        WK(4) = WK(3)*FN
        RCZ = -CON1/WK(4)
        Z32 = 1.5E0*WK(3)
        RTZ = Z32**CON2
        WK(5) = RTZ*WK(7)
        WK(6) = -WK(5)*WK(5)
        GO TO 100
   90   CONTINUE
C
C     CASES FOR (X/FN).LT.SQRT(0.7225)
C
        WK(3) = ABS(ALOG((1.0E0+WK(2))/XX)-WK(2))
        WK(4) = WK(3)*FN
        RCZ = CON1/WK(4)
        IF(WK(4).GT.ELIM) GO TO 75
        Z32 = 1.5E0*WK(3)
        RTZ = Z32**CON2
        WK(7) = FN**CON2
        WK(5) = RTZ*WK(7)
        WK(6) = WK(5)*WK(5)
  100   CONTINUE
        PHI = SQRT((RTZ+RTZ)*TAU)
        TB = 1.0E0
        ASUM = 1.0E0
        TFN = TAU/FN
        UPOL(2) = (C(1)*T2+C(2))*TFN
        CRZ32 = CON548*RCZ
        BSUM = UPOL(2) + CRZ32
        RELB = TOL*ABS(BSUM)
        AP = TFN
        KS = 0
        KP1 = 2
        RZDEN = RCZ
        L = 2
        DO 140 LR=2,8,2
C
C     COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA)
C
          LRP1 = LR + 1
          DO 120 K=LR,LRP1
            KS = KS + 1
            KP1 = KP1 + 1
            L = L + 1
            S1 = C(L)
            DO 110 J=2,KP1
              L = L + 1
              S1 = S1*T2 + C(L)
  110       CONTINUE
            AP = AP*TFN
            UPOL(KP1) = AP*S1
            CR(KS) = BR(KS)*RZDEN
            RZDEN = RZDEN*RCZ
            DR(KS) = AR(KS)*RZDEN
  120     CONTINUE
          SUMA = UPOL(LRP1)
          SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32
          JU = LRP1
          DO 130 JR=1,LR
            JU = JU - 1
            SUMA = SUMA + CR(JR)*UPOL(JU)
            SUMB = SUMB + DR(JR)*UPOL(JU)
  130     CONTINUE
          TB = -TB
          IF (WK(1).GT.0.0E0) TB = ABS(TB)
          ASUM = ASUM + SUMA*TB
          BSUM = BSUM + SUMB*TB
          IF (ABS(SUMA).LE.TOL .AND. ABS(SUMB).LE.RELB) GO TO 150
  140   CONTINUE
  150   TB = WK(5)
        IF (WK(1).GT.0.0E0) TB = -TB
        BSUM = BSUM/TB
C
  160   CONTINUE
        CALL FUNJY(WK(6), WK(5), WK(4), FI, DFI)
        Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7)
        FN = FN - FLGJY
  170 CONTINUE
      RETURN
      END
      SUBROUTINE JAIRY(X,RX,C,AI,DAI)
C
C                  JAIRY COMPUTES THE AIRY FUNCTION AI(X)
C                   AND ITS DERIVATIVE DAI(X) FOR JBESS
C
C                                   INPUT
C
C         X - ARGUMENT, COMPUTED BY JBESS, X UNRESTRICTED
C        RX - RX=SQRT(ABS(X)), COMPUTED BY JBESS
C         C - C=2.*(ABS(X)**1.5)/3., COMPUTED BY JBESS
C
C                                  OUTPUT
C
C        AI - VALUE OF FUNCTION AI(X)
C       DAI - VALUE OF THE DERIVATIVE DAI(X)
C
C                                WRITTEN BY
C
C                                D. E. AMOS
C                               S. L. DANIEL
C                               M. K. WESTON
C
      DIMENSION AK1(14),AK2(23),AK3(14)
      DIMENSION AJP(19),AJN(19),A(15),B(15)
      DIMENSION DAK1(14),DAK2(24),DAK3(14)
      DIMENSION DAJP(19),DAJN(19),DA(15),DB(15)
C
      DATA N1,N2,N3,N4/14,23,19,15/
      DATA M1,M2,M3,M4/12,21,17,13/
      DATA FPI12,CON1,CON2,CON3,CON4,CON5/
     1 1.30899693899575E+00, 6.66666666666667E-01, 5.03154716196777E+00,
     2 3.80004589867293E-01, 8.33333333333333E-01, 8.66025403784439E-01/
C
      DATA AK1(1) / 2.20423090987793E-01/,
     1 AK1(2) /-1.25290242787700E-01/, AK1(3) / 1.03881163359194E-02/,
     2 AK1(4) / 8.22844152006343E-04/, AK1(5) /-2.34614345891226E-04/,
     3 AK1(6) / 1.63824280172116E-05/, AK1(7) / 3.06902589573189E-07/,
     4 AK1(8) /-1.29621999359332E-07/, AK1(9) / 8.22908158823668E-09/,
     5 AK1(10)/ 1.53963968623298E-11/, AK1(11)/-3.39165465615682E-11/,
     6 AK1(12)/ 2.03253257423626E-12/, AK1(13)/-1.10679546097884E-14/,
     7 AK1(14)/-5.16169497785080E-15/
C
      DATA AK2(1) / 2.74366150869598E-01/,
     1 AK2(2) / 5.39790969736903E-03/, AK2(3) /-1.57339220621190E-03/,
     2 AK2(4) / 4.27427528248750E-04/, AK2(5) /-1.12124917399925E-04/,
     3 AK2(6) / 2.88763171318904E-05/, AK2(7) /-7.36804225370554E-06/,
     4 AK2(8) / 1.87290209741024E-06/, AK2(9) /-4.75892793962291E-07/,
     5 AK2(10)/ 1.21130416955909E-07/, AK2(11)/-3.09245374270614E-08/,
     6 AK2(12)/ 7.92454705282654E-09/, AK2(13)/-2.03902447167914E-09/,
     7 AK2(14)/ 5.26863056595742E-10/, AK2(15)/-1.36704767639569E-10/,
     8 AK2(16)/ 3.56141039013708E-11/, AK2(17)/-9.31388296548430E-12/,
     9 AK2(18)/ 2.44464450473635E-12/, AK2(19)/-6.43840261990955E-13/,
     1 AK2(20)/ 1.70106030559349E-13/, AK2(21)/-4.50760104503281E-14/,
     2 AK2(22)/ 1.19774799164811E-14/, AK2(23)/-3.19077040865066E-15/
C
      DATA AK3(1) / 2.80271447340791E-01/,
     1 AK3(2) /-1.78127042844379E-03/, AK3(3) / 4.03422579628999E-05/,
     2 AK3(4) /-1.63249965269003E-06/, AK3(5) / 9.21181482476768E-08/,
     3 AK3(6) /-6.52294330229155E-09/, AK3(7) / 5.47138404576546E-10/,
     4 AK3(8) /-5.24408251800260E-11/, AK3(9) / 5.60477904117209E-12/,
     5 AK3(10)/-6.56375244639313E-13/, AK3(11)/ 8.31285761966247E-14/,
     6 AK3(12)/-1.12705134691063E-14/, AK3(13)/ 1.62267976598129E-15/,
     7 AK3(14)/-2.46480324312426E-16/
C
      DATA AJP(1) / 7.78952966437581E-02/,
     1 AJP(2) /-1.84356363456801E-01/, AJP(3) / 3.01412605216174E-02/,
     2 AJP(4) / 3.05342724277608E-02/, AJP(5) /-4.95424702513079E-03/,
     3 AJP(6) /-1.72749552563952E-03/, AJP(7) / 2.43137637839190E-04/,
     4 AJP(8) / 5.04564777517082E-05/, AJP(9) /-6.16316582695208E-06/,
     5 AJP(10)/-9.03986745510768E-07/, AJP(11)/ 9.70243778355884E-08/,
     6 AJP(12)/ 1.09639453305205E-08/, AJP(13)/-1.04716330588766E-09/,
     7 AJP(14)/-9.60359441344646E-11/, AJP(15)/ 8.25358789454134E-12/,
     8 AJP(16)/ 6.36123439018768E-13/, AJP(17)/-4.96629614116015E-14/,
     9 AJP(18)/-3.29810288929615E-15/, AJP(19)/ 2.35798252031104E-16/
C
      DATA AJN(1) / 3.80497887617242E-02/,
     1 AJN(2) /-2.45319541845546E-01/, AJN(3) / 1.65820623702696E-01/,
     2 AJN(4) / 7.49330045818789E-02/, AJN(5) /-2.63476288106641E-02/,
     3 AJN(6) /-5.92535597304981E-03/, AJN(7) / 1.44744409589804E-03/,
     4 AJN(8) / 2.18311831322215E-04/, AJN(9) /-4.10662077680304E-05/,
     5 AJN(10)/-4.66874994171766E-06/, AJN(11)/ 7.15218807277160E-07/,
     6 AJN(12)/ 6.52964770854633E-08/, AJN(13)/-8.44284027565946E-09/,
     7 AJN(14)/-6.44186158976978E-10/, AJN(15)/ 7.20802286505285E-11/,
     8 AJN(16)/ 4.72465431717846E-12/, AJN(17)/-4.66022632547045E-13/,
     9 AJN(18)/-2.67762710389189E-14/, AJN(19)/ 2.36161316570019E-15/
C
      DATA A(1) / 4.90275424742791E-01/, A(2) / 1.57647277946204E-03/,
     1     A(3) /-9.66195963140306E-05/, A(4) / 1.35916080268815E-07/,
     2     A(5) / 2.98157342654859E-07/, A(6) /-1.86824767559979E-08/,
     3     A(7) /-1.03685737667141E-09/, A(8) / 3.28660818434328E-10/,
     4     A(9) /-2.57091410632780E-11/, A(10)/-2.32357655300677E-12/,
     5     A(11)/ 9.57523279048255E-13/, A(12)/-1.20340828049719E-13/,
     6     A(13)/-2.90907716770715E-15/, A(14)/ 4.55656454580149E-15/,
     7     A(15)/-9.99003874810259E-16/
C
      DATA B(1) / 2.78593552803079E-01/, B(2) /-3.52915691882584E-03/,
     1     B(3) /-2.31149677384994E-05/, B(4) / 4.71317842263560E-06/,
     2     B(5) /-1.12415907931333E-07/, B(6) /-2.00100301184339E-08/,
     3     B(7) / 2.60948075302193E-09/, B(8) /-3.55098136101216E-11/,
     4     B(9) /-3.50849978423875E-11/, B(10)/ 5.83007187954202E-12/,
     5     B(11)/-2.04644828753326E-13/, B(12)/-1.10529179476742E-13/,
     6     B(13)/ 2.87724778038775E-14/, B(14)/-2.88205111009939E-15/,
     7     B(15)/-3.32656311696166E-16/
C
      DATA N1D,N2D,N3D,N4D/14,24,19,15/
      DATA M1D,M2D,M3D,M4D/12,22,17,13/
C
      DATA DAK1(1) / 2.04567842307887E-01/,
     1 DAK1(2) /-6.61322739905664E-02/, DAK1(3) /-8.49845800989287E-03/,
     2 DAK1(4) / 3.12183491556289E-03/, DAK1(5) /-2.70016489829432E-04/,
     3 DAK1(6) /-6.35636298679387E-06/, DAK1(7) / 3.02397712409509E-06/,
     4 DAK1(8) /-2.18311195330088E-07/, DAK1(9) /-5.36194289332826E-10/,
     5 DAK1(10)/ 1.13098035622310E-09/, DAK1(11)/-7.43023834629073E-11/,
     6 DAK1(12)/ 4.28804170826891E-13/, DAK1(13)/ 2.23810925754539E-13/,
     7 DAK1(14)/-1.39140135641182E-14/
C
      DATA DAK2(1) / 2.93332343883230E-01/,
     1 DAK2(2) /-8.06196784743112E-03/, DAK2(3) / 2.42540172333140E-03/,
     2 DAK2(4) /-6.82297548850235E-04/, DAK2(5) / 1.85786427751181E-04/,
     3 DAK2(6) /-4.97457447684059E-05/, DAK2(7) / 1.32090681239497E-05/,
     4 DAK2(8) /-3.49528240444943E-06/, DAK2(9) / 9.24362451078835E-07/,
     5 DAK2(10)/-2.44732671521867E-07/, DAK2(11)/ 6.49307837648910E-08/,
     6 DAK2(12)/-1.72717621501538E-08/, DAK2(13)/ 4.60725763604656E-09/,
     7 DAK2(14)/-1.23249055291550E-09/, DAK2(15)/ 3.30620409488102E-10/,
     8 DAK2(16)/-8.89252099772401E-11/, DAK2(17)/ 2.39773319878298E-11/,
     9 DAK2(18)/-6.48013921153450E-12/, DAK2(19)/ 1.75510132023731E-12/,
     1 DAK2(20)/-4.76303829833637E-13/, DAK2(21)/ 1.29498241100810E-13/,
     2 DAK2(22)/-3.52679622210430E-14/, DAK2(23)/ 9.62005151585923E-15/,
     3 DAK2(24)/-2.62786914342292E-15/
C
      DATA DAK3(1) / 2.84675828811349E-01/,
     1 DAK3(2) / 2.53073072619080E-03/, DAK3(3) /-4.83481130337976E-05/,
     2 DAK3(4) / 1.84907283946343E-06/, DAK3(5) /-1.01418491178576E-07/,
     3 DAK3(6) / 7.05925634457153E-09/, DAK3(7) /-5.85325291400382E-10/,
     4 DAK3(8) / 5.56357688831339E-11/, DAK3(9) /-5.90889094779500E-12/,
     5 DAK3(10)/ 6.88574353784436E-13/, DAK3(11)/-8.68588256452194E-14/,
     6 DAK3(12)/ 1.17374762617213E-14/, DAK3(13)/-1.68523146510923E-15/,
     7 DAK3(14)/ 2.55374773097056E-16/
C
      DATA DAJP(1) / 6.53219131311457E-02/,
     1 DAJP(2) /-1.20262933688823E-01/, DAJP(3) / 9.78010236263823E-03/,
     2 DAJP(4) / 1.67948429230505E-02/, DAJP(5) /-1.97146140182132E-03/,
     3 DAJP(6) /-8.45560295098867E-04/, DAJP(7) / 9.42889620701976E-05/,
     4 DAJP(8) / 2.25827860945475E-05/, DAJP(9) /-2.29067870915987E-06/,
     5 DAJP(10)/-3.76343991136919E-07/, DAJP(11)/ 3.45663933559565E-08/,
     6 DAJP(12)/ 4.29611332003007E-09/, DAJP(13)/-3.58673691214989E-10/,
     7 DAJP(14)/-3.57245881361895E-11/, DAJP(15)/ 2.72696091066336E-12/,
     8 DAJP(16)/ 2.26120653095771E-13/, DAJP(17)/-1.58763205238303E-14/,
     9 DAJP(18)/-1.12604374485125E-15/, DAJP(19)/ 7.31327529515367E-17/
C
      DATA DAJN(1) / 1.08594539632967E-02/,
     1 DAJN(2) / 8.53313194857091E-02/, DAJN(3) /-3.15277068113058E-01/,
     2 DAJN(4) /-8.78420725294257E-02/, DAJN(5) / 5.53251906976048E-02/,
     3 DAJN(6) / 9.41674060503241E-03/, DAJN(7) /-3.32187026018996E-03/,
     4 DAJN(8) /-4.11157343156826E-04/, DAJN(9) / 1.01297326891346E-04/,
     5 DAJN(10)/ 9.87633682208396E-06/, DAJN(11)/-1.87312969812393E-06/,
     6 DAJN(12)/-1.50798500131468E-07/, DAJN(13)/ 2.32687669525394E-08/,
     7 DAJN(14)/ 1.59599917419225E-09/, DAJN(15)/-2.07665922668385E-10/,
     8 DAJN(16)/-1.24103350500302E-11/, DAJN(17)/ 1.39631765331043E-12/,
     9 DAJN(18)/ 7.39400971155740E-14/, DAJN(19)/-7.32887475627500E-15/
C
      DATA DA(1) / 4.91627321104601E-01/, DA(2) / 3.11164930427489E-03/,
     1     DA(3) / 8.23140762854081E-05/, DA(4) /-4.61769776172142E-06/,
     2     DA(5) /-6.13158880534626E-08/, DA(6) / 2.87295804656520E-08/,
     3     DA(7) /-1.81959715372117E-09/, DA(8) /-1.44752826642035E-10/,
     4     DA(9) / 4.53724043420422E-11/, DA(10)/-3.99655065847223E-12/,
     5     DA(11)/-3.24089119830323E-13/, DA(12)/ 1.62098952568741E-13/,
     6     DA(13)/-2.40765247974057E-14/, DA(14)/ 1.69384811284491E-16/,
     7     DA(15)/ 8.17900786477396E-16/
C
      DATA DB(1) /-2.77571356944231E-01/, DB(2) / 4.44212833419920E-03/,
     1     DB(3) /-8.42328522190089E-05/, DB(4) /-2.58040318418710E-06/,
     2     DB(5) / 3.42389720217621E-07/, DB(6) /-6.24286894709776E-09/,
     3     DB(7) /-2.36377836844577E-09/, DB(8) / 3.16991042656673E-10/,
     4     DB(9) /-4.40995691658191E-12/, DB(10)/-5.18674221093575E-12/,
     5     DB(11)/ 9.64874015137022E-13/, DB(12)/-4.90190576608710E-14/,
     6     DB(13)/-1.77253430678112E-14/, DB(14)/ 5.55950610442662E-15/,
     7     DB(15)/-7.11793337579530E-16/
C     -------------------
      IF(X.LT.0.) GO TO 300
      IF(C.GT.5.) GO TO 200
      IF(X.GT.1.2) GO TO 150
      T=(X+X-1.2)*CON4
      TT = T + T
      J=N1
      F1=AK1(J)
      F2=0.
      DO 105 I=1,M1
      J=J-1
      TEMP1=F1
      F1=TT*F1-F2+AK1(J)
      F2=TEMP1
  105 CONTINUE
      AI=T*F1-F2+AK1(1)
C
      J=N1D
      F1=DAK1(J)
      F2=0.
      DO 106 I=1,M1D
      J=J-1
      TEMP1=F1
      F1=TT*F1-F2+DAK1(J)
      F2=TEMP1
106   CONTINUE
      DAI=-(T*F1-F2+DAK1(1))
      RETURN
C
  150 CONTINUE
      T=(X+X-CON2)*CON3
      TT = T + T
      J=N2
      F1=AK2(J)
      F2=0.
      DO 155 I=1,M2
      J=J-1
      TEMP1=F1
      F1=TT*F1-F2+AK2(J)
      F2=TEMP1
  155 CONTINUE
      RTRX=SQRT(RX)
      EC=EXP(-C)
      AI=EC*(T*F1-F2+AK2(1))/RTRX
      J=N2D
      F1=DAK2(J)
      F2=0.
      DO 156 I=1,M2D
      J=J-1
      TEMP1=F1
      F1=TT*F1-F2+DAK2(J)
      F2=TEMP1
156   CONTINUE
      DAI=-EC*(T*F1-F2+DAK2(1))*RTRX
      RETURN
C
  200 CONTINUE
      T=10./C-1.
      TT=T+T
      J=N1
      F1=AK3(J)
      F2=0.
      DO 205 I=1,M1
      J=J-1
      TEMP1=F1
      F1=TT*F1-F2+AK3(J)
      F2=TEMP1
  205 CONTINUE
      RTRX=SQRT(RX)
      EC=EXP(-C)
      AI=EC*(T*F1-F2+AK3(1))/RTRX
      J=N1D
      F1=DAK3(J)
      F2=0.
      DO 206 I=1,M1D
      J=J-1
      TEMP1=F1
      F1=TT*F1-F2+DAK3(J)
      F2=TEMP1
206   CONTINUE
      DAI=-RTRX*EC*(T*F1-F2+DAK3(1))
      RETURN
C
  300 CONTINUE
      IF(C.GT.5.) GO TO 350
      T=.4*C-1.
      TT=T+T
      J=N3
      F1=AJP(J)
      E1=AJN(J)
      F2=0.
      E2=0.
      DO 305 I=1,M3
      J=J-1
      TEMP1=F1
      TEMP2=E1
      F1=TT*F1-F2+AJP(J)
      E1=TT*E1-E2+AJN(J)
      F2=TEMP1
      E2=TEMP2
  305 CONTINUE
      AI=(T*E1-E2+AJN(1))-X*(T*F1-F2+AJP(1))
      J=N3D
      F1=DAJP(J)
      E1=DAJN(J)
      F2=0.
      E2=0.
      DO 306 I=1,M3D
      J=J-1
      TEMP1=F1
      TEMP2=E1
      F1 = TT*F1-F2+DAJP(J)
      E1= TT*E1-E2+DAJN(J)
      F2=TEMP1
      E2=TEMP2
 306  CONTINUE
      DAI=X*X*(T*F1-F2+DAJP(1))+(T*E1-E2+DAJN(1))
      RETURN
C
  350 CONTINUE
      T=10./C-1.
      TT=T+T
      J=N4
      F1=A(J)
      E1=B(J)
      F2=0.
      E2=0.
      DO 310 I=1,M4
      J=J-1
      TEMP1=F1
      TEMP2=E1
      F1=TT*F1-F2+A(J)
      E1=TT*E1-E2+B(J)
      F2=TEMP1
      E2=TEMP2
  310 CONTINUE
      TEMP1=T*F1-F2+A(1)
      TEMP2=T*E1-E2+B(1)
      RTRX=SQRT(RX)
      CV=C-FPI12
      CCV=COS(CV)
      SCV=SIN(CV)
      AI=(TEMP1*CCV-TEMP2*SCV)/RTRX
      J=N4D
      F1=DA(J)
      E1=DB(J)
      F2=0.
      E2=0.
      DO 311 I=1,M4D
      J=J-1
      TEMP1=F1
      TEMP2=E1
      F1=TT*F1-F2+DA(J)
      E1=TT*E1-E2+DB(J)
      F2=TEMP1
      E2=TEMP2
 311  CONTINUE
      TEMP1=T*F1-F2+DA(1)
      TEMP2=T*E1-E2+DB(1)
      E1=CCV*CON5+.5*SCV
      E2=SCV*CON5-.5*CCV
      DAI=(TEMP1*E1-TEMP2*E2)*RTRX
      RETURN
      END
      SUBROUTINE BSSLY (A, IN, W)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR ORDINARY BESSEL FUNCTION OF INTEGRAL ORDER
C     ******************************************************************
C     A  = ARGUMENT (COMPLEX NUMBER)
C     IN = ORDER (INTEGER)
C     W  = FUNCTION OF SECOND KIND (COMPLEX NUMBER)
C     -------------------
      COMPLEX A, W
      DIMENSION AZ(2)
      DIMENSION CD(30), CE(30)
      DIMENSION QZ(2), RZ(2), SZ(2), ZL(2)
      DIMENSION TS(2), TM(4), SM(4), SL(2), SQ(2), SR(2), AQ(2), QF(2)
      DATA CD(1) / 0.00000000000000E00/,  CD(2) /-1.64899505142212E-2/,
     1     CD(3) /-7.18621880068536E-2/,  CD(4) /-1.67086878124866E-1/,
     2     CD(5) /-3.02582250219469E-1/,  CD(6) /-4.80613945245927E-1/,
     3     CD(7) /-7.07075239357898E-1/,  CD(8) /-9.92995790539516E-1/,
     4     CD(9) /-1.35583925612592E00/,  CD(10)/-1.82105907899132E00/,
     5     CD(11)/-2.42482175310879E00/,  CD(12)/-3.21956655708750E00/,
     6     CD(13)/-4.28658077248384E00/,  CD(14)/-5.77022816798128E00/,
     7     CD(15)/-8.01371260952526E00/
      DATA CD(16)/ 0.00000000000000E00/,  CD(17)/-5.57742429879505E-3/,
     1     CD(18)/-4.99112944172476E-2/,  CD(19)/-1.37440911652397E-1/,
     2     CD(20)/-2.67233784710566E-1/,  CD(21)/-4.40380166808682E-1/,
     3     CD(22)/-6.61813614872541E-1/,  CD(23)/-9.41861077665017E-1/,
     4     CD(24)/-1.29754130468326E00/,  CD(25)/-1.75407696719816E00/,
     5     CD(26)/-2.34755299882276E00/,  CD(27)/-3.13041332689196E00/,
     6     CD(28)/-4.18397120563729E00/,  CD(29)/-5.65251799214994E00/,
     7     CD(30)/-7.87863959810677E00/
      DATA CE(1) / 0.00000000000000E00/,  CE(2) /-4.80942336387447E-3/,
     1     CE(3) /-1.31366200347759E-2/,  CE(4) /-1.94843834008458E-2/,
     2     CE(5) /-2.19948900032003E-2/,  CE(6) /-2.09396625676519E-2/,
     3     CE(7) /-1.74600268458650E-2/,  CE(8) /-1.27937813362085E-2/,
     4     CE(9) /-8.05234421796592E-3/,  CE(10)/-4.15817375002760E-3/,
     5     CE(11)/-1.64317738747922E-3/,  CE(12)/-4.49175585314709E-4/,
     6     CE(13)/-7.28594765574007E-5/,  CE(14)/-5.38265230658285E-6/,
     7     CE(15)/-9.93779048036289E-8/
      DATA CE(16)/ 0.00000000000000E00/,  CE(17)/ 7.53805779200591E-2/,
     1     CE(18)/ 7.12293537403464E-2/,  CE(19)/ 6.33116224228200E-2/,
     2     CE(20)/ 5.28240264523301E-2/,  CE(21)/ 4.13305359441492E-2/,
     3     CE(22)/ 3.01350573947510E-2/,  CE(23)/ 2.01043439592720E-2/,
     4     CE(24)/ 1.18552223068074E-2/,  CE(25)/ 5.86055510956010E-3/,
     5     CE(26)/ 2.25465148267325E-3/,  CE(27)/ 6.08173041536336E-4/,
     6     CE(28)/ 9.84215550625747E-5/,  CE(29)/ 7.32139093038089E-6/,
     7     CE(30)/ 1.37279667384666E-7/
C     -------------------
      AZ(1)=REAL(A)
      AZ(2)=AIMAG(A)
      ZS=AZ(1)*AZ(1)+AZ(2)*AZ(2)
      ZL(1)=0.5*ALOG(ZS)
      ZL(2)=ATAN2(AZ(2),AZ(1))
      AN=IABS(IN)
      SN=+1.0
      IF(IN)002,003,003
  002 IF(IN.EQ.IN/2*2)GO TO 003
      SN=-1.0
  003 IF(AZ(1))004,005,005
  004 QZ(1)=-AZ(1)
      QZ(2)=-AZ(2)
      GO TO 006
  005 QZ(1)=+AZ(1)
      QZ(2)=+AZ(2)
  006 IF(ZS-1.0)020,020,007
  007 IF(ZS-289.0)008,010,010
  008 IF(-ABS(AZ(2))+0.096*AZ(1)*AZ(1))020,020,015
  010 QM=SN*0.797884560802865*EXP(-0.5*ZL(1))
      QF(1)=QM*COS(-0.5*ZL(2))
      QF(2)=QM*SIN(-0.5*ZL(2))
      IF(AN.GT.1.0)GO TO 012
      PN=AN
      ASSIGN 011 TO LA
      GO TO 100
  011 TS(1)=QF(1)*SM(1)-QF(2)*SM(2)
      TS(2)=QF(1)*SM(2)+QF(2)*SM(1)
      SM(1)=TS(1)
      SM(2)=TS(2)
      GO TO 029
  012 PN=1.0
      ASSIGN 013 TO LA
      GO TO 100
  013 SQ(1)=-QF(1)*SM(1)+QF(2)*SM(2)
      SQ(2)=-QF(1)*SM(2)-QF(2)*SM(1)
      PN=0.0
      ASSIGN 014 TO LA
      GO TO 100
  014 SR(1)=+QF(1)*SM(1)-QF(2)*SM(2)
      SR(2)=+QF(1)*SM(2)+QF(2)*SM(1)
      GO TO 026
  015 QM=SN*0.3989422804014327*EXP(-0.5*ZL(1))
      QF(1)=QM*COS(-0.5*ZL(2))
      QF(2)=QM*SIN(-0.5*ZL(2))
      IF(AN.GT.1.0)GO TO 017
      PN=AN
      ASSIGN 016 TO LR
      GO TO 112
  016 TS(1)=QF(1)*SM(1)-QF(2)*SM(2)
      TS(2)=QF(1)*SM(2)+QF(2)*SM(1)
      SM(1)=TS(1)
      SM(2)=TS(2)
      GO TO 029
  017 PN=1.0
      ASSIGN 018 TO LR
      GO TO 112
  018 SQ(1)=-QF(1)*SM(1)+QF(2)*SM(2)
      SQ(2)=-QF(1)*SM(2)-QF(2)*SM(1)
      PN=0.0
      ASSIGN 019 TO LR
      GO TO 112
  019 SR(1)=+QF(1)*SM(1)-QF(2)*SM(2)
      SR(2)=+QF(1)*SM(2)+QF(2)*SM(1)
      GO TO 026
  020 QF(1)=SN*0.6366197723675813
      QF(2)=0.0
  021 IF(AN.GT.1.0)GO TO 023
      PN=AN
      ASSIGN 022 TO LY
      GO TO 122
  022 TS(1)=QF(1)*SM(1)-QF(2)*SM(2)
      TS(2)=QF(1)*SM(2)+QF(2)*SM(1)
      SM(1)=TS(1)
      SM(2)=TS(2)
      GO TO 029
  023 PN=1.0
      ASSIGN 024 TO LY
      GO TO 122
  024 SQ(1)=-QF(1)*SM(1)+QF(2)*SM(2)
      SQ(2)=-QF(1)*SM(2)-QF(2)*SM(1)
      PN=0.0
      ASSIGN 025 TO LY
      GO TO 122
  025 SR(1)=+QF(1)*SM(1)-QF(2)*SM(2)
      SR(2)=+QF(1)*SM(2)+QF(2)*SM(1)
  026 RZ(1)=+AZ(1)/ZS
      RZ(2)=-AZ(2)/ZS
      PN=0.0
      GO TO 028
  027 SQ(1)=SR(1)
      SQ(2)=SR(2)
      SR(1)=SM(1)
      SR(2)=SM(2)
  028 SM(1)=2.0*PN*(RZ(1)*SR(1)-RZ(2)*SR(2))-SQ(1)
      SM(2)=2.0*PN*(RZ(1)*SR(2)+RZ(2)*SR(1))-SQ(2)
      PN=PN+1.0
      IF(PN.LT.AN)GO TO 027
  029 W=CMPLX(SM(1),SM(2))
      RETURN
  100 SM(1)=0.0
      SM(2)=0.0
      SM(3)=0.0
      SM(4)=0.0
      RZ(1)=+0.5*QZ(1)/ZS
      RZ(2)=-0.5*QZ(2)/ZS
      QN=PN*PN-0.25
      TM(1)=1.0
      TM(2)=0.0
      PM=0.0
      GO TO 102
  101 QN=QN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=-QN*TS(1)/PM
      TM(2)=-QN*TS(2)/PM
  102 SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      QN=QN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=+QN*TS(1)/PM
      TM(2)=+QN*TS(2)/PM
      IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 103
      IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 104
  103 SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
      IF(PM.LT.35.0)GO TO 101
  104 AQ(1)=QZ(1)-1.57079632679490*(PN+0.5)
      AQ(2)=QZ(2)
      TS(1)=+COS(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2)))
      TS(2)=-SIN(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2)))
      TM(1)=SM(1)*TS(1)-SM(2)*TS(2)
      TM(2)=SM(1)*TS(2)+SM(2)*TS(1)
      TM(3)=SM(3)*TS(1)-SM(4)*TS(2)
      TM(4)=SM(3)*TS(2)+SM(4)*TS(1)
      TS(1)=+SIN(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2)))
      TS(2)=+COS(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2)))
      TM(1)=TM(1)-SM(3)*TS(1)+SM(4)*TS(2)
      TM(2)=TM(2)-SM(3)*TS(2)-SM(4)*TS(1)
      TM(3)=TM(3)+SM(1)*TS(1)-SM(2)*TS(2)
      TM(4)=TM(4)+SM(1)*TS(2)+SM(2)*TS(1)
  105 IF(AZ(1))106,110,110
  106 IF(AZ(2))107,108,108
  107 SM(1)=-2.0*TM(1)+TM(4)
      SM(2)=-2.0*TM(2)-TM(3)
      GO TO 109
  108 SM(1)=-2.0*TM(1)-TM(4)
      SM(2)=-2.0*TM(2)+TM(3)
  109 IF(PN.EQ.0.0)GO TO 111
      SM(1)=-SM(1)
      SM(2)=-SM(2)
      GO TO 111
  110 SM(1)=TM(3)
      SM(2)=TM(4)
  111 GO TO LA,(011,013,014)
  112 SM(1)=1.0
      SM(2)=0.0
      SM(3)=1.0
      SM(4)=0.0
      M=15.0*PN+2.0
      N=15.0*PN+15.0
      DO 113 I=M,N
      TS(1)=+QZ(2)-CD(I)
      TS(2)=-QZ(1)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      TS(1)=-QZ(2)-CD(I)
      TS(2)=+QZ(1)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
  113 CONTINUE
  114 AQ(1)=QZ(1)-1.57079632679490*(PN+0.5)
      AQ(2)=QZ(2)
      TS(1)=+COS(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2)))
      TS(2)=-SIN(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2)))
      TM(1)=+TS(1)*SM(1)-TS(2)*SM(2)+TS(1)*SM(3)-TS(2)*SM(4)
      TM(2)=+TS(1)*SM(2)+TS(2)*SM(1)+TS(1)*SM(4)+TS(2)*SM(3)
      TM(3)=+TS(1)*SM(2)+TS(2)*SM(1)-TS(1)*SM(4)-TS(2)*SM(3)
      TM(4)=-TS(1)*SM(1)+TS(2)*SM(2)+TS(1)*SM(3)-TS(2)*SM(4)
      TS(1)=+SIN(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2)))
      TS(2)=+COS(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2)))
      TM(1)=TM(1)-TS(1)*SM(2)-TS(2)*SM(1)+TS(1)*SM(4)+TS(2)*SM(3)
      TM(2)=TM(2)+TS(1)*SM(1)-TS(2)*SM(2)-TS(1)*SM(3)+TS(2)*SM(4)
      TM(3)=TM(3)+TS(1)*SM(1)-TS(2)*SM(2)+TS(1)*SM(3)-TS(2)*SM(4)
      TM(4)=TM(4)+TS(1)*SM(2)+TS(2)*SM(1)+TS(1)*SM(4)+TS(2)*SM(3)
  115 IF(AZ(1))116,120,120
  116 IF(AZ(2))117,118,118
  117 SM(1)=-2.0*TM(1)+TM(4)
      SM(2)=-2.0*TM(2)-TM(3)
      GO TO 119
  118 SM(1)=-2.0*TM(1)-TM(4)
      SM(2)=-2.0*TM(2)+TM(3)
  119 IF(PN.EQ.0.0)GO TO 121
      SM(1)=-SM(1)
      SM(2)=-SM(2)
      GO TO 121
  120 SM(1)=TM(3)
      SM(2)=TM(4)
  121 GO TO LR,(016,018,019)
  122 AQ(1)=1.0
      AQ(2)=0.0
      RN=0.0
      PM=0.0
      GO TO 124
  123 PM=PM+1.0
      RN=RN+0.5/PM
      TS(1)=0.5*(AZ(1)*AQ(1)-AZ(2)*AQ(2))
      TS(2)=0.5*(AZ(1)*AQ(2)+AZ(2)*AQ(1))
      AQ(1)=TS(1)/PM
      AQ(2)=TS(2)/PM
  124 IF(PM.LT.PN)GO TO 123
      SZ(1)=0.25*(AZ(1)-AZ(2))*(AZ(1)+AZ(2))
      SZ(2)=0.5*AZ(1)*AZ(2)
      SR(1)=0.0
      SR(2)=0.0
      SS=AQ(1)*AQ(1)+AQ(2)*AQ(2)
      TM(1)=+AQ(1)/SS
      TM(2)=-AQ(2)/SS
      PM=0.0
      GO TO 126
  125 TM(1)=TM(1)/(PN-PM)
      TM(2)=TM(2)/(PN-PM)
      SR(1)=SR(1)-0.5*TM(1)
      SR(2)=SR(2)-0.5*TM(2)
      PM=PM+1.0
      TS(1)=SZ(1)*TM(1)-SZ(2)*TM(2)
      TS(2)=SZ(1)*TM(2)+SZ(2)*TM(1)
      TM(1)=+TS(1)/PM
      TM(2)=+TS(2)/PM
  126 IF(PM.LT.PN)GO TO 125
      SM(1)=0.0
      SM(2)=0.0
      RM=1.0
      QM=0.0
      SL(1)=-0.115931515658412+ZL(1)-RN
      SL(2)=+ZL(2)
      PM=0.0
      GO TO 128
  127 QM=QM+RM
      PM=PM+1.0
      RM=0.25*ZS*RM/(PM*(PN+PM))
      TS(1)=SZ(1)*AQ(1)-SZ(2)*AQ(2)
      TS(2)=SZ(1)*AQ(2)+SZ(2)*AQ(1)
      AQ(1)=-TS(1)/(PM*(PN+PM))
      AQ(2)=-TS(2)/(PM*(PN+PM))
      SL(1)=SL(1)-0.5/PM-0.5/(PN+PM)
  128 TM(1)=AQ(1)*SL(1)-AQ(2)*SL(2)
      TM(2)=AQ(1)*SL(2)+AQ(2)*SL(1)
      SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      IF(QM+RM.GT.QM)GO TO 127
      SM(1)=SR(1)+SM(1)
      SM(2)=SR(2)+SM(2)
      GO TO LY,(022,024,025)
      END
      SUBROUTINE CBSSLI (Z, CNU, W)
C------------------------------------------------------------
C     CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE
C     FIRST KIND FOR COMPLEX ORDER CNU AND COMPLEX ARGUMENT
C     Z.  IT IS ASSUMED THAT -PI .LT. ARG Z .LE. PI.
C------------------------------------------------------------
      COMPLEX Z, CNU, W, NU, Z0
C
      DATA PIHALF /1.5707963267949/
C
      X = REAL(Z)
      Y = AIMAG(Z)
      IF (Y .LT. 0.0) GO TO 10
         Z0 = CMPLX(Y, -X)
         NU = CNU
         GO TO 20
   10 Z0 = CMPLX(-Y, X)
      NU = -CNU
C
   20 T = -PIHALF*AIMAG(NU)
      IF (T .GT. EXPARG(1)) GO TO 30
         W = (0.0, 0.0)
         RETURN
C
   30 CALL CBSSLJ (Z0, CNU, W)
      W = EXP(T)*W
      T = 0.5*REAL(NU)
      W = W*CMPLX(COS1(T),SIN1(T))
      RETURN
      END
      SUBROUTINE BSSLI (MO, A, IN, W)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR MODIFIED BESSEL FUNCTION OF INTEGRAL ORDER
C     ******************************************************************
C     MO = MODE OF OPERATION
C     A  = ARGUMENT (COMPLEX NUMBER)
C     IN = ORDER (INTEGER)
C     W  = FUNCTION OF FIRST KIND (COMPLEX NUMBER)
C     -------------------
      COMPLEX A, W
      DIMENSION AZ(2), FI(2)
      DIMENSION CD(30), CE(30)
      DIMENSION QZ(2), RZ(2), SZ(2), ZR(2)
      DIMENSION TS(2), TM(2), RM(4), SM(4), AQ(2), QF(2)
      DATA CD(1) / 0.00000000000000E00/,  CD(2) /-1.64899505142212E-2/,
     1     CD(3) /-7.18621880068536E-2/,  CD(4) /-1.67086878124866E-1/,
     2     CD(5) /-3.02582250219469E-1/,  CD(6) /-4.80613945245927E-1/,
     3     CD(7) /-7.07075239357898E-1/,  CD(8) /-9.92995790539516E-1/,
     4     CD(9) /-1.35583925612592E00/,  CD(10)/-1.82105907899132E00/,
     5     CD(11)/-2.42482175310879E00/,  CD(12)/-3.21956655708750E00/,
     6     CD(13)/-4.28658077248384E00/,  CD(14)/-5.77022816798128E00/,
     7     CD(15)/-8.01371260952526E00/
      DATA CD(16)/ 0.00000000000000E00/,  CD(17)/-5.57742429879505E-3/,
     1     CD(18)/-4.99112944172476E-2/,  CD(19)/-1.37440911652397E-1/,
     2     CD(20)/-2.67233784710566E-1/,  CD(21)/-4.40380166808682E-1/,
     3     CD(22)/-6.61813614872541E-1/,  CD(23)/-9.41861077665017E-1/,
     4     CD(24)/-1.29754130468326E00/,  CD(25)/-1.75407696719816E00/,
     5     CD(26)/-2.34755299882276E00/,  CD(27)/-3.13041332689196E00/,
     6     CD(28)/-4.18397120563729E00/,  CD(29)/-5.65251799214994E00/,
     7     CD(30)/-7.87863959810677E00/
      DATA CE(1) / 0.00000000000000E00/,  CE(2) /-4.80942336387447E-3/,
     1     CE(3) /-1.31366200347759E-2/,  CE(4) /-1.94843834008458E-2/,
     2     CE(5) /-2.19948900032003E-2/,  CE(6) /-2.09396625676519E-2/,
     3     CE(7) /-1.74600268458650E-2/,  CE(8) /-1.27937813362085E-2/,
     4     CE(9) /-8.05234421796592E-3/,  CE(10)/-4.15817375002760E-3/,
     5     CE(11)/-1.64317738747922E-3/,  CE(12)/-4.49175585314709E-4/,
     6     CE(13)/-7.28594765574007E-5/,  CE(14)/-5.38265230658285E-6/,
     7     CE(15)/-9.93779048036289E-8/
      DATA CE(16)/ 0.00000000000000E00/,  CE(17)/ 7.53805779200591E-2/,
     1     CE(18)/ 7.12293537403464E-2/,  CE(19)/ 6.33116224228200E-2/,
     2     CE(20)/ 5.28240264523301E-2/,  CE(21)/ 4.13305359441492E-2/,
     3     CE(22)/ 3.01350573947510E-2/,  CE(23)/ 2.01043439592720E-2/,
     4     CE(24)/ 1.18552223068074E-2/,  CE(25)/ 5.86055510956010E-3/,
     5     CE(26)/ 2.25465148267325E-3/,  CE(27)/ 6.08173041536336E-4/,
     6     CE(28)/ 9.84215550625747E-5/,  CE(29)/ 7.32139093038089E-6/,
     7     CE(30)/ 1.37279667384666E-7/
C     -------------------
      AZ(1)=REAL(A)
      AZ(2)=AIMAG(A)
      ZS=AZ(1)*AZ(1)+AZ(2)*AZ(2)
      ZM=SQRT(ZS)
      PN=IABS(IN)
      SN=+1.0
      IF(AZ(1))002,003,003
  002 QZ(1)=-AZ(1)
      QZ(2)=-AZ(2)
      IF(IN.EQ.IN/2*2)GO TO 004
      SN=-1.0
      GO TO 004
  003 QZ(1)=AZ(1)
      QZ(2)=AZ(2)
  004 IF(ZM.LE.17.5+0.5*PN*PN)GO TO 005
      QN=PN
      GO TO 011
  005 QN=0.5*ZM-0.5*ABS(QZ(1))+0.5*ABS(0.5*ZM-ABS(QZ(1)))
      IF(PN.LE.QN)GO TO 006
      QN=+AINT(0.0625*ZS)
      IF(PN.LE.QN)GO TO 039
      QN=PN
      GO TO 039
  006 IF(ZM.LE.17.5)GO TO 007
      QN=+AINT(SQRT(2.0*(ZM-17.5)))
      GO TO 011
  007 IF(ZS-1.0)009,008,008
  008 IF(-ABS(AZ(1))+0.096*AZ(2)*AZ(2))009,010,010
  009 QN=AINT(0.0625*ZS)
      IF(PN.LE.QN)GO TO 039
      QN=PN
      GO TO 039
  010 QN=0.0
  011 SZ(1)=QZ(1)
      SZ(2)=QZ(2)
      QM=SN*0.398942280401433
      ZR(1)=SQRT(SZ(1)+ZM)
      ZR(2)=SZ(2)/ZR(1)
      ZR(1)=0.707106781186548*ZR(1)
      ZR(2)=0.707106781186548*ZR(2)
      QF(1)=+QM*ZR(1)/ZM
      QF(2)=-QM*ZR(2)/ZM
      IF(ZM.LE.17.5)GO TO 017
  012 RZ(1)=+0.5*QZ(1)/ZS
      RZ(2)=-0.5*QZ(2)/ZS
      AN=QN*QN-0.25
      SM(1)=0.0
      SM(2)=0.0
      SM(3)=0.0
      SM(4)=0.0
      TM(1)=1.0
      TM(2)=0.0
      PM=0.0
      GO TO 014
  013 AN=AN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=AN*TS(1)/PM
      TM(2)=AN*TS(2)/PM
  014 SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      AN=AN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=AN*TS(1)/PM
      TM(2)=AN*TS(2)/PM
      IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 015
      IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 016
  015 SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
      IF(PM.LT.35.0)GO TO 013
  016 TS(1)=SM(1)+SM(3)
      TS(2)=SM(2)+SM(4)
      SM(1)=SM(1)-SM(3)
      SM(2)=SM(2)-SM(4)
      SM(3)=TS(1)
      SM(4)=TS(2)
      GO TO 019
  017 SM(1)=1.0
      SM(2)=0.0
      SM(3)=1.0
      SM(4)=0.0
      M=15.0*QN+2.0
      N=15.0*QN+15.0
      DO 018 I=M,N
      TS(1)=-QZ(1)-CD(I)
      TS(2)=-QZ(2)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      TS(1)=QZ(1)-CD(I)
      TS(2)=QZ(2)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
  018 CONTINUE
  019 RM(1)=SM(1)
      RM(2)=SM(2)
      IF(QZ(1).GE.17.5)GO TO 023
      AQ(1)=-2.0*QZ(1)
      IF(QZ(2))020,021,021
  020 AQ(2)=-2.0*QZ(2)-3.14159265358979*(QN+0.5)
      GO TO 022
  021 AQ(2)=-2.0*QZ(2)+3.14159265358979*(QN+0.5)
  022 QM=EXP(AQ(1))
      TS(1)=QM*COS(AQ(2))
      TS(2)=QM*SIN(AQ(2))
      RM(1)=RM(1)+TS(1)*SM(3)-TS(2)*SM(4)
      RM(2)=RM(2)+TS(1)*SM(4)+TS(2)*SM(3)
  023 IF(QN.EQ.PN)GO TO 037
      RM(3)=RM(1)
      RM(4)=RM(2)
      QN=QN+1.0
      IF(ZM.LE.17.5)GO TO 029
  024 AN=QN*QN-0.25
      SM(1)=0.0
      SM(2)=0.0
      SM(3)=0.0
      SM(4)=0.0
      TM(1)=1.0
      TM(2)=0.0
      PM=0.0
      GO TO 026
  025 AN=AN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=AN*TS(1)/PM
      TM(2)=AN*TS(2)/PM
  026 SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      AN=AN-2.0*PM
      PM=PM+1.0
      TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2)
      TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1)
      TM(1)=AN*TS(1)/PM
      TM(2)=AN*TS(2)/PM
      IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 027
      IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 028
  027 SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
      IF(PM.LT.35.0)GO TO 025
  028 TS(1)=SM(1)+SM(3)
      TS(2)=SM(2)+SM(4)
      SM(1)=SM(1)-SM(3)
      SM(2)=SM(2)-SM(4)
      SM(3)=TS(1)
      SM(4)=TS(2)
      GO TO 031
  029 SM(1)=1.0
      SM(2)=0.0
      SM(3)=1.0
      SM(4)=0.0
      M=15.0*QN+2.0
      N=15.0*QN+15.0
      DO 030 I=M,N
      TS(1)=-QZ(1)-CD(I)
      TS(2)=-QZ(2)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      TS(1)=+QZ(1)-CD(I)
      TS(2)=+QZ(2)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(3)=SM(3)+TM(1)
      SM(4)=SM(4)+TM(2)
  030 CONTINUE
  031 RM(1)=SM(1)
      RM(2)=SM(2)
      IF(QZ(1).GE.17.5)GO TO 036
      AQ(1)=-2.0*QZ(1)
      IF(QZ(2))032,033,033
  032 AQ(2)=-2.0*QZ(2)-3.14159265358979*(QN+0.5)
      GO TO 034
  033 AQ(2)=-2.0*QZ(2)+3.14159265358979*(QN+0.5)
  034 QM=EXP(AQ(1))
      TS(1)=QM*COS(AQ(2))
      TS(2)=QM*SIN(AQ(2))
      RM(1)=RM(1)+TS(1)*SM(3)-TS(2)*SM(4)
      RM(2)=RM(2)+TS(1)*SM(4)+TS(2)*SM(3)
      GO TO 036
  035 TM(1)=-2.0*QN*QZ(1)/ZS
      TM(2)=+2.0*QN*QZ(2)/ZS
      TS(1)=TM(1)*RM(1)-TM(2)*RM(2)+RM(3)
      TS(2)=TM(1)*RM(2)+TM(2)*RM(1)+RM(4)
      RM(3)=RM(1)
      RM(4)=RM(2)
      RM(1)=TS(1)
      RM(2)=TS(2)
      QN=QN+1.0
  036 IF(QN.LT.PN)GO TO 035
  037 IF(MO.NE.0)GO TO 038
      QM=EXP(QZ(1))
      TM(1)=QM*COS(QZ(2))
      TM(2)=QM*SIN(QZ(2))
      TS(1)=TM(1)*RM(1)-TM(2)*RM(2)
      TS(2)=TM(1)*RM(2)+TM(2)*RM(1)
      RM(1)=TS(1)
      RM(2)=TS(2)
  038 FI(1)=QF(1)*RM(1)-QF(2)*RM(2)
      FI(2)=QF(1)*RM(2)+QF(2)*RM(1)
      W=CMPLX(FI(1),FI(2))
      RETURN
  039 SZ(1)=0.25*(QZ(1)*QZ(1)-QZ(2)*QZ(2))
      SZ(2)=0.5*QZ(1)*QZ(2)
      AN=QN
      SM(1)=0.0
      SM(2)=0.0
      SM(3)=0.0
      SM(4)=0.0
      TM(1)=1.0
      TM(2)=0.0
      PM=0.0
  040 AN=AN+1.0
      TS(1)=TM(1)/AN
      TS(2)=TM(2)/AN
      SM(3)=SM(3)+TS(1)
      SM(4)=SM(4)+TS(2)
      TM(1)=TS(1)*SZ(1)-TS(2)*SZ(2)
      TM(2)=TS(1)*SZ(2)+TS(2)*SZ(1)
      PM=PM+1.0
      TM(1)=TM(1)/PM
      TM(2)=TM(2)/PM
      IF(ABS(SM(1))+ABS(TM(1)).NE.ABS(SM(1)))GO TO 041
      IF(ABS(SM(2))+ABS(TM(2)).EQ.ABS(SM(2)))GO TO 042
  041 SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      GO TO 040
  042 SM(1)=SM(1)+1.0
      AN=QN+1.0
      SM(3)=AN*SM(3)
      SM(4)=AN*SM(4)
      GO TO 044
  043 AN=QN*(QN+1.0)
      TM(1)=SZ(1)/AN
      TM(2)=SZ(2)/AN
      TS(1)=+TM(1)*SM(3)-TM(2)*SM(4)
      TS(2)=+TM(1)*SM(4)+TM(2)*SM(3)
      SM(3)=SM(1)
      SM(4)=SM(2)
      SM(1)=SM(1)+TS(1)
      SM(2)=SM(2)+TS(2)
      QN=QN-1.0
  044 IF(QN.GT.PN)GO TO 043
      QF(1)=SN
      QF(2)=0.0
      QN=0.0
      GO TO 046
  045 QN=QN+1.0
      TM(1)=QF(1)*QZ(1)-QF(2)*QZ(2)
      TM(2)=QF(1)*QZ(2)+QF(2)*QZ(1)
      QF(1)=0.5*TM(1)/QN
      QF(2)=0.5*TM(2)/QN
  046 IF(QN.LT.PN)GO TO 045
      IF(MO.EQ.0)GO TO 047
      QM=EXP(-QZ(1))
      TM(1)=QM*COS(-QZ(2))
      TM(2)=QM*SIN(-QZ(2))
      TS(1)=TM(1)*QF(1)-TM(2)*QF(2)
      TS(2)=TM(1)*QF(2)+TM(2)*QF(1)
      QF(1)=TS(1)
      QF(2)=TS(2)
  047 FI(1)=QF(1)*SM(1)-QF(2)*SM(2)
      FI(2)=QF(1)*SM(2)+QF(2)*SM(1)
      W=CMPLX(FI(1),FI(2))
      RETURN
      END
      SUBROUTINE BESI(X, ALPHA, KODE, N, Y, NZ)
C
C     WRITTEN BY D. E. AMOS AND S. L. DANIEL, JANUARY,1975.
C
C     REFERENCE
C         SAND-75-0152
C
C         CDC 6600 SUBROUTINES IBESS AND JBESS FOR BESSEL FUNCTIONS
C         I(NU,X) AND J(NU,X), X.GE.0, NU.GE.0  BY D.E. AMOS, S.L.
C         DANIEL, M.K. WESTON. ACM TRANS MATH SOFTWARE,3,PP 76-92
C         (1977)
C
C         TABLES OF BESSEL FUNCTIONS OF MODERATE OR LARGE ORDERS,
C         NPL MATHEMATICAL TABLES, VOL. 6, BY F.W.J. OLVER, HER
C         MAJESTY-S STATIONERY OFFICE, LONDON, 1962.
C
C     ABSTRACT
C         BESI COMPUTES AN N MEMBER SEQUENCE OF I BESSEL FUNCTIONS
C         I/SUB(ALPHA+K-1)/(X), K=1,...,N OR SCALED BESSEL FUNCTIONS
C         EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N FOR NON-NEGATIVE ALPHA
C         AND X. A COMBINATION OF THE POWER SERIES, THE ASYMPTOTIC
C         EXPANSION FOR X TO INFINITY, AND THE UNIFORM ASYMPTOTIC
C         EXPANSION FOR NU TO INFINITY ARE APPLIED OVER SUBDIVISIONS OF
C         THE (NU,X) PLANE. FOR VALUES NOT COVERED BY ONE OF THESE
C         FORMULAE, THE ORDER IS INCREMENTED BY AN INTEGER SO THAT ONE
C         OF THESE FORMULAE APPLY. BACKWARD RECURSION IS USED TO REDUCE
C         ORDERS BY INTEGER VALUES. THE ASYMPTOTIC EXPANSION FOR X TO
C         INFINITY IS USED ONLY WHEN THE ENTIRE SEQUENCE (SPECIFICALLY
C         THE LAST MEMBER) LIES WITHIN THE REGION COVERED BY THE
C         EXPANSION. LEADING TERMS OF THESE EXPANSIONS ARE USED TO TEST
C         FOR OVER OR UNDERFLOW WHERE APPROPRIATE. IF A SEQUENCE IS
C         REQUESTED AND THE LAST MEMBER WOULD UNDERFLOW, THE RESULT IS
C         SET TO ZERO AND THE NEXT LOWER ORDER TRIED, ETC., UNTIL A
C         MEMBER COMES ON SCALE OR ALL ARE SET TO ZERO. AN OVERFLOW
C         CANNOT OCCUR WITH SCALING.
C
C         BESI CALLS ASIK, GAMLN, SPMPAR, AND IPMPAR
C
C     DESCRIPTION OF ARGUMENTS
C
C         INPUT
C           X      - X.GE.0.0E0
C           ALPHA  - ORDER OF FIRST MEMBER OF THE SEQUENCE,
C                    ALPHA.GE.0.0E0
C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
C                    KODE=1 RETURNS
C                           Y(K)=        I/SUB(ALPHA+K-1)/(X),
C                                K=1,...,N
C                    KODE=2 RETURNS
C                           Y(K)=EXP(-X)*I/SUB(ALPHA+K-1)/(X),
C                                K=1,...,N
C           N      - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1
C
C         OUTPUT
C           Y      - A VECTOR WHOSE FIRST N COMPONENTS CONTAIN
C                    VALUES FOR I/SUB(ALPHA+K-1)/(X) OR SCALED
C                    VALUES FOR EXP(-X)*I/SUB(ALPHA+K-1)/(X),
C                    K=1,...,N DEPENDING ON KODE
C           NZ     - ERROR INDICATOR
C                    NZ= 0     NORMAL RETURN-COMPUTATION COMPLETED
C                    NZ=-1     X IS LESS THAN 0.0
C                    NZ=-2     ALPHA IS LESS THAN 0.0
C                    NZ=-3     N IS LESS THAN 1
C                    NZ=-4     KODE IS NOT 1 OR 2
C                    NZ=-5     X IS TOO LARGE FOR KODE=1
C                    NZ.GT.0   LAST NZ COMPONENTS OF Y SET TO 0.0
C                              BECAUSE OF UNDERFLOW
C
C     ERROR CONDITIONS
C         IMPROPER INPUT ARGUMENTS - A FATAL ERROR
C         OVERFLOW WITH KODE=1 - A FATAL ERROR
C         UNDERFLOW - A NON-FATAL ERROR(NZ.GT.0)
C
      INTEGER I, IALP, IN, INLIM, IS, I1, I2, K, KK, KM, KODE, KT,
     * N, NN, NS, NZ
      INTEGER IPMPAR
      REAL AIN, AK, AKM, ALPHA, ANS, AP, ARG, ATOL, TOLLN, DFN,
     * DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA,
     * RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL,
     * TRX, T2, X, XO2, XO2L, Y, Z
      REAL GAMLN, SPMPAR
      DIMENSION Y(N), TEMP(3)
      DATA RTTPI           / 3.98942280401433E-01/
      DATA INLIM           /          80         /
C     -------------------
C     IPMPAR(8) REPLACES IPMPAR(5) IN A DOUBLE PRECISION CODE
C     IPMPAR(9) REPLACES IPMPAR(6) IN A DOUBLE PRECISION CODE
C
C     DEFINITION OF THE TOLERANCES TOL AND ELIM
C
      TB = IPMPAR(4)
      TA = SPMPAR(1)/TB
      IF (TB.EQ.2.0E0) GO TO 1
      IF (TB.EQ.8.0E0) GO TO 2
      IF (TB.EQ.16.0E0) GO TO 3
      TB = ALOG(TB)
      GO TO 5
    1 TB = .69315E0
      GO TO 5
    2 TB = 2.07944E0
      GO TO 5
    3 TB = 2.77259E0
C
    5 TOL = AMAX1(TA,1.E-15)
      I1 = IPMPAR(5)
      I2 = IPMPAR(6)
C     LN(10**3) = 6.90776
      ELIM = FLOAT(-I2)*TB - 6.90776E0
C     TOLLN = -LN(TOL)
      TOLLN = FLOAT(I1)*TB
      TOLLN = AMIN1(TOLLN,34.5388E0)
C
C
C
      NZ = 0
      KT = 1
      IF (N-1) 590, 10, 20
   10 KT = 2
   20 NN = N
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570
      IF (X) 600, 30, 80
   30 IF (ALPHA) 580, 40, 50
   40 Y(1) = 1.0E0
      IF (N.EQ.1) RETURN
      I1 = 2
      GO TO 60
   50 I1 = 1
   60 DO 70 I=I1,N
        Y(I) = 0.0E0
   70 CONTINUE
      RETURN
   80 CONTINUE
      IF (ALPHA.LT.0.0E0) GO TO 580
C
      IALP = INT(ALPHA)
      FNI = FLOAT(IALP+N-1)
      FNF = ALPHA - FLOAT(IALP)
      DFN = FNI + FNF
      FNU = DFN
      IN = 0
      XO2 = X*0.5E0
      SXO2 = XO2*XO2
      ETX = FLOAT(KODE-1)
      SX = ETX*X
C
C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
C     APPLIED.
C
      IF (SXO2.LE.(FNU+1.0E0)) GO TO 90
      IF (X.LE.12.0E0) GO TO 110
      FN = 0.55E0*FNU*FNU
      FN = AMAX1(17.0E0,FN)
      IF (X.GE.FN) GO TO 430
      ANS = AMAX1(36.0E0-FNU,0.0E0)
      NS = INT(ANS)
      FNI = FNI + FLOAT(NS)
      DFN = FNI + FNF
      FN = DFN
      IS = KT
      KM = N - 1 + NS
      IF (KM.GT.0) IS = 3
      GO TO 120
   90 FN = FNU
      FNP1 = FN + 1.0E0
      XO2L = ALOG(XO2)
      IS = KT
      IF (X.LE.0.5E0) GO TO 230
      NS = 0
  100 FNI = FNI + FLOAT(NS)
      DFN = FNI + FNF
      FN = DFN
      FNP1 = FN + 1.0E0
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 230
  110 XO2L = ALOG(XO2)
      NS = INT(SXO2-FNU)
      GO TO 100
  120 CONTINUE
C
C     OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
C
      IF (KODE.EQ.2) GO TO 130
      IF (ALPHA.LT.1.0E0) GO TO 150
      Z = X/ALPHA
      RA = SQRT(1.0E0+Z*Z)
      GLN = ALOG((1.0E0+RA)/Z)
      T = RA*(1.0E0-ETX) + ETX/(Z+RA)
      ARG = ALPHA*(T-GLN)
      IF (ARG.GT.ELIM) GO TO 610
      IF (KM.EQ.0) GO TO 140
  130 CONTINUE
C
C     UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
C
      Z = X/FN
      RA = SQRT(1.0E0+Z*Z)
      GLN = ALOG((1.0E0+RA)/Z)
      T = RA*(1.0E0-ETX) + ETX/(Z+RA)
      ARG = FN*(T-GLN)
  140 IF (ARG.LT.(-ELIM)) GO TO 280
      GO TO 190
  150 IF (X.GT.ELIM) GO TO 610
      GO TO 130
C
C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
C
  160 IF (KM.NE.0) GO TO 170
      Y(1) = TEMP(3)
      RETURN
  170 TEMP(1) = TEMP(3)
      IN = NS
      KT = 1
      I1 = 0
  180 CONTINUE
      IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF(I1.EQ.2) GO TO 350
      Z = X/FN
      RA = SQRT(1.0E0+Z*Z)
      GLN = ALOG((1.0E0+RA)/Z)
      T = RA*(1.0E0-ETX) + ETX/(Z+RA)
      ARG = FN*(T-GLN)
  190 CONTINUE
      I1 = IABS(3-IS)
      I1 = MAX0(I1,1)
      FLGIK = 1.0E0
      CALL ASIK(X,FN,KODE,FLGIK,RA,ARG,I1,TOL,TEMP(IS))
      GO TO (180, 350, 510), IS
C
C     SERIES FOR (X/2)**2.LE.NU+1
C
  230 CONTINUE
      GLN = GAMLN(FNP1)
      ARG = FN*XO2L - GLN - SX
      IF (ARG.LT.(-ELIM)) GO TO 300
      EARG = EXP(ARG)
  240 CONTINUE
      S = 1.0E0
      IF (X.LT.TOL) GO TO 260
      AK = 3.0E0
      T2 = 1.0E0
      T = 1.0E0
      S1 = FN
      DO 250 K=1,17
        S2 = T2 + S1
        T = T*SXO2/S2
        S = S + T
        IF (ABS(T).LT.TOL) GO TO 260
        T2 = T2 + AK
        AK = AK + 2.0E0
        S1 = S1 + FN
  250 CONTINUE
  260 CONTINUE
      TEMP(IS) = S*EARG
      GO TO (270, 350, 500), IS
  270 EARG = EARG*FN/XO2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IS = 2
      GO TO 240
C
C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
C
  280 Y(NN) = 0.0E0
      NN = NN - 1
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 340, 290, 130
  290 KT = 2
      IS = 2
      GO TO 130
  300 Y(NN) = 0.0E0
      NN = NN - 1
      FNP1 = FN
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 340, 310, 320
  310 KT = 2
      IS = 2
  320 IF (SXO2.LE.FNP1) GO TO 330
      GO TO 130
  330 ARG = ARG - XO2L + ALOG(FNP1)
      IF (ARG.LT.(-ELIM)) GO TO 300
      GO TO 230
  340 NZ = N - NN
      RETURN
C
C     BACKWARD RECURSION SECTION
C
  350 CONTINUE
      NZ = N - NN
  360 CONTINUE
      IF(KT.EQ.2) GO TO 420
      S1 = TEMP(1)
      S2 = TEMP(2)
      TRX = 2.0E0/X
      DTM = FNI
      TM = (DTM+FNF)*TRX
      IF (IN.EQ.0) GO TO 390
C     BACKWARD RECUR TO INDEX ALPHA+NN-1
      DO 380 I=1,IN
        S = S2
        S2 = TM*S2 + S1
        S1 = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  380 CONTINUE
      Y(NN) = S1
      IF (NN.EQ.1) RETURN
      Y(NN-1) = S2
      IF (NN.EQ.2) RETURN
      GO TO 400
  390 CONTINUE
C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
      Y(NN) = S1
      Y(NN-1) = S2
      IF (NN.EQ.2) RETURN
  400 K = NN + 1
      DO 410 I=3,NN
        K = K - 1
        Y(K-2) = TM*Y(K-1) + Y(K)
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  410 CONTINUE
      RETURN
  420 Y(1) = TEMP(2)
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR X TO INFINITY
C
  430 CONTINUE
      EARG = RTTPI/SQRT(X)
      IF (KODE.EQ.2) GO TO 440
      IF (X.GT.ELIM) GO TO 610
      EARG = EARG*EXP(X)
  440 ETX = 8.0E0*X
      IS = KT
      IN = 0
      FN = FNU
  450 DX = FNI + FNI
      TM = 0.0E0
      IF (FNI.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 460
      TM = 4.0E0*FNF*(FNI+FNI+FNF)
  460 CONTINUE
      DTM = DX*DX
      S1 = ETX
      TRX = DTM - 1.0E0
      DX = -(TRX+TM)/ETX
      T = DX
      S = 1.0E0 + DX
      ATOL = TOL*ABS(S)
      S2 = 1.0E0
      AK = 8.0E0
      DO 470 K=1,25
        S1 = S1 + ETX
        S2 = S2 + AK
        DX = DTM - S2
        AP = DX + TM
        T = -T*AP/S1
        S = S + T
        IF (ABS(T).LE.ATOL) GO TO 480
        AK = AK + 8.0E0
  470 CONTINUE
  480 TEMP(IS) = S*EARG
      IF(IS.EQ.2) GO TO 360
      IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      GO TO 450
C
C     BACKWARD RECURSION WITH NORMALIZATION BY
C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
C
  500 CONTINUE
C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
      AKM = AMAX1(3.0E0-FN,0.0E0)
      KM = INT(AKM)
      TFN = FN + FLOAT(KM)
      TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
      TA = XO2L - TA
      TB = -(1.0E0-1.0E0/TFN)/TFN
      AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
      IN = INT(AIN)
      IN = IN + KM
      GO TO 520
  510 CONTINUE
C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
      T = 1.0E0/(FN*RA)
      AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5E0
      IN = INT(AIN)
      IF (IN.GT.INLIM) GO TO 160
  520 CONTINUE
      TRX = 2.0E0/X
      DTM = FNI + FLOAT(IN)
      TM = (DTM+FNF)*TRX
      TA = 0.0E0
      TB = TOL
      KK = 1
  530 CONTINUE
C
C     BACKWARD RECUR UNINDEXED
C
      DO 540 I=1,IN
        S = TB
        TB = TM*TB + TA
        TA = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  540 CONTINUE
C     NORMALIZATION
      IF (KK.NE.1) GO TO 550
      TA = (TA/TB)*TEMP(3)
      TB = TEMP(3)
      KK = 2
      IN = NS
      IF (NS.NE.0) GO TO 530
  550 Y(NN) = TB
      NZ = N - NN
      IF (NN.EQ.1) RETURN
      TB = TM*TB + TA
      K = NN - 1
      Y(K) = TB
      IF (NN.EQ.2) RETURN
      DTM = DTM - 1.0E0
      TM = (DTM+FNF)*TRX
      KM = K - 1
C
C     BACKWARD RECUR INDEXED
C
      DO 560 I=1,KM
        Y(K-1) = TM*Y(K) + Y(K+1)
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
        K = K - 1
  560 CONTINUE
      RETURN
C
C
C
  570 CONTINUE
      NZ = -4
      RETURN
  580 CONTINUE
      NZ = -2
      RETURN
  590 CONTINUE
      NZ = -3
      RETURN
  600 CONTINUE
      NZ = -1
      RETURN
  610 CONTINUE
      NZ = -5
      RETURN
      END
      SUBROUTINE ASIK(X,FNU,KODE,FLGIK,RA,ARG,IN,TOL,Y)
C
C                  ASIK COMPUTES BESSEL FUNCTIONS I AND K
C                  FOR ARGUMENTS X.GT.0.0 AND ORDERS FNU.GE.35
C                  ON FLGIK = 1 AND FLGIK = -1 RESPECTIVELY.
C
C                                    INPUT
C
C      X    - ARGUMENT, X.GT.0.0E0
C      FNU  - ORDER OF FIRST BESSEL FUNCTION
C      KODE - A PARAMETER TO INDICATE THE SCALING OPTION
C             KODE=1 RETURNS Y(I)=        I/SUB(FNU+I-1)/(X), I=1,IN
C                    OR      Y(I)=        K/SUB(FNU+I-1)/(X), I=1,IN
C                    ON FLGIK = 1.0E0 OR FLGIK = -1.0E0
C             KODE=2 RETURNS Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN
C                    OR      Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN
C                    ON FLGIK = 1.0E0 OR FLGIK = -1.0E0
C     FLGIK - SELECTION PARAMETER FOR I OR K FUNCTION
C             FLGIK =  1.0E0 GIVES THE I FUNCTION
C             FLGIK = -1.0E0 GIVES THE K FUNCTION
C        RA - SQRT(1.+Z*Z), Z=X/FNU
C       ARG - ARGUMENT OF THE LEADING EXPONENTIAL
C        IN - NUMBER OF FUNCTIONS DESIRED, IN=1 OR 2
C       TOL - TOLERANCE SPECIFIED BY BESI OR BESK
C
C                                    OUTPUT
C
C         Y - A VECTOR WHOSE FIRST IN COMPONENTS CONTAIN THE SEQUENCE
C
C                                 WRITTEN BY
C                                 D. E. AMOS
C
C     ABSTRACT
C         ASIK IMPLEMENTS THE UNIFORM ASYMPTOTIC EXPANSION OF
C         THE I AND K BESSEL FUNCTIONS FOR FNU.GE.35 AND REAL
C         X.GT.0.0E0. THE FORMS ARE IDENTICAL EXCEPT FOR A CHANGE
C         IN SIGN OF SOME OF THE TERMS. THIS CHANGE IN SIGN IS
C         ACCOMPLISHED BY MEANS OF THE FLAG FLGIK = 1 OR -1.
C
      INTEGER IN, J, JN, K, KK, KODE, L
      REAL AK,AP,ARG,C, COEF,CON,ETX,FLGIK,FN, FNU,GLN,RA,S1,S2,
     * T, TOL, T2, X, Y, Z
      DIMENSION Y(*), C(65), CON(2)
      DATA CON(1), CON(2)  /
     1        3.98942280401432678E-01,    1.25331413731550025E+00/
      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
     2     C(19), C(20), C(21), C(22), C(23), C(24)/
     3       -2.08333333333333E-01,        1.25000000000000E-01,
     4        3.34201388888889E-01,       -4.01041666666667E-01,
     5        7.03125000000000E-02,       -1.02581259645062E+00,
     6        1.84646267361111E+00,       -8.91210937500000E-01,
     7        7.32421875000000E-02,        4.66958442342625E+00,
     8       -1.12070026162230E+01,        8.78912353515625E+00,
     9       -2.36408691406250E+00,        1.12152099609375E-01,
     A       -2.82120725582002E+01,        8.46362176746007E+01,
     B       -9.18182415432400E+01,        4.25349987453885E+01,
     C       -7.36879435947963E+00,        2.27108001708984E-01,
     D        2.12570130039217E+02,       -7.65252468141182E+02,
     E        1.05999045252800E+03,       -6.99579627376133E+02/
      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
     3        2.18190511744212E+02,       -2.64914304869516E+01,
     4        5.72501420974731E-01,       -1.91945766231841E+03,
     5        8.06172218173731E+03,       -1.35865500064341E+04,
     6        1.16553933368645E+04,       -5.30564697861340E+03,
     7        1.20090291321635E+03,       -1.08090919788395E+02,
     8        1.72772750258446E+00,        2.02042913309661E+04,
     9       -9.69805983886375E+04,        1.92547001232532E+05,
     A       -2.03400177280416E+05,        1.22200464983017E+05,
     B       -4.11926549688976E+04,        7.10951430248936E+03,
     C       -4.93915304773088E+02,        6.07404200127348E+00,
     D       -2.42919187900551E+05,        1.31176361466298E+06,
     E       -2.99801591853811E+06,        3.76327129765640E+06/
      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
     2     C(65)/
     3       -2.81356322658653E+06,        1.26836527332162E+06,
     4       -3.31645172484564E+05,        4.52187689813627E+04,
     5       -2.49983048181121E+03,        2.43805296995561E+01,
     6        3.28446985307204E+06,       -1.97068191184322E+07,
     7        5.09526024926646E+07,       -7.41051482115327E+07,
     8        6.63445122747290E+07,       -3.75671766607634E+07,
     9        1.32887671664218E+07,       -2.78561812808645E+06,
     A        3.08186404612662E+05,       -1.38860897537170E+04,
     B        1.10017140269247E+02/
C     ---------------------
      FN = FNU
      Z  = (3.0E0-FLGIK)/2.0E0
      KK = INT(Z)
      DO 50 JN=1,IN
        IF (JN.EQ.1) GO TO 10
        FN = FN - FLGIK
        Z = X/FN
        RA = SQRT(1.0E0+Z*Z)
        GLN = ALOG((1.0E0+RA)/Z)
        ETX = FLOAT(KODE-1)
        T = RA*(1.0E0-ETX) + ETX/(Z+RA)
        ARG = FN*(T-GLN)*FLGIK
   10   COEF = EXP(ARG)
        T = 1.0E0/RA
        T2 = T*T
        T = T/FN
        T = SIGN(T,FLGIK)
        S2 = 1.0E0
        AP = 1.0E0
        L = 0
        DO 30 K=2,11
          L = L + 1
          S1 = C(L)
          DO 20 J=2,K
            L = L + 1
            S1 = S1*T2 + C(L)
   20     CONTINUE
          AP = AP*T
          AK = AP*S1
          S2 = S2 + AK
          IF (AMAX1(ABS(AK),ABS(AP)) .LT. TOL) GO TO 40
   30   CONTINUE
   40   CONTINUE
      T = ABS(T)
      Y(JN) = S2*COEF*SQRT(T)*CON(KK)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE CBESK (Z, CNU, W)
C-----------------------------------------------------------------------
C
C        CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE
C        SECOND KIND FOR COMPLEX ORDER CNU AND COMPLEX ARGUMENT
C        Z.  IT IS ASSUMED THAT -PI .LT. ARG Z .LE. PI.
C
C-----------------------------------------------------------------------
C     WRITTEN BY
C        ALFRED H. MORRIS, JR. AND ANDREW H. VAN TUYL
C        NAVAL SURFACE WARFARE CENTER
C        OCT 1992
C--------------------------
      COMPLEX Z, CNU, W
      COMPLEX NU
C
      X = ABS(REAL(Z))
      Y = ABS(AIMAG(Z))
      NU = CNU
      IF (REAL(NU) .LT. 0.0) NU = - NU
      A = REAL(NU)
      B = ABS(AIMAG(NU))
      RN = CPABS(A, B)
      RZ = CPABS(X, Y)
C
C     ASYMPTOTIC EXPANSION
C
      IF (RZ .LT. 17.5 + 0.5*RN*RN) GO TO 10
         CALL CBKA (Z, NU, W)
         RETURN
C
   10 IF (B .LE. 1.5E-2*A) GO TO 200
      TAU = RN/RZ
      IF (TAU .GE. 1.5) GO TO 100
      IF (TAU .LE. 0.05) GO TO 200
      IF (TAU .LT. 0.70 .AND. REAL(Z) .LE. 0.0) GO TO 100
      IF (AIMAG(NU) .GT. 0.0 .AND. B .LT. 0.07*A) GO TO 200
C
      IF (TAU .LT. 1.291) GO TO 20
      IF (AIMAG(NU) .LT. 0.0 .AND. B .LT. 0.127*A) GO TO 40
         S = 0.5*(1.5 - TAU)
         IF (B .LT. S*A) GO TO 200
         GO TO 100
C
   20 IF (TAU .LT. 0.639) GO TO 60
      IF (TAU .GT. 0.691) GO TO 30
         IF (B .GT. 0.5*A) GO TO 61
         E = B/A
         GO TO 50
C
   30 IF (B .LT. 0.191*A) GO TO 40
      IF (TAU .GT. 0.99 .AND. B .GT. 0.257*A .AND.
     *    B .LT. 0.64*A) GO TO 61
      IF (TAU .LE. 1.16 .AND. B .LT. 0.727*A .AND.
     *    Y .LT. 0.727*X) GO TO 200
      IF (TAU .LE. 0.91 .AND. A .GT. 0.45*B .AND.
     *    Y .LT. 0.325*X) GO TO 200
      C = 0.471
      IF (TAU .LT. 0.75) C = 0.55
      IF (TAU .LT. 0.844 .AND. A .LT. 0.55*B .AND.
     *    Y .LT. C*X) GO TO 200
C
   40 S = 1.65*(1.54 - TAU)**2
      IF (TAU .LT. 0.91) S = 0.82 - 1.5*(TAU - 0.8)
      E = 2.25
      IF (TAU .LT. 0.78) E = 2.90
      IF (B .GT. E*S*A) GO TO 100
      IF (B .GT. 0.5*A) GO TO 61
C
      E = B/(S*A)
      IF (E .LT. 0.50) GO TO 50
         C = 2.83 - 1.66*E
         IF (Y .GT. C*X) GO TO 100
         GO TO 200
   50 C = 7.0 - 10.0*E
      IF (TAU .GT. 0.86) C = 8.0 - 12.0*E
      IF (Y .GT. C*X) GO TO 100
      GO TO 200
C
   60 IF (B .LE. 0.191*A) GO TO 200
   61 IF (X .LT. 0.64*(TAU - 0.2)*Y) GO TO 100
      S = 1.5*B/(A + 1.E-7)
      E = 0.95
      IF (TAU .GT. 0.95 .AND. TAU .LT. 1.16 .AND.
     *    B .GT. 0.471*A .AND. B .LE. A) E = 0.75
      IF (TAU .GT. 0.85 .AND. TAU .LE. 0.95 .AND.
     *    B .LE. A) E = 0.80
      IF (TAU .GT. 0.71 .AND. TAU .LE. 0.85 .AND.
     *    B .LT. 1.21*A) E = 0.85
      IF (TAU .GT. 0.61 .AND. TAU .LE. 0.71 .AND.
     *    B .GT. 0.63*A .AND. B .LT. 1.15*A) E = 0.80
      IF (TAU .GT. 0.50 .AND. TAU .LE. 0.61 .AND.
     *    B .GT. 0.7*A .AND. B .LE. A) E = 0.70
C
      IF (TAU .GT. 0.68 .AND. TAU .LE. 0.77 .AND.
     *    A .LT. 0.75*B) E = 1.15
      IF (TAU .GT. 0.77 .AND. TAU .LT. 0.95 .AND.
     *    A .LT. 0.83*B) E = 1.10
      C = (1.0 + E*TAU)*TAU*TANH(S)**2
      IF (X .GE. C*Y) GO TO 200
C
C     CALCULATION IN TERMS OF THE MODIFIED
C     BESSEL FUNCTION I
C
  100 CALL CBKI (Z, NU, W)
      RETURN
C
C     POWER SERIES AND MILLER ALGORITHM
C
  200 CALL CBKM (Z, RZ, NU, W)
      RETURN
      END
      SUBROUTINE CBKI (Z, CNU, W)
C------------------------------------------------------------
C     CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE
C     SECOND KIND WITH COMPLEX ORDER AND ARGUMENT IN TERMS
C     OF THE MODIFIED BESSEL FUNCTION OF THE FIRST KIND.
C------------------------------------------------------------
      COMPLEX Z, CNU, W, W1, W2
      COMPLEX CDIV
C
      DATA PI/3.14159265358979E+00/
      DATA PIHALF/1.5707963267949E+00/
C
      CALL CBSSLI (Z, -CNU, W1)
      CALL CBSSLI (Z, CNU, W2)
      A = REAL(CNU)
      B = PI*AIMAG(CNU)
      U1 = SIN1(A)*COSH(B)
      U2 = COS1(A)*SINH(B)
      W = PIHALF*CDIV(W1 - W2, CMPLX(U1,U2))
      RETURN
      END
      SUBROUTINE CBKA (Z, CNU, W)
C-----------------------------------------------------------------------
C        COMPUTATION OF THE BESSEL FUNCTION K FOR COMPLEX ORDER
C        CNU AND COMPLEX ARGUMENT Z BY THE ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      COMPLEX Z, CNU, W
      REAL M
      COMPLEX A, P, T, ZR
C--------------------------
      ANORM(Z) = AMAX1(ABS(REAL(Z)), ABS(AIMAG(Z)))
C--------------------------
C     C = PI**(1/2)
C--------------------------
      DATA C /1.77245385090552E+00/
C--------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 .
C
                      EPS = SPMPAR(1)
C
C--------------------------
      CALL CREC (REAL(Z), AIMAG(Z), U, V)
      ZR = CMPLX(0.5*U, 0.5*V)
      A = CNU*CNU - 0.25
      M = 1.0
      T = A*ZR
      P = T
C
      DO 10 I = 1, 16
         A = A - 2.0*M
         M = M + 1.0
         T = T*A*ZR/M
         P = P + T
         IF (ANORM(T) .LE. EPS*ANORM(P)) GO TO 20
   10 CONTINUE
C
   20 P = P + 1.0
      T = CSQRT(ZR)
      IF (AIMAG(Z) .EQ. 0.0) T = CONJG(T)
      W = C*T*P*CEXP(-Z)
      RETURN
      END
      SUBROUTINE CBKM (Z, RZ, CNU, W)
C-------------------------------------------------------------------
C     CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE SECOND
C     KIND WITH COMPLEX ORDER AND ARGUMENT BY MEANS OF MACLAURIN
C     EXPANSIONS AND THE MILLER ALGORITHM. IT IS ASSUMED THAT
C     RZ = ABS(Z).
C-------------------------------------------------------------------
      COMPLEX Z, CNU, W
      REAL NU
      COMPLEX CZ, EX, R, R1, U1, U2, U3, W1, W2, ZR
      COMPLEX CXP
C---------------------------
C     CPI = SQRT(PI/2)
C---------------------------
      DATA PI  /3.14159265358979/
      DATA CPI /1.25331413731550/
C
C        REDUCTION OF CNU TO R = NU + B*I WHERE
C                -0.5 .LT. NU .LE. 0.5
C
      R = CNU
      IF (REAL(R) .LT. 0.0) R = - R
C
      A = REAL(R)
      B = AIMAG(R)
      N = A
      NU = A - FLOAT(N)
      T = NU - 0.5
      IF (T .LE. 0.0) GO TO 10
         NU = T - 0.5
         N = N + 1
   10 M = N
      R1 = CMPLX(NU, B)
C
      IND = 1
      CZ = Z
      X = 0.5*REAL(Z)
      Y = 0.5*AIMAG(Z)
      CALL CREC (X, Y, ZR1, ZR2)
      ZR = CMPLX (ZR1, ZR2)
      IF (T .NE. 0.0) GO TO 20
      IF (B .NE. 0.0) GO TO 20
C
C               CALCULATION FOR NU = 0.5
C
      W = CMPLX(CPI, 0.0)
      W1 = (1.0, 0.0)
      IF (N .EQ. 0) GO TO 90
      IF (X .GE. 0.0) GO TO 15
         IND = -1
         CZ = - Z
         ZR = - ZR
   15 U1 = W
      U2 = W
      N = N + 1
      R1 = (-0.5, 0.0)
      GO TO 70
C
C           CALCULATION FOR ABS(NU) .LT. 0.5
C
   20 ZNORM = 0.5*RZ
      IF (ZNORM .GT. 1.0) GO TO 30
         IND = 0
         CALL CKPS (Z, ZNORM, ZR, R1, U1, U2)
         GO TO 50
   30 U1 = (1.0, 0.0)
      IF (X .LT. 0.0) GO TO 40
         CALL CBKML (Z, ZNORM, ZR, R1, N, W1, U2)
         GO TO 50
   40 IND = -1
      CZ = - Z
      ZR = - ZR
      CALL CBKML (CZ, ZNORM, ZR, R1, N, W1, U2)
C
   50 IF (N .GT. 1) GO TO 70
      W = U1
      IF (N .NE. 0) W = U2
      GO TO 90
C
C                 RECURSION
C
   70 N1 = N - 1
      DO 80 I = 1, N1
         AI = I
         U3 = (R1 + AI)*ZR*U2 + U1
         U1 = U2
         U2 = U3
   80 CONTINUE
      W = U3
C
   90 IF (IND .EQ. 0) RETURN
      W = W*W1*CEXP(-CZ)/CSQRT(CZ)
      IF (IND .GT. 0) RETURN
C
C            ANALYTIC CONTINUATION
C
      C = EXP(0.5*B*PI)
      EX = CXP(M, NU)
      IF (Y .LT. 0.0) GO TO 100
         EX = C*EX
         W1 = CMPLX (AIMAG(Z), -REAL(Z))
         CALL CBSSLJ (W1, R, W2)
         W2 = CMPLX (PI*AIMAG(W2), -PI*REAL(W2))
         W = EX*(EX*W + W2)
         RETURN
  100 EX = CONJG(EX)/C
      W1 = CMPLX (-AIMAG(Z), REAL(Z))
      CALL CBSSLJ (W1, R, W2)
      W2 = CMPLX (-PI*AIMAG(W2), PI*REAL(W2))
      W = EX*(EX*W + W2)
      RETURN
      END
      SUBROUTINE CKPS (Z, R, ZR, NU, W1, W2)
C-----------------------------------------------------------------------
C
C        CALCULATION OF THE MODIFIED BESSEL FUNCTIONS
C
C                  W1 = K  (Z)  AND  W2 = K    (Z)
C                        NU                NU+1
C
C     FOR A COMPLEX ARGUMENT Z WHERE ABS(Z) .LE. 2 AND A COMPLEX
C     ORDER NU WHERE ABS(REAL(NU)) .LE. 0.5.  IT IS ASSUMED THAT
C     -PI .LT. ARG Z .LE. PI, R = ABS(Z/2), AND ZR = 2/Z.  POWER
C     SERIES EXPANSIONS ARE USED.
C
C-----------------------------------------------------------------------
      COMPLEX Z, ZR, NU, W1, W2
      REAL D(7)
      COMPLEX A, C, CH, CL, F, G1, G2, GM1, GM2, MU, P, Q, SH,
     *        T, T1, T2
      COMPLEX CDIV, CGAM0
C-----------------------
      DATA TOL /1.E-10/
      DATA PI /3.14159265358979/
C-----------------------
      DATA D(1) / .577215664901533E+00/,  D(2) /-.420026350340952E-01/,
     *     D(3) /-.421977345555443E-01/,  D(4) / .721894324666310E-02/,
     *     D(5) /-.215241674114951E-03/,  D(6) /-.201348547807882E-04/,
     *     D(7) / .113302723198170E-05/
C-----------------------
      ANORM(T) = AMAX1(ABS(REAL(T)), ABS(AIMAG(T)))
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      EPS0 = AMAX1(EPS, 5.E-15)
C
C                     CL = - LN(Z/2)
C
      PHI = ATAN2(AIMAG(Z),REAL(Z))
      CL = CMPLX(-ALOG(R), -PHI)
      MU = NU*CL
      C = CEXP(MU)
C
C                   G1 = GAMMA(1 + NU)
C                   G2 = GAMMA(1 - NU)
C
      T = PI*NU
      IF (ANORM(NU) .GT. TOL) GO TO 10
         A = 1.0 + (T*T)/6.0
         GO TO 20
   10 A = T/CSIN(T)
C
   20 S = REAL(NU)**2 + AIMAG(NU)**2
      IF (S .GE. 1.0) GO TO 21
         T = CGAM0(NU)
         G1 = 1.0/T
         G2 = A*T
         GO TO 30
   21 T = 0.5 + (0.5 + NU)
      CALL CGAMMA (0, T, G1)
      G2 = CDIV(A,G1)
C
   30 GM2 = 0.5*(G1 + G2)
      IF (S .GT. 0.04) GO TO 31
C
C         THE FOLLOWING IS THE TAYLOR SERIES FOR
C     W1 = (1/G2 - 1/G1)/(2*NU). NOTE THAT G1*G2 = A.
C
         T = NU*NU
         W1 = -((((((D(7)*T + D(6))*T + D(5))*T + D(4))*T +
     *                        D(3))*T + D(2))*T + D(1))
         GM1 = A*W1
         GO TO 40
   31 GM1 = 0.5*(G1 - G2)/NU
C
C            INITIALIZATION OF THE SUMMATION
C
   40 P = 0.5*C*G1
      Q = 0.5*CDIV(G2,C)
      X = REAL(MU)
      Y = AIMAG(MU)
      IF (ANORM(MU) .GT. TOL) GO TO 50
         U = X*Y
         SH = CMPLX(1.0, U/3.0)
         CH = CMPLX(1.0, U)
         GO TO 60
   50 T = CMPLX (-Y, X)
      SH = CSIN(T)/T
      CH = CCOS(T)
C
   60 F = GM1*CH + GM2*CL*SH
      C = (1.0, 0.0)
      W1 = F
      W2 = P
C
C                 SUMMATION OF SERIES
C
      T = 0.25*(Z*Z)
      DO 70 K = 1, 50
         AK = K
         F = (AK*F + P + Q)/((AK - NU)*(AK + NU))
         P = P/(AK - NU)
         Q = Q/(AK + NU)
         C = C*T/AK
         T1 = C*F
         W1 = W1 + T1
         T2 = C*(P - AK*F)
         W2 = W2 + T2
         IF (ANORM(T1) .LE. EPS0*ANORM(W1)) GO TO 80
   70 CONTINUE
C
   80 W2 = W2 * ZR
      RETURN
      END
      SUBROUTINE CBKML (Z, R, ZR, NU, N, W, W0)
C-----------------------------------------------------------------------
C
C             COMPUTATION OF THE SCALED BESSEL FUNCTION
C
C                   W = (EXP(Z)*SQRT(Z)) K  (Z)
C                                         NU
C     AND THE VALUE
C
C                   W0 = K    (Z) /K  (Z)
C                         NU+1      NU
C
C     FOR COMPLEX ORDERS NU AND NU + 1 AND FOR COMPLEX ARGUMENT Z
C     BY USE OF THE MILLER ALGORITHM. FOR THE GREATEST ACCURACY,
C     Z SHOULD LIE IN A SECTOR SLIGHTLY LARGER THAN THE RIGHT HALF
C     PLANE. IT IS ASSUMED THAT ABS(REAL(NU)) .LT. 0.5, AND THAT
C     R = ABS(Z/2) AND ZR = 2/Z.
C
C-----------------------------------------------------------------------
      COMPLEX Z, ZR, NU, W, W0
      COMPLEX AL, BL, S, U1, U2, U3
      REAL INU, L
C---------------------
C     C1 = SQRT(PI/2)
C     C2 = SQRT(PI)
C---------------------
      DATA C1 /1.25331413731559E+00/
      DATA C2 /1.77245385090552E+00/
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      EPS0 = AMAX1(EPS, 5.E-15)
C
      X = REAL(Z)
      Y = AIMAG(Z)
      RNU = REAL(NU)
      INU = AIMAG(NU)
C
C     CALCULATION OF M FOR USE IN MILLER ALGORITHM.
C
      TH = ATAN2(Y,X)
      A = 3.0/(1.0 + R)
      B = 14.7/(28.0 + R)
      F = (2.0*R)**(0.25)
      IF (RNU .EQ. 0.5 .AND. INU .NE. 0.0) GO TO 10
         C = 4.0*COS1(RNU)/(C1*EPS0*F)
         GO TO 20
   10 C = 4.0*C2/F
   20 M = (0.485/R)*(ALOG(C) + R*COS(A*TH)/(1.0 + 0.008*R))**2/
     *    (2.0*COS(B*TH))**2 + 1.5
      T = 0.0
      IF (R .GT. 22.5) T = 0.01*(R - 22.5)**2
      NUM = 35.0 + 0.8*(R - 22.5) + T
      IF (INU .NE. 0.0) M = M + NUM
      C = N
      IF (C + RNU .LT. 0.327*ABS(INU)) M = M + 10
C
C     BACKWARD RECURRENCE IN MILLER ALGORITHM.
C
      A = (0.5 - RNU)*(0.5 + RNU) + INU*INU
      E = 2.0*RNU*INU
      U2 = (0.0, 0.0)
      U1 = (1.0, 0.0)
      S = U1
      L = M
      DO 30 I = 2, M
         U3 = U2
         U2 = U1
         C = A/L + (L - 1.0)
         AL = CMPLX(C, - E/L)
         BL = 2.0*(L + Z)
         U1 = (BL*U2 - (L + 1.0)*U3)/AL
         S = S + U1
         C = ABS(REAL(U1)) + ABS(AIMAG(U1))
         IF (I .EQ. M .OR. C .LT. 1.E+8) GO TO 30
C
C           RESCALE TO AVOID OVERFLOW
C
            U2 = U2/C
            U1 = U1/C
            S = S/C
C
   30    L = L - 1.0
C
C     LAST STEP IN THE MILLER ALGORITHM.
C
      IF (C .LT. 2.0) GO TO 40
         U2 = U2/C
         U1 = U1/C
         S = S/C
   40 U3 = U2
      U2 = U1
      AL = CMPLX(0.5*A, - 0.5*E)
      BL = 1.0 + Z
      U1 = (BL*U2 - U3)/AL
      S = S + U1
C
C     FINAL ASSEMBLY
C
      W = C1*(U1/S)
      W0 = 1.0 + 0.5*(NU + 0.5 - U2/U1)*ZR
      RETURN
      END
      SUBROUTINE CBSSLK (Z, R, W)
C-----------------------------------------------------------------------
C
C         CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE
C         SECOND KIND FOR REAL ORDER R AND COMPLEX ARGUMENT Z.
C         IT IS ASSUMED THAT -PI .LT. ARG Z .LE. PI.
C
C-----------------------------------------------------------------------
C     WRITTEN BY
C         ANDREW H. VAN TUYL
C         NAVAL SURFACE WARFARE CENTER
C     MODIFIED BY A.H. MORRIS (NSWC)
C     REVISED ... OCT 1992
C---------------------------
      COMPLEX Z, W, CN, CZ, EX, U1, U2, U3, W1, W2, ZR
      REAL NU, NU1
      COMPLEX CXP
C---------------------------
C     CPI = SQRT(PI/2)
C---------------------------
      DATA PI  /3.14159265358979/
      DATA CPI /1.25331413731550/
C
      RZ = CPABS(REAL(Z), AIMAG(Z))
C
C     ASYMPTOTIC EXPANSION
C
      IF (RZ .LT. 17.5 + 0.5*R*R) GO TO 5
         CALL CKA (Z, R, W)
         RETURN
C
C          REDUCTION OF R TO THE RANGE -0.5 .LT. NU .LE. 0.5
C
    5 A = ABS(R)
      N = A
      NU = A - FLOAT(N)
      T = NU - 0.5
      IF (T .LE. 0.0) GO TO 10
         NU = T - 0.5
         N = N + 1
   10 M = N
      NU1 = NU
C
      IND = 1
      CZ = Z
      X = 0.5*REAL(Z)
      Y = 0.5*AIMAG(Z)
      CALL CREC (X, Y, ZR1, ZR2)
      ZR = CMPLX (ZR1, ZR2)
      IF (T .NE. 0.0) GO TO 20
C
C               CALCULATION FOR NU = 0.5
C
      W = CMPLX(CPI, 0.0)
      IF (N .EQ. 0) GO TO 90
      IF (X .GE. 0.0) GO TO 15
         IND = -1
         CZ = - Z
         ZR = - ZR
   15 U1 = W
      U2 = W
      N = N + 1
      NU = - 0.5
      GO TO 70
C
C           CALCULATION FOR ABS(NU) .LT. 0.5
C
   20 ZNORM = 0.5*RZ
      IF (ZNORM .GT. 1.0) GO TO 30
         IND = 0
         CALL CKM (Z, ZNORM, ZR, NU, U1, U2)
         GO TO 50
   30 IF (X .LT. 0.0) GO TO 40
         CALL CKML (Z, ZNORM, ZR, NU, U1, U2)
         GO TO 50
   40 IND = -1
      CZ = - Z
      ZR = - ZR
      CALL CKML (CZ, ZNORM, ZR, NU, U1, U2)
C
   50 IF (N .GT. 1) GO TO 70
      W = U1
      IF (N .NE. 0) W = U2
      GO TO 90
C
C                 RECURSION
C
   70 N1 = N - 1
      DO 80 I = 1, N1
         AI = I
         U3 = (NU + AI)*ZR*U2 + U1
         U1 = U2
         U2 = U3
   80 CONTINUE
      W = U3
C
   90 IF (IND .EQ. 0) RETURN
      W = W*CEXP(-CZ)/CSQRT(CZ)
      IF (IND .GT. 0) RETURN
C
C            ANALYTIC CONTINUATION
C
      EX = CXP(M, NU1)
      CN = CMPLX (A, 0.0)
      IF (Y .LT. 0.0) GO TO 100
         W1 = CMPLX (AIMAG(Z), -REAL(Z))
         CALL CBSSLJ (W1, CN, W2)
         W2 = CMPLX (PI*AIMAG(W2), -PI*REAL(W2))
         W = EX*(EX*W + W2)
         RETURN
  100 EX = CONJG(EX)
      W1 = CMPLX (-AIMAG(Z), REAL(Z))
      CALL CBSSLJ (W1, CN, W2)
      W2 = CMPLX (-PI*AIMAG(W2), PI*REAL(W2))
      W = EX*(EX*W + W2)
      RETURN
      END
      SUBROUTINE CKA (Z, NU, W)
C-----------------------------------------------------------------------
C        COMPUTATION OF THE BESSEL FUNCTION K FOR REAL ORDER NU
C        AND COMPLEX ARGUMENT Z BY THE ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      COMPLEX Z, W
      REAL M, NU
      COMPLEX P, T, ZR
C--------------------------
      ANORM(Z) = AMAX1(ABS(REAL(Z)), ABS(AIMAG(Z)))
C--------------------------
C     C = PI**(1/2)
C--------------------------
      DATA C /1.77245385090552/
C--------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 .
C
                      EPS = SPMPAR(1)
C
C--------------------------
      CALL CREC (REAL(Z), AIMAG(Z), U, V)
      ZR = CMPLX(0.5*U, 0.5*V)
      A = NU*NU - 0.25
      M = 1.0
      T = A*ZR
      P = T
C
      DO 10 I = 1, 16
         A = A - 2.0*M
         M = M + 1.0
         T = (A/M)*T*ZR
         P = P + T
         IF (ANORM(T) .LE. EPS*ANORM(P)) GO TO 20
   10 CONTINUE
C
   20 P = P + 1.0
      T = CSQRT(ZR)
      IF (AIMAG(Z) .EQ. 0.0) T = CONJG(T)
      W = C*T*P*CEXP(-Z)
      RETURN
      END
      SUBROUTINE CKM (Z, R, ZR, NU, W1, W2)
C-----------------------------------------------------------------------
C
C        CALCULATION OF THE MODIFIED BESSEL FUNCTIONS
C
C                  W1 = K  (Z)  AND  W2 = K    (Z)
C                        NU                NU+1
C
C     FOR A COMPLEX ARGUMENT Z WHERE ABS(Z) .LE. 2  AND A REAL
C     ORDER NU WHERE ABS(NU) .LE. 0.5.  IT IS ASSUMED THAT
C     -PI .LT. ARG Z .LE. PI, R = ABS(Z/2), AND ZR = 2/Z. POWER
C     SERIES EXPANSIONS ARE USED.
C
C-----------------------------------------------------------------------
      COMPLEX Z, ZR, W1, W2
      REAL NU, D(7)
      COMPLEX C, CH, CL, F, MU, P, Q, SH, T1, T2, W
C-----------------------
      DATA TOL /1.E-10/
      DATA PI /3.14159265358979/
C-----------------------
      DATA D(1) / .577215664901533E+00/,  D(2) /-.420026350340952E-01/,
     *     D(3) /-.421977345555443E-01/,  D(4) / .721894324666310E-02/,
     *     D(5) /-.215241674114951E-03/,  D(6) /-.201348547807882E-04/,
     *     D(7) / .113302723198170E-05/
C-----------------------
      ANORM(W) = AMAX1(ABS(REAL(W)), ABS(AIMAG(W)))
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      EPS0 = AMAX1(EPS, 5.E-15)
C
C                     CL = - LN(Z/2)
C
      PHI = ATAN2(AIMAG(Z),REAL(Z))
      CL = CMPLX(-ALOG(R), -PHI)
      MU = NU*CL
      C = CEXP(MU)
C
C                   G1 = GAMMA(1 + NU)
C                   G2 = GAMMA(1 - NU)
C
      T = PI*NU
      IF (ABS(NU) .GT. TOL) GO TO 10
         A = 1.0 + (T*T)/6.0
         GO TO 20
   10 A = T/SIN(T)
C
   20 T = 0.5 + (0.5 + GAM1(NU))
      G1 = 1.0/T
      G2 = A*T
      GM2 = 0.5*(G1 + G2)
      IF (ABS(NU) .GT. 0.2) GO TO 30
C
C         THE FOLLOWING IS THE TAYLOR SERIES FOR
C     T = (1/G2 - 1/G1)/(2*NU). NOTE THAT G1*G2 = A.
C
         T = NU*NU
         T = -((((((D(7)*T + D(6))*T + D(5))*T + D(4))*T +
     *                       D(3))*T + D(2))*T + D(1))
         GM1 = A*T
         GO TO 40
   30 GM1 = 0.5*(G1 - G2)/NU
C
C            INITIALIZATION OF THE SUMMATION
C
   40 P = (0.5*G1)*C
      Q = (0.5*G2)/C
      X = REAL(MU)
      Y = AIMAG(MU)
      IF (ANORM(MU) .GT. TOL) GO TO 50
         T = X*Y
         SH = CMPLX(1.0, T/3.0)
         CH = CMPLX(1.0, T)
         GO TO 60
   50 W = CMPLX (-Y, X)
      SH = CSIN(W)/W
      CH = CCOS(W)
C
   60 F = GM1*CH + GM2*CL*SH
      C = (1.0, 0.0)
      W1 = F
      W2 = P
C
C                 SUMMATION OF SERIES
C
      W = 0.25*(Z*Z)
      DO 70 K = 1, 50
         AK = K
         F = (AK*F + P + Q)/((AK - NU)*(AK + NU))
         P = P/(AK - NU)
         Q = Q/(AK + NU)
         C = C*W/AK
         T1 = C*F
         W1 = W1 + T1
         T2 = C*(P - AK*F)
         W2 = W2 + T2
         IF (ANORM(T1) .LE. EPS0*ANORM(W1)) GO TO 80
   70 CONTINUE
C
   80 W2 = W2 * ZR
      RETURN
      END
      SUBROUTINE CKML (Z, R, ZR, NU, K1, K2)
C-----------------------------------------------------------------------
C
C             COMPUTATION OF THE SCALED BESSEL FUNCTIONS
C
C                   K1 = (EXP(Z)*SQRT(Z)) K  (Z)
C                                          NU
C                   K2 = (EXP(Z)*SQRT(Z)) K    (Z)
C                                          NU+1
C
C     FOR REAL ORDERS NU AND NU + 1 AND FOR COMPLEX ARGUMENT Z
C     BY USE OF THE MILLER ALGORITHM. FOR THE GREATEST ACCURACY,
C     Z SHOULD LIE IN A SECTOR SLIGHTLY LARGER THAN THE RIGHT
C     HALF PLANE. IT IS ASSUMED THAT ABS(NU) .LT. 0.5, AND THAT
C     R = ABS(Z/2) AND ZR = 2/Z.
C
C-----------------------------------------------------------------------
      COMPLEX Z, ZR, K1, K2
      COMPLEX BL, S, U1, U2, U3
      REAL L, NU, NU2
C---------------------
C     C1 = SQRT(PI/2)
C---------------------
      DATA C1/1.25331413731559/
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      EPS0 = AMAX1(EPS, 5.E-15)
      X = REAL(Z)
      Y = AIMAG(Z)
      NU2 = NU*NU
C
C     CALCULATION OF M FOR USE IN MILLER ALGORITHM.
C
      TH = ATAN2(Y,X)
      A = 3.0/(1.0 + R)
      B = 14.7/(28.0 + R)
      C = 4.0*COS1(NU)/(C1*EPS0*(2.0*R)**(0.25))
      M = (0.485/R)*(ALOG(C) + R*COS(A*TH)/(1.0 + 0.008*R))**2/
     *    (2.0*COS(B*TH))**2 + 1.5
C
C     BACKWARD RECURRENCE IN MILLER ALGORITHM.
C
      U2 = (0.0, 0.0)
      U1 = (1.0, 0.0)
      S = U1
      L = M
      DO 10 I = 2, M
         U3 = U2
         U2 = U1
         E = L - 0.5
         AL = (E*E - NU2)/(L*(L + 1.0))
         BL = (2.0/(L + 1.0))*(L + Z)
         U1 = (BL*U2 - U3)/AL
         S = S + U1
         C = ABS(REAL(U1)) + ABS(AIMAG(U1))
         IF (I .EQ. M .OR. C .LT. 1.E+6) GO TO 10
C
C           RESCALE TO AVOID OVERFLOW
C
            U2 = U2/C
            U1 = U1/C
            S = S/C
C
   10    L = L - 1.0
C
C     LAST STEP IN THE MILLER ALGORITHM.
C
      IF (C .LT. 2.0) GO TO 20
         U2 = U2/C
         U1 = U1/C
         S = S/C
   20 U3 = U2
      U2 = U1
      AL = 0.5*(0.5 - NU)*(0.5 + NU)
      BL = 1.0 + Z
      U1 = (BL*U2 - U3)/AL
      S = S + U1
C
C     FINAL ASSEMBLY
C
      K1 = C1*(U1/S)
      K2 = K1*(1.0 + 0.5*(NU + 0.5 - U2/U1)*ZR)
      RETURN
      END
      COMPLEX FUNCTION CXP (N, NU)
C-----------------------------------------------------------------------
C                 COMPUTATION OF EXP(-R*(PI/2)*I)
C              WHERE R = N + NU FOR ABS(NU) .LE. 0.5
C-----------------------------------------------------------------------
      REAL NU
C
      C = COS0(NU)
      S = SIN0(NU)
      K = MOD(N,4)
      IF (K .EQ. 0) GO TO 10
      IF (K .EQ. 1) GO TO 20
      IF (K .EQ. 2) GO TO 30
      GO TO 40
C
   10 CXP = CMPLX (C, -S)
      RETURN
C
   20 CXP = CMPLX (-S, -C)
      RETURN
C
   30 CXP = CMPLX (-C, S)
      RETURN
C
   40 CXP = CMPLX (S, C)
      RETURN
      END
      SUBROUTINE BSSLK (MO, A, IN, W)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR MODIFIED BESSEL FUNCTION OF INTEGRAL ORDER
C     ******************************************************************
C     MO = MODE OF OPERATION
C     A  = ARGUMENT (COMPLEX NUMBER)
C     IN = ORDER (INTEGER)
C     W  = FUNCTION OF SECOND KIND (COMPLEX NUMBER)
C     -------------------
      COMPLEX A, W
      DIMENSION AZ(2)
      DIMENSION CD(30), CE(30)
      DIMENSION SZ(2), RZ(2), ZL(2)
      DIMENSION TS(2), TM(2), SM(2), SL(2), SQ(2), SR(2), AQ(2), QF(2)
      DATA CD(1) / 0.00000000000000E00/,  CD(2) /-1.64899505142212E-2/,
     1     CD(3) /-7.18621880068536E-2/,  CD(4) /-1.67086878124866E-1/,
     2     CD(5) /-3.02582250219469E-1/,  CD(6) /-4.80613945245927E-1/,
     3     CD(7) /-7.07075239357898E-1/,  CD(8) /-9.92995790539516E-1/,
     4     CD(9) /-1.35583925612592E00/,  CD(10)/-1.82105907899132E00/,
     5     CD(11)/-2.42482175310879E00/,  CD(12)/-3.21956655708750E00/,
     6     CD(13)/-4.28658077248384E00/,  CD(14)/-5.77022816798128E00/,
     7     CD(15)/-8.01371260952526E00/
      DATA CD(16)/ 0.00000000000000E00/,  CD(17)/-5.57742429879505E-3/,
     1     CD(18)/-4.99112944172476E-2/,  CD(19)/-1.37440911652397E-1/,
     2     CD(20)/-2.67233784710566E-1/,  CD(21)/-4.40380166808682E-1/,
     3     CD(22)/-6.61813614872541E-1/,  CD(23)/-9.41861077665017E-1/,
     4     CD(24)/-1.29754130468326E00/,  CD(25)/-1.75407696719816E00/,
     5     CD(26)/-2.34755299882276E00/,  CD(27)/-3.13041332689196E00/,
     6     CD(28)/-4.18397120563729E00/,  CD(29)/-5.65251799214994E00/,
     7     CD(30)/-7.87863959810677E00/
      DATA CE(1) / 0.00000000000000E00/,  CE(2) /-4.80942336387447E-3/,
     1     CE(3) /-1.31366200347759E-2/,  CE(4) /-1.94843834008458E-2/,
     2     CE(5) /-2.19948900032003E-2/,  CE(6) /-2.09396625676519E-2/,
     3     CE(7) /-1.74600268458650E-2/,  CE(8) /-1.27937813362085E-2/,
     4     CE(9) /-8.05234421796592E-3/,  CE(10)/-4.15817375002760E-3/,
     5     CE(11)/-1.64317738747922E-3/,  CE(12)/-4.49175585314709E-4/,
     6     CE(13)/-7.28594765574007E-5/,  CE(14)/-5.38265230658285E-6/,
     7     CE(15)/-9.93779048036289E-8/
      DATA CE(16)/ 0.00000000000000E00/,  CE(17)/ 7.53805779200591E-2/,
     1     CE(18)/ 7.12293537403464E-2/,  CE(19)/ 6.33116224228200E-2/,
     2     CE(20)/ 5.28240264523301E-2/,  CE(21)/ 4.13305359441492E-2/,
     3     CE(22)/ 3.01350573947510E-2/,  CE(23)/ 2.01043439592720E-2/,
     4     CE(24)/ 1.18552223068074E-2/,  CE(25)/ 5.86055510956010E-3/,
     5     CE(26)/ 2.25465148267325E-3/,  CE(27)/ 6.08173041536336E-4/,
     6     CE(28)/ 9.84215550625747E-5/,  CE(29)/ 7.32139093038089E-6/,
     7     CE(30)/ 1.37279667384666E-7/
C     -------------------
      AZ(1)=REAL(A)
      AZ(2)=AIMAG(A)
      ZS=AZ(1)*AZ(1)+AZ(2)*AZ(2)
      ZL(1)=0.5*ALOG(ZS)
      ZL(2)=ATAN2(AZ(2),AZ(1))
      AN=IABS(IN)
      TM(1)=0.0
      TM(2)=0.0
      IF(MO.NE.0)GO TO 002
      TM(1)=AZ(1)
      TM(2)=AZ(2)
  002 IF(ZS-1.0)020,020,003
  003 IF(ZS-289.0)004,010,010
  004 IF(AZ(1)+0.096*AZ(2)*AZ(2))020,020,015
  010 QM=1.25331413731550*EXP(-0.5*ZL(1)-TM(1))
      QF(1)=QM*COS(-0.5*ZL(2)-TM(2))
      QF(2)=QM*SIN(-0.5*ZL(2)-TM(2))
      IF(AN.GT.1.0)GO TO 012
      PN=AN
      ASSIGN 011 TO LA
      GO TO 100
  011 TS(1)=QF(1)*SM(1)-QF(2)*SM(2)
      TS(2)=QF(1)*SM(2)+QF(2)*SM(1)
      SM(1)=TS(1)
      SM(2)=TS(2)
      GO TO 029
  012 PN=1.0
      ASSIGN 013 TO LA
      GO TO 100
  013 SQ(1)=QF(1)*SM(1)-QF(2)*SM(2)
      SQ(2)=QF(1)*SM(2)+QF(2)*SM(1)
      PN=0.0
      ASSIGN 014 TO LA
      GO TO 100
  014 SR(1)=QF(1)*SM(1)-QF(2)*SM(2)
      SR(2)=QF(1)*SM(2)+QF(2)*SM(1)
      GO TO 026
  015 QM=1.25331413731550*EXP(-0.5*ZL(1)-TM(1))
      QF(1)=QM*COS(-0.5*ZL(2)-TM(2))
      QF(2)=QM*SIN(-0.5*ZL(2)-TM(2))
      IF(AN.GT.1.0)GO TO 017
      PN=AN
      ASSIGN 016 TO LR
      GO TO 104
  016 TS(1)=QF(1)*SM(1)-QF(2)*SM(2)
      TS(2)=QF(1)*SM(2)+QF(2)*SM(1)
      SM(1)=TS(1)
      SM(2)=TS(2)
      GO TO 029
  017 PN=1.0
      ASSIGN 018 TO LR
      GO TO 104
  018 SQ(1)=QF(1)*SM(1)-QF(2)*SM(2)
      SQ(2)=QF(1)*SM(2)+QF(2)*SM(1)
      PN=0.0
      ASSIGN 019 TO LR
      GO TO 104
  019 SR(1)=QF(1)*SM(1)-QF(2)*SM(2)
      SR(2)=QF(1)*SM(2)+QF(2)*SM(1)
      GO TO 026
  020 QF(1)=1.0
      QF(2)=0.0
      IF(MO.EQ.0)GO TO 021
      QM=EXP(AZ(1))
      QF(1)=QM*COS(AZ(2))
      QF(2)=QM*SIN(AZ(2))
  021 IF(AN.GT.1.0)GO TO 023
      PN=AN
      ASSIGN 022 TO LK
      GO TO 106
  022 TS(1)=QF(1)*SM(1)-QF(2)*SM(2)
      TS(2)=QF(1)*SM(2)+QF(2)*SM(1)
      SM(1)=TS(1)
      SM(2)=TS(2)
      GO TO 029
  023 PN=1.0
      ASSIGN 024 TO LK
      GO TO 106
  024 SQ(1)=QF(1)*SM(1)-QF(2)*SM(2)
      SQ(2)=QF(1)*SM(2)+QF(2)*SM(1)
      PN=0.0
      ASSIGN 025 TO LK
      GO TO 106
  025 SR(1)=QF(1)*SM(1)-QF(2)*SM(2)
      SR(2)=QF(1)*SM(2)+QF(2)*SM(1)
  026 RZ(1)=+AZ(1)/ZS
      RZ(2)=-AZ(2)/ZS
      PN=0.0
      GO TO 028
  027 SQ(1)=SR(1)
      SQ(2)=SR(2)
      SR(1)=SM(1)
      SR(2)=SM(2)
  028 SM(1)=2.0*PN*(RZ(1)*SR(1)-RZ(2)*SR(2))+SQ(1)
      SM(2)=2.0*PN*(RZ(1)*SR(2)+RZ(2)*SR(1))+SQ(2)
      PN=PN+1.0
      IF(PN.LT.AN)GO TO 027
  029 W=CMPLX(SM(1),SM(2))
      RETURN
  100 SM(1)=0.0
      SM(2)=0.0
      RZ(1)=+0.5*AZ(1)/ZS
      RZ(2)=-0.5*AZ(2)/ZS
      QN=(PN-0.5)*(PN+0.5)
      TM(1)=1.0
      TM(2)=0.0
      PM=0.0
      GO TO 102
  101 QN=QN-2.0*PM
      PM=PM+1.0
      TS(1)=RZ(1)*TM(1)-RZ(2)*TM(2)
      TS(2)=RZ(1)*TM(2)+RZ(2)*TM(1)
      TM(1)=QN*TS(1)/PM
      TM(2)=QN*TS(2)/PM
      IF(ABS(SM(1))+ABS(TM(1)).NE.ABS(SM(1)))GO TO 102
      IF(ABS(SM(2))+ABS(TM(2)).EQ.ABS(SM(2)))GO TO 103
  102 SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      IF(PM.LT.36.0)GO TO 101
  103 GO TO LA,(011,013,014)
  104 SM(1)=1.0
      SM(2)=0.0
      M=15.0*PN+2.0
      N=15.0*PN+15.0
      DO 105 I=M,N
      TS(1)=AZ(1)-CD(I)
      TS(2)=AZ(2)
      SS=TS(1)*TS(1)+TS(2)*TS(2)
      TM(1)=+CE(I)*TS(1)/SS
      TM(2)=-CE(I)*TS(2)/SS
      SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
  105 CONTINUE
      GO TO LR,(016,018,019)
  106 AQ(1)=1.0
      AQ(2)=0.0
      RN=0.0
      SN=-1.0
      PM=0.0
      GO TO 108
  107 PM=PM+1.0
      RN=RN+0.5/PM
      SN=-SN
      TS(1)=0.5*(AZ(1)*AQ(1)-AZ(2)*AQ(2))
      TS(2)=0.5*(AZ(1)*AQ(2)+AZ(2)*AQ(1))
      AQ(1)=TS(1)/PM
      AQ(2)=TS(2)/PM
  108 IF(PM.LT.PN)GO TO 107
      SZ(1)=0.25*(AZ(1)-AZ(2))*(AZ(1)+AZ(2))
      SZ(2)=0.5*AZ(1)*AZ(2)
      SR(1)=0.0
      SR(2)=0.0
      SS=AQ(1)*AQ(1)+AQ(2)*AQ(2)
      TM(1)=+AQ(1)/SS
      TM(2)=-AQ(2)/SS
      PM=0.0
      GO TO 110
  109 TM(1)=TM(1)/(PN-PM)
      TM(2)=TM(2)/(PN-PM)
      SR(1)=SR(1)+0.5*TM(1)
      SR(2)=SR(2)+0.5*TM(2)
      PM=PM+1.0
      TS(1)=SZ(1)*TM(1)-SZ(2)*TM(2)
      TS(2)=SZ(1)*TM(2)+SZ(2)*TM(1)
      TM(1)=-TS(1)/PM
      TM(2)=-TS(2)/PM
  110 IF(PM.LT.PN)GO TO 109
      SM(1)=0.0
      SM(2)=0.0
      RM=1.0
      QM=0.0
      AQ(1)=SN*AQ(1)
      AQ(2)=SN*AQ(2)
      SL(1)=-0.115931515658412+ZL(1)-RN
      SL(2)=+ZL(2)
      PM=0.0
      GO TO 112
  111 QM=QM+RM
      PM=PM+1.0
      RM=0.25*ZS*RM/(PM*(PN+PM))
      TS(1)=SZ(1)*AQ(1)-SZ(2)*AQ(2)
      TS(2)=SZ(1)*AQ(2)+SZ(2)*AQ(1)
      AQ(1)=TS(1)/(PM*(PN+PM))
      AQ(2)=TS(2)/(PM*(PN+PM))
      SL(1)=SL(1)-0.5/PM-0.5/(PN+PM)
  112 TM(1)=AQ(1)*SL(1)-AQ(2)*SL(2)
      TM(2)=AQ(1)*SL(2)+AQ(2)*SL(1)
      SM(1)=SM(1)+TM(1)
      SM(2)=SM(2)+TM(2)
      IF(QM+RM.GT.QM)GO TO 111
      SM(1)=SR(1)+SM(1)
      SM(2)=SR(2)+SM(2)
      GO TO LK,(022,024,025)
      END
      SUBROUTINE CAI(IND,Z,AI,AIP,IERR)
C------------------------------------------------------------
C     CALCULATES THE AIRY FUNCTION AI AND ITS DERIVATIVE AIP
C     FOR COMPLEX ARGUMENT Z.
C------------------------------------------------------------
      COMPLEX Z,AI,BI,AIP,BIP
      IERR = 0
      A = REAL(Z)
      B = AIMAG(Z)
      R = CPABS(A,B)
      IF(R .GT. 1.0) GO TO 10
C
C     MACLAURIN EXPANSION
C
         CALL AIRM(IND,Z,AI,AIP,BI,BIP)
         RETURN
   10 IF(R .GT. 10.0) GO TO 20
C
C     INTERMEDIATE RANGE CALCULATION
C
         CALL AII(IND,Z,AI,AIP,IERR)
         RETURN
C
C     ASYMPTOTIC EXPANSION
C
   20 CALL AIA(IND,Z,AI,AIP,IERR)
      RETURN
      END
      SUBROUTINE AIRM (IND,Z,AI,AIP,BI,BIP)
C--------------------------------------------------------------
C     CALCULATES THE AIRY FUNCTIONS AI AND BI AND THEIR
C     DERIVATIVES AIP AND BIP BY USE OF THEIR MACLAURIN
C     EXPANSIONS.
C--------------------------------------------------------------
      COMPLEX AI, AIP, BI, BIP, Z, Z1, Z2, Z3, ZZ, F, F1, G, G1,
     *        E, E1
      REAL A(8), B(8), C(8), D(8)
C-----------------------
C     C1 = 3**(-2/3)/GAMMA(2/3)
C     C2 = 3**(-1/3)/GAMMA(1/3)
C-----------------------
      DATA C1/3.55028053887817E-01/, C2/2.58819403792807E-01/,
     1     SQT3/1.73205080756888E+00/
C-----------------------
      DATA A(1) /.166666666666667E+00/, A(2) /.555555555555556E-02/,
     *     A(3) /.771604938271605E-04/, A(4) /.584549195660307E-06/,
     *     A(5) /.278356759838241E-08/, A(6) /.909662613850462E-11/,
     *     A(7) /.216586336631062E-13/, A(8) /.392366551867867E-16/
      DATA B(1) /.833333333333333E-01/, B(2) /.198412698412698E-02/,
     *     B(3) /.220458553791887E-04/, B(4) /.141319585764030E-06/,
     *     B(5) /.588831607350126E-09/, B(6) /.172172984605300E-11/,
     *     B(7) /.372668797846970E-14/, B(8) /.621114663078283E-17/
      DATA C(1) /.333333333333333E-01/, C(2) /.694444444444444E-03/,
     *     C(3) /.701459034792368E-05/, C(4) /.417535139757362E-07/,
     *     C(5) /.163739270493083E-09/, C(6) /.454831306925231E-12/,
     *     C(7) /.941679724482880E-15/, C(8) /.150910212256872E-17/
      DATA D(1) /.333333333333333E+00/, D(2) /.138888888888889E-01/,
     *     D(3) /.220458553791887E-03/, D(4) /.183715461493239E-05/,
     *     D(5) /.942130571760201E-08/, D(6) /.327128670750070E-10/,
     *     D(7) /.819871355263333E-13/, D(8) /.155278665769571E-15/
C-----------------------
      Z2 = Z*Z
      Z3 = Z*Z2
C
C     SUMMATION OF F AND G
C
      F = CMPLX(A(8),0.0)
      G = CMPLX(B(8),0.0)
      DO 10 N = 1, 7
         I = 8 - N
         F = A(I) + Z3*F
         G = B(I) + Z3*G
   10 CONTINUE
      F = 1.0 + Z3*F
      G = Z + Z2*Z2*G
C
C     SUMMATION OF F1 AND G1
C
      F1 = CMPLX(C(8),0.0)
      G1 = CMPLX(D(8),0.0)
      DO 20 N = 1,7
         I = 8 - N
         F1 = C(I) + Z3*F1
         G1 = D(I) + Z3*G1
   20 CONTINUE
      F1 = Z2*(0.5 + Z3*F1)
      G1 = 1.0 + Z3*G1
C
C     FINAL ASSEMBLY
C
      AI = C1*F - C2*G
      BI = SQT3*(C1*F + C2*G)
      AIP = C1*F1 - C2*G1
      BIP = SQT3*(C1*F1 + C2*G1)
      IF (IND .EQ. 0) RETURN
         X = REAL(Z)
         Y = AIMAG(Z)
         Z1 = CSQRT(Z)
         ZZ = Z*Z1/1.5
         E = CEXP(ZZ)
         E1 = 1.0/E
         AI = AI*E
         AIP = AIP*E
         IF (ABS(Y) .GT. X*SQT3) GO TO 30
            BI = BI*E1
            BIP = BIP*E1
            RETURN
   30    BI = BI*E
         BIP = BIP*E
      RETURN
      END
      SUBROUTINE AII(IND, Z, AI, AIP, IERR)
C------------------------------------------------------------
C     CALCULATES THE AIRY FUNCTION AI AND ITS DERIVATIVE AIP
C     FOR COMPLEX ARGUMENT Z IN THE INTERMEDIATE RANGE 1 .LE.
C     CABS(Z) .LE. 10.0.
C------------------------------------------------------------
      COMPLEX Z, AI, AIP, Z1, Z2, Z3, ZM, W1, W2, W1M, W2M, E
C
C     C1 = 1/(PI*SQRT(3))
C
      DATA C1/1.83776298473931E-01/
      IERR = 0
      A = REAL(Z)
      B = AIMAG(Z)
      R = CPABS(A, B)
      Z1 = CSQRT(Z)
      Z2 = Z1*Z/1.5
      IF (ABS(B) .LT. -5.0*A) GO TO 10
C
C           ----  ABS(B) .GE. -5.0*A  ----
C
         CALL KA(IND, Z2, W1, W2)
         AI = C1*Z1*W1
         AIP = -C1*Z*W2
         RETURN
C
C           ----  ABS(B) .LT. -5.0*A  ----
C
   10 IF (ABS(B) .LT. -1.74*A) GO TO 30
         IF (R .GE. 8.2) GO TO 40
   20    ZM = -Z
         Z1 = CSQRT(ZM)
         Z3 = Z1*ZM/1.5
         CALL JA(Z3, W1, W2, W1M, W2M)
         AI = (Z1/3.0)*(W1M +W1)
         AIP = (Z/3.0)*(W2M - W2)
         IF (IND .EQ. 0) RETURN
            E = CEXP(Z2)
            AI = AI*E
            AIP = AIP*E
            RETURN
   30 IF (R .LT. 7.4) GO TO 20
   40 CALL AIA (IND,Z,AI,AIP,IERR)
      RETURN
      END
      SUBROUTINE AIA (IND, Z, AI, AIP, IERR)
C-----------------------------------------------------------------------
C     CALCULATES THE AIRY FUNCTION AI AND ITS DERIVATIVE AIP FOR
C     COMPLEX ARGUMENT Z BY MEANS OF ASYMPTOTIC EXPANSIONS.
C-----------------------------------------------------------------------
      COMPLEX AI,AIP,Z,Z1,Z2,Z2R,ZZ,W,W2,S1,S2,S3,S4,E,ZETA,SI,CN
      COMPLEX ALPHA,BETA,J
      REAL C(30), D(30)
C------------------------
      DATA C(1)  /.100000000000000E+01/, C(2)  /.694444444444444E-01/,
     *     C(3)  /.371334876543210E-01/, C(4)  /.379930591278006E-01/,
     *     C(5)  /.576491904126697E-01/, C(6)  /.116099064025515E+00/,
     *     C(7)  /.291591399230751E+00/, C(8)  /.877666969510017E+00/,
     *     C(9)  /.307945303017317E+01/, C(10) /.123415733323452E+02/,
     *     C(11) /.556227853659171E+02/, C(12) /.278465080777603E+03/,
     *     C(13) /.153316943201280E+04/, C(14) /.920720659972641E+04/,
     *     C(15) /.598925135658791E+05/, C(16) /.419524875116551E+06/,
     *     C(17) /.314825741786683E+07/, C(18) /.251989198716024E+08/,
     *     C(19) /.214288036963680E+09/, C(20) /.192937554918249E+10/
      DATA C(21) /.183357669378906E+11/, C(22) /.183418303528833E+12/,
     *     C(23) /.192647115897045E+13/, C(24) /.211969993886476E+14/,
     *     C(25) /.243826826879716E+15/, C(26) /.292659921929793E+16/,
     *     C(27) /.365903070126431E+17/, C(28) /.475768102036307E+18/,
     *     C(29) /.642404935790194E+19/, C(30) /.899520742705838E+20/
C------------------------
      DATA D(1)  / .100000000000000E+01/, D(2)  /-.972222222222222E-01/,
     *     D(3)  /-.438850308641975E-01/, D(4)  /-.424628307898948E-01/,
     *     D(5)  /-.626621634920323E-01/, D(6)  /-.124105896027275E+00/,
     *     D(7)  /-.308253764901079E+00/, D(8)  /-.920479992412945E+00/,
     *     D(9)  /-.321049358464862E+01/, D(10) /-.128072930807356E+02/,
     *     D(11) /-.575083035139143E+02/, D(12) /-.287033237109221E+03/,
     *     D(13) /-.157635730333710E+04/, D(14) /-.944635482309593E+04/,
     *     D(15) /-.613357066638521E+05/, D(16) /-.428952400400069E+06/,
     *     D(17) /-.321453652140086E+07/, D(18) /-.256979083839113E+08/,
     *     D(19) /-.218293420832160E+09/, D(20) /-.196352378899103E+10/
      DATA D(21) /-.186439310881072E+11/, D(22) /-.186352996385294E+12/,
     *     D(23) /-.195588293238984E+13/, D(24) /-.215064446351972E+14/,
     *     D(25) /-.247236992290621E+15/, D(26) /-.296588243029521E+16/,
     *     D(27) /-.370624400063547E+17/, D(28) /-.481678264794522E+18/,
     *     D(29) /-.650098408075106E+19/, D(30) /-.909919826436541E+20/
C------------------------
C     C1 = PI**(-1/2)
C     C2 = (2*PI)**(-1/2)
C------------------------
      DATA C1 /.564189583547756/
      DATA C2 /.398942280401433/
C------------------------
C
C     EPS, XPOS, AND XNEG ARE MACHINE DEPENDENT CONSTANTS. EPS IS
C     THE SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0, XPOS IS THE
C     THE LARGEST POSTIVE NUMBER FOR WHICH EXP(X) CAN BE COMPUTED,
C     AND XNEG IS THE LARGEST NEGATIVE NUMBER FOR WHICH EXP(X) DOES
C     NOT UNDERFLOW.
C
                      EPS = SPMPAR(1)
                      XPOS = EXPARG(0)
                      XNEG = EXPARG(1)
C
C------------------------
      IERR = 0
      IF (REAL(Z) .LT. 0.0) GO TO 30
C
C             -----   REAL(Z) .GE. 0    -----
C
      Z1 = CSQRT(Z)
      Z2 = CSQRT(Z1)
      Z2R = 1.0/Z2
      CALL CREC (REAL(Z), AIMAG(Z), U, V)
      W = -1.5*CMPLX(U,V)/Z1
      U = ABS(REAL(W))
      V = ABS(AIMAG(W))
      T = AMAX1(U,V)
      IF (IND .NE. 0) GO TO 10
C
         IF (T .EQ. 0.0) GO TO 90
         U1 = U/T
         V1 = V/T
         R = U*U1 + V*V1
         XM = XPOS
         IF (REAL(W) .LT. 0.0) XM = -XNEG
         IF (U1 .GE. R*XM .OR. V1 .GE. 0.1*R/EPS) GO TO 90
         ZETA = Z1*Z/1.5
         E = CEXP(-ZETA)
C
   10 M = 20
      IF (T .GT. 30.0) M = 8
      S1 = CMPLX(C(M),0.0)
      S2 = CMPLX(D(M),0.0)
      I = M
      DO 20 K = 2,M
         I = I - 1
         S1 = C(I) + W*S1
         S2 = D(I) + W*S2
   20 CONTINUE
C
      AI = 0.5*C1*Z2R*S1
      AIP = - 0.5*C1*Z2*S2
      IF (IND .NE. 0) RETURN
      AI = E*AI
      AIP = E*AIP
      RETURN
C
C             -----   REAL(Z) .LT. 0    -----
C
   30 ZZ = -Z
      Z1 = CSQRT(ZZ)
      Z2 = CSQRT(Z1)
      Z2R = 1.0/Z2
      CALL CREC (REAL(ZZ), AIMAG(ZZ), U, V)
      W = 1.5*CMPLX(U,V)/Z1
      U = ABS(REAL(W))
      V = ABS(AIMAG(W))
      T = AMAX1(U,V)
C
         IF (T .EQ. 0.0) GO TO 90
         U1 = U/T
         V1 = V/T
         R = U*U1 + V*V1
         IF (IND .NE. 0) GO TO 40
            IF (V1 .GE. R*XPOS .OR. U1 .GE. 0.1*R/EPS) GO TO 90
            ZETA = Z1*ZZ/1.5
            GO TO 50
   40    E = (0.0, 0.0)
         J = (0.0, -1.0)
         IF (AIMAG(Z) .LT. 0.0) J = (0.0, 1.0)
         IF (V1 .GT. 0.5*R*ABS(XNEG)) GO TO 50
         IF (U1 .GE. 0.05*R/EPS) GO TO 90
         ZETA = Z1*ZZ/1.5
         E = CEXP(2.0*J*ZETA)
C
   50 W2 =  W*W
      M = 15
      IF (T .GT. 30.0) M = 5
      M2 = M + M
      I = M2 - 1
      S1 = CMPLX(C(I),0.0)
      S2 = CMPLX(C(M2),0.0)
      S3 = CMPLX(D(I),0.0)
      S4 = CMPLX(D(M2),0.0)
      DO 60 K = 2,M
         I = I - 1
         S2 = C(I) - S2*W2
         S4 = D(I) - S4*W2
         I = I - 1
         S1 = C(I) - S1*W2
         S3 = D(I) - S3*W2
   60 CONTINUE
      S2 = W*S2
      S4 = W*S4
C
      IF (IND .NE. 0) GO TO 70
         CN = CCOS(ZETA)
         SI = CSIN(ZETA)
         GO TO 80
   70 CN = 0.5*(1.0 + E)
      SI = 0.5*(1.0 - E)*J
C
   80 ALPHA = S1 - S2
      BETA  = S1 + S2
      AI = C2*Z2R*(ALPHA*CN + BETA*SI)
      ALPHA = S3 - S4
      BETA  = S3 + S4
      AIP = C2*Z2*(ALPHA*SI - BETA*CN)
      RETURN
C
C         RETURN WITH ZERO VALUES IF SCALING IS NEEDED
C
   90 AI = (0.0, 0.0)
      AIP = (0.0, 0.0)
      IERR = 1
      RETURN
      END
      SUBROUTINE CBI(IND,Z,BI,BIP,IERR)
C------------------------------------------------------------
C     CALCULATES THE AIRY FUNCTION BI AND ITS DERIVATIVE BIP
C     FOR COMPLEX ARGUMENT Z.
C------------------------------------------------------------
      COMPLEX Z,AI,BI,AIP,BIP
      IERR = 0
      A = REAL(Z)
      B = AIMAG(Z)
      R = CPABS(A,B)
      IF(R .GT. 1.0) GO TO 10
C
C     MACLAURIN EXPANSION
C
         CALL AIRM(IND,Z,AI,AIP,BI,BIP)
         RETURN
   10 IF(R .GT. 9.6) GO TO 20
C
C     INTERMEDIATE RANGE CALCULATION
C
         CALL BII(IND,Z,BI,BIP,IERR)
         RETURN
C
C     ASYMPTOTIC EXPANSION
C
   20 CALL BIA(IND,Z,BI,BIP,IERR)
      RETURN
      END
      SUBROUTINE BII(IND, Z, BI, BIP, IERR)
C------------------------------------------------------------
C     CALCULATES THE AIRY FUNCTION BI AND ITS DERIVATIVE BIP
C     FOR COMPLEX ARGUMENT Z IN THE INTERMEDIATE RANGE 1 .LE.
C     CABS(Z) .LE. 10.0.
C------------------------------------------------------------
      COMPLEX Z, BI, BIP, Z1, Z2, ZM, W1, W2, W1M, W2M, E, E1
C
C     C1 = 1/SQRT(3)
C     SQT3 = SQRT(3)
C
      DATA C1/5.77350269189626E-01/
      DATA SQT3/1.73205080756888E+00/
C
      IERR = 0
      X = REAL(Z)
      Y = AIMAG(Z)
      R = CPABS(X, Y)
      Z1 = CSQRT(Z)
      Z2 = Z1*Z/1.5
      E = CEXP(-Z2)
      E1 = 1.0/E
      IF(REAL(Z) .LT. 0.0) GO TO 10
C
C               ----  REAL(Z) .GE. 0  ----
C
      IF (R .LT. 8.9) GO TO 5
      A = 0.156*R - 0.913
      IF (ABS(Y) .LT. A*X .OR. ABS(Y) .GT. 0.58*X) GO TO 40
    5    CALL IA(Z2, W1, W2, W1M, W2M)
         BI = C1*Z1*(W1 + W1M)
         BIP = C1*Z*(W2 + W2M)
         IF (IND .EQ. 0) RETURN
         GO TO 20
C
C               ----  REAL(Z) .LT. 0  ----
C
   10 IF (R .LT. 8.1) GO TO 15
      IF (ABS(Y) .LT. 3.89*ABS(X)) GO TO 40
   15    ZM = -Z
         Z1 = CSQRT(ZM)
         Z2 = Z1*ZM/1.5
         CALL JA(Z2, W1, W2, W1M, W2M)
         BI = C1*Z1*(W1M -W1)
         BIP = C1*ZM*(W2M + W2)
         IF (IND .EQ. 0) RETURN
   20    IF (X .GE. C1*ABS(Y)) GO TO 30
            BI = BI*E1
            BIP = BIP*E1
            RETURN
   30    BI = BI*E
         BIP = BIP*E
         RETURN
   40 CALL BIA(IND, Z, BI, BIP, IERR)
      RETURN
      END
      SUBROUTINE BIA(IND,Z,BI,BIP,IERR)
C---------------------------------------------------------------
C     CALCULATES THE AIRY FUNCTION BI AND ITS DERIVATIVE BIP FOR
C     COMPLEX ARGUMENT Z BY MEANS OF ASYMPTOTIC EXPANSIONS.
C---------------------------------------------------------------
      COMPLEX Z,BI,BIP,Z1,Z2,Z2R,ZZ,W,W2,S1,S2,S3,S4,E,ZETA,SI,CN,
     *        CF1,CF2,EX3C,EX6,EX6C,CLN2,ALPHA,BETA,J,CZ
      DIMENSION C(30), D(30)
C------------------------
      DATA C(1)  /.100000000000000E+01/, C(2)  /.694444444444444E-01/,
     *     C(3)  /.371334876543210E-01/, C(4)  /.379930591278006E-01/,
     *     C(5)  /.576491904126697E-01/, C(6)  /.116099064025515E+00/,
     *     C(7)  /.291591399230751E+00/, C(8)  /.877666969510017E+00/,
     *     C(9)  /.307945303017317E+01/, C(10) /.123415733323452E+02/,
     *     C(11) /.556227853659171E+02/, C(12) /.278465080777603E+03/,
     *     C(13) /.153316943201280E+04/, C(14) /.920720659972641E+04/,
     *     C(15) /.598925135658791E+05/, C(16) /.419524875116551E+06/,
     *     C(17) /.314825741786683E+07/, C(18) /.251989198716024E+08/,
     *     C(19) /.214288036963680E+09/, C(20) /.192937554918249E+10/
      DATA C(21) /.183357669378906E+11/, C(22) /.183418303528833E+12/,
     *     C(23) /.192647115897045E+13/, C(24) /.211969993886476E+14/,
     *     C(25) /.243826826879716E+15/, C(26) /.292659921929793E+16/,
     *     C(27) /.365903070126431E+17/, C(28) /.475768102036307E+18/,
     *     C(29) /.642404935790194E+19/, C(30) /.899520742705838E+20/
C------------------------
      DATA D(1)  / .100000000000000E+01/, D(2)  /-.972222222222222E-01/,
     *     D(3)  /-.438850308641975E-01/, D(4)  /-.424628307898948E-01/,
     *     D(5)  /-.626621634920323E-01/, D(6)  /-.124105896027275E+00/,
     *     D(7)  /-.308253764901079E+00/, D(8)  /-.920479992412945E+00/,
     *     D(9)  /-.321049358464862E+01/, D(10) /-.128072930807356E+02/,
     *     D(11) /-.575083035139143E+02/, D(12) /-.287033237109221E+03/,
     *     D(13) /-.157635730333710E+04/, D(14) /-.944635482309593E+04/,
     *     D(15) /-.613357066638521E+05/, D(16) /-.428952400400069E+06/,
     *     D(17) /-.321453652140086E+07/, D(18) /-.256979083839113E+08/,
     *     D(19) /-.218293420832160E+09/, D(20) /-.196352378899103E+10/
      DATA D(21) /-.186439310881072E+11/, D(22) /-.186352996385294E+12/,
     *     D(23) /-.195588293238984E+13/, D(24) /-.215064446351972E+14/,
     *     D(25) /-.247236992290621E+15/, D(26) /-.296588243029521E+16/,
     *     D(27) /-.370624400063547E+17/, D(28) /-.481678264794522E+18/,
     *     D(29) /-.650098408075106E+19/, D(30) /-.909919826436541E+20/
C-------------------------
C     SQT3 = SQRT(3)
C     EX3C = EXP(-I*PI/3)
C     EX6 = EXP(I*PI/6)
C     EX6C = EXP(-I*PI/6)
C     CLN2 = 0.5*I*LN(2)
C     C1 = PI**(-1/2)
C     C2 = (2*PI)**(-1/2)
C     C3 = 2**(-1/2)
C--------------------------
      DATA SQT3/1.73205080756888/
      DATA EX3C/(5.E-01, -8.66025403784439E-01)/
      DATA EX6/(8.66025403784439E-01, 5.E-01)/
      DATA EX6C/(8.66025403784439E-01, -5.E-01)/
      DATA CLN2/(0.0, 3.46573590279973E-01)/
      DATA C1/5.64189583547756E-01/
      DATA C2/3.98942280401433E-01/
      DATA C3/7.07106781186548E-01/
C--------------------------
C
C     EPS AND XM ARE MACHINE DEPENDENT CONSTANTS. EPS IS THE
C     SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0, XPOS IS THE
C     LARGEST POSITIVE NUMBER FOR WHICH EXP(XM) CAN BE COMPUTED,
C     AND XNEG IS THE NEGATIVE NUMBER OF LARGEST MAGNITUDE FOR
C     WHICH EXP(X) DOES NOT UNDERFLOW.
C
                      EPS = SPMPAR(1)
                      XPOS = EXPARG(0)
                      XNEG = EXPARG(1)
C
C------------------------
      IERR = 0
      X = REAL(Z)
      Y = AIMAG(Z)
      IF (X .LT. ABS(Y)*SQT3) GO TO 30
C
C          -----  ABS(ARG(Z)) .LE. PI/6  ----
C
      Z1 = CSQRT(Z)
      Z2 = CSQRT(Z1)
      Z2R = 1.0/Z2
      CALL CREC(X, Y, U, V)
      W = 1.5*CMPLX(U, V)/Z1
      U = ABS(REAL(W))
      V = ABS(AIMAG(W))
      T = AMAX1(U, V)
      IF (IND .NE. 0) GO TO 10
         IF (T .EQ. 0.0) GO TO 90
            U1 = U/T
            V1 = V/T
            R = U*U1 + V*V1
            IF (U1 .GE. R*XPOS .OR. V1 .GE. 0.1*R/EPS) GO TO 90
               ZETA = Z1*Z/1.5
               E = CEXP(ZETA)
C
   10 M = 20
      T = AMAX1(X, ABS(Y))
      IF (T .GT. 30.0) M = 8
      S1 = CMPLX(C(M), 0.0)
      S2 = CMPLX(D(M), 0.0)
      I = M
      DO 20 K = 2,M
         I = I - 1
         S1 = C(I) + W*S1
         S2 = D(I) + W*S2
   20 CONTINUE
C
      BI = C1*Z2R*S1
      BIP = C1*Z2*S2
      IF (IND .NE. 0) RETURN
         BI = E*BI
         BIP = E*BIP
         RETURN
   30 IF (X .LT. 0.0) GO TO 50
C
C          ----  PI/6 .LT. ABS(ARG(Z)) .LE. PI/2  ----
C
      CZ = Z
      IF (Y .LT. 0.0) CZ = CONJG(CZ)
      ZZ = CZ*EX3C
      Z1 = CSQRT(ZZ)
      Z2 = CSQRT(Z1)
      Z2R = 1.0/Z2
      CF1 = C1*Z2R*EX6
      CF2 = C1*Z2*EX6C
      CALL CREC(REAL(ZZ), AIMAG(ZZ), U, V)
      W = 1.5*CMPLX(U, V)/Z1
      U = ABS(REAL(W))
      V = ABS(AIMAG(W))
      T = AMAX1(U, V)
C
      IF (T .EQ. 0.0) GO TO 90
         U1 = U/T
         V1 = V/T
         R = U*U1 + V*V1
         IF (IND .NE. 0) GO TO 40
            IF (V1 .GE. R*XPOS .OR. U1 .GE. 0.1*R/EPS) GO TO 90
               ZETA = Z1*ZZ/1.5
               CN = CCOS(ZETA - CLN2)
               SI = CSIN(ZETA - CLN2)
               GO TO 70
C
C        E = EXP(-2*I*(ZETA - CLN2)) IF ABS(ARG(ZZ)) .LE. PI/3
C        E = EXP( 2*I*(ZETA - CLN2)) IF ABS(ARG(ZZ)) .GT. PI/3
C
   40    E = (0.0, 0.0)
         J = (0.0, -1.0)
         S = 1.0
         CE = 1.0
         CF = 0.5
         IF (AIMAG(ZZ) .LE. 0.0) GO TO 44
            S = -1.0
            CE = 0.5
            CF = 2.0
   44    IF (V1 .GE. 0.5*R*ABS(XNEG)) GO TO 45
         IF (U1 .GE. 0.05*R/EPS) GO TO 90
         ZETA = Z1*ZZ/1.5
         E = CF*CEXP(2.0*S*J*ZETA)
   45    CN = CE*C3*(1 + E)
         SI = CE*S*C3*(1 - E)*J
         GO TO 70
C
C                  ----  REAL(Z) .LT. 0  ----
C
   50 ZZ = -Z
      IF (Y .LT. 0.0) ZZ = CONJG(ZZ)
      Z1 = CSQRT(ZZ)
      Z2 = CSQRT(Z1)
      Z2R = 1.0/Z2
      CF1 = C2*Z2R
      CF2 = C2*Z2
      CALL CREC(REAL(ZZ), AIMAG(ZZ), U, V)
      W = 1.5*CMPLX(U, V)/Z1
      U = ABS(REAL(W))
      V = ABS(AIMAG(W))
      T = AMAX1(U, V)
C
      IF (T .EQ. 0.0) GO TO 90
         U1 = U/T
         V1 = V/T
         R = U*U1 + V*V1
         IF (IND .NE. 0) GO TO 60
            IF (V1 .GE. R*XPOS .OR. U1 .GE. 0.1*R/EPS) GO TO 90
               ZETA = Z1*ZZ/1.5
               CN = CCOS(ZETA)
               SI = CSIN(ZETA)
               GO TO 70
   60    E = (0.0, 0.0)
         J = (0.0, -1.0)
         IF (V1 .GE. 0.5*R*ABS(XNEG)) GO TO 65
         IF (U1 .GE. 0.05*R/EPS) GO TO 90
         ZETA = Z1*ZZ/1.5
         E = CEXP(2.0*J*ZETA)
   65    CN = 0.5*(1.0 + E)
         SI = 0.5*(1.0 - E)*J
C
   70 W2 = W*W
      M = 15
      T = AMAX1(ABS(X), ABS(Y))
      IF (T .GT. 30.0) M = 5
         M2 = M + M
         I = M2 - 1
         S1 = CMPLX(C(I), 0.0)
         S2 = CMPLX(C(M2), 0.0)
         S3 = CMPLX(D(I), 0.0)
         S4 = CMPLX(D(M2), 0.0)
         DO 80 K = 2,M
            I = I - 1
            S2 = C(I) - S2*W2
            S4 = D(I) - S4*W2
            I = I - 1
            S1 = C(I) - S1*W2
            S3 = D(I) - S3*W2
   80    CONTINUE
         S2 = W*S2
         S4 = W*S4
         IF (X .GE. 0.0) GO TO 81
            ALPHA = S1 + S2
            BETA = S2 - S1
            GO TO 82
   81    ALPHA = S1 - S2
         BETA = S1 + S2
   82    BI = CF1*(ALPHA*CN + BETA*SI)
         IF (X .GE. 0.0) GO TO 83
            ALPHA = S3 - S4
            BETA = S3 + S4
            GO TO 84
   83    ALPHA = S3 + S4
         BETA = S4 - S3
   84    BIP = CF2*(ALPHA*CN + BETA*SI)
         IF (Y .GE. 0.0) RETURN
         BI = CONJG(BI)
         BIP = CONJG(BIP)
         RETURN
C
C            RETURN WITH ZERO VALUES IF SCALING IS NEEDED.
C
   90 BI = (0.0, 0.0)
      BIP = (0.0, 0.0)
      IERR = 1
      RETURN
      END
      SUBROUTINE IA(Z, I1, I2, I1M, I2M)
C-------------------------------------------------------------
C     CALCULATES THE MODIFIED BESSEL FUNCTION OF THE FIRST
C     KIND FOR ORDERS 1/3, 2/3, -1/3, AND -2/3 AND FOR COMPLEX
C     ARGUMENT Z, WHERE -PI .LT. ARG(Z) .LE. PI.  I1 AND I2
C     ARE REPLACED BY THE FUNCTIONS OF ORDERS 1/3 AND 2/3,
C     RESPECTIVELY, AND I1M AND I2M BY THE FUNCTIONS OF ORDERS
C     -1/3 AND -2/3, RESPECTIVELY.
C-------------------------------------------------------------
      COMPLEX Z,I1,I2,I1M,I2M,CZ,EX13,EX13C,EX23,EX23C
C
C     EX13 = EXP(I*PI/3)
C     EX13C = EXP(-I*PI/3)
C     EX23 = EXP(2*I*PI/3)
C     EX23C = EXP(-2*I*PI/3)
C
      DATA EX13/(5.0E-01, 8.66025403784439E-01)/
      DATA EX13C/(5.0E-01, -8.66025403784439E-01)/
      DATA EX23/(-5.0E-01, 8.66025403784439E-01)/
      DATA EX23C/(-5.0E-01, -8.66025403784439E-01)/
      IF(REAL(Z) .GE. 0.0) GO TO 20
         CZ = -Z
C
C     CALCULATION OF I1, I2, I1M, AND I2M WHEN REAL(CZ) .GT. 0.
C
         CALL IMC(CZ, I1, I2, I1M, I2M)
C
C     FINAL ASSEMBLY
C
         IF(AIMAG(Z) .LT. 0.0) GO TO 10
            I1 = EX13*I1
            I2 = EX23*I2
            I1M = EX13C*I1M
            I2M = EX23C*I2M
            RETURN
   10    I1 = EX13C*I1
         I2 = EX23C*I2
         I1M = EX13*I1M
         I2M = EX23*I2M
         RETURN
   20    CALL IMC(Z, I1, I2, I1M, I2M)
         RETURN
         END
      SUBROUTINE IMC(Z, I1, I2, I1M, I2M)
C----------------------------------------------------------------
C     CALCULATES THE MODIFIED BESSEL FUNCTION OF THE FIRST
C     KIND FOR ORDERS 1/3, 2/3, -1/3, AND -2/3 AND FOR COMPLEX
C     ARGUMENT Z. THE MACLAURIN EXPANSION AND BACKWARD RECURRENCE
C     ARE USED. I1 AND I2 ARE REPLACED BY THE FUNCTIONS OF ORDERS
C     1/3 AND 2/3, RESPECTIVELY, AND I1M AND I2M BY THE FUNCTIONS
C     OF ORDERS -1/3 AND -2/3, RESPECTIVELY.  FOR GREATEST
C     ACCURACY, Z SHOULD LIE IN THE REGION REAL(Z) .GE. 0.
C----------------------------------------------------------------
      COMPLEX Z,IA1,IA2,IA3,IB1,IB2,IB3,I1,I2,I1M,I2M,SZ,ZH,E,
     *        CF1,CF2,CF3,CF4
      REAL M
C
C     GM1 = GAMMA(4.0/3.0)
C     GM2 = GAMMA(5.0/3.0)
C
      DATA C1/.333333333333333E+00/
      DATA C2/.666666666666667E+00/
      DATA GM1/.892979511569248E+00/
      DATA GM2/.902745292950932E+00/
      ZH = 0.5*Z
      SZ = ZH*ZH
      A = REAL(ZH)
      B = AIMAG(ZH)
      AN = AINT(A*A + B*B)
      CN1 = C1 + AN
      CN2 = C2 + AN
C
C     CALCULATION OF INITIAL VALUES FOR BACKWARD RECURRENCE BY
C     USE OF THE MACLAURIN EXPANSION.
C
      CALL BIM(Z, CN1, IA1)
      CALL BIM(Z, CN1 + 1.0, IA2)
      CALL BIM(Z, CN2, IB1)
      CALL BIM(Z, CN2 + 1.0, IB2)
C
C     BACKWARD RECURRENCE
C
      N = AN
      M = AN
      N1 = N + 1
      DO 10 I = 1, N1
         IA3 = IA2
         IA2 = IA1
         IB3 = IB2
         IB2 = IB1
         CFA = (M + C1)*(M + C1 + 1.0)
         CFB = (M + C2)*(M + C2 + 1.0)
         M = M - 1.0
         IA1 = IA2 + (SZ/CFA)*IA3
   10    IB1 = IB2 + (SZ/CFB)*IB3
      E = CEXP(C1*CLOG(ZH))
      CF1 = E/GM1
      CF2 = E*E/GM2
      CF3 = C2*CF2/ZH
      CF4 = C1*CF1/ZH
      I1 = CF1*IA2
      I2 = CF2*IB2
      I1M = CF3*IB1
      I2M = CF4*IA1
      RETURN
      END
      SUBROUTINE BIM(Z,CN,W)
C-------------------------------------------------------------
C     CALCULATES THE MODIFIED BESSEL FUNCTION OF THE FIRST KIND
C     FOR REAL ORDER CN .GT. -1 AND COMPLEX ARGUMENT Z BY MEANS
C     OF THE MACLAURIN EXPANSION.  W IS REPLACED BY THE
C     CALCULATED VALUE.
C-------------------------------------------------------------
      REAL M
      COMPLEX Z, W, SZ, T
C------------------
      ANORM(Z) = AMAX1(ABS(REAL(Z)),ABS(AIMAG(Z)))
C-------------------------------------------------------------
C     EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE SMALLEST
C     NUMBER SUCH THAT 1 + EPS .GT. 1.
C
      EPS = SPMPAR(1)
C
C-------------------------------------------------------------
      SZ = 0.25*Z*Z
C
C     INITIALIZATION OF MACLAURIN EXPANSION
C
      M = 1.0
      T = SZ/(CN + 1.0)
      W = T
C
C     SUMMATION OF MACLAURIN EXPANSION
C
   10    M = M + 1.0
         D = M*(CN + M)
         T = T*(SZ/D)
         W = W + T
         IF(ANORM(T) .GT. EPS*ANORM(W)) GO TO 10
C
      W = W + 1.0
      RETURN
      END
      SUBROUTINE JA(Z, I1, I2, I1M, I2M)
C------------------------------------------------------------
C     CALCULATES THE BESSEL FUNCTION OF THE FIRST KIND FOR
C     ORDERS 1/3, 2/3, -1/3, AND -2/3 AND FOR COMPLEX ARGUMENT
C     Z, WHERE -PI .LT. ARG(Z) .LE. PI.  I1 AND I2 ARE REPLACED
C     BY THE FUNCTIONS OF ORDERS 1/3 AND 2/3, RESPECTIVELY, AND
C     I1M AND I2M BY FUNCTIONS OF ORDERS -1/3 AND -2/3,
C     RESPECTIVELY.
C--------------------------------------------------------------
      COMPLEX Z,I1,I2,I1M,I2M,CZ,EX13,EX13C,EX23,EX23C
C
C     EX13 = EXP(I*PI/3)
C     EX13C = EXP(-I*PI/3)
C     EX23 = EXP(2*I*PI/3)
C     EX23C = EXP(-2*I*PI/3)
C
      DATA EX13/(5.0E-01, 8.66025403784439E-01)/
      DATA EX13C/(5.0E-01, -8.66025403784439E-01)/
      DATA EX23/(-5.0E-01, 8.66025403784439E-01)/
      DATA EX23C/(-5.0E-01, -8.66025403784439E-01)/
      IF(REAL(Z) .GE. 0.0) GO TO 20
         CZ = -Z
C
C     CALCULATION OF I1, I2, I1M, AND I2M WHEN REAL(CZ) .GT. 0.0
C
         CALL JMC(CZ, I1, I2, I1M, I2M)
C
C     FINAL ASSEMBLY
C
         IF(AIMAG(Z) .LT. 0.0) GO TO 10
            I1 = EX13*I1
            I2 = EX23*I2
            I1M = EX13C*I1M
            I2M = EX23C*I2M
            RETURN
   10    I1 = EX13C*I1
         I2 = EX23C*I2
         I1M = EX13*I1M
         I2M = EX23*I2M
         RETURN
   20    CALL JMC(Z, I1, I2, I1M, I2M)
         RETURN
         END
      SUBROUTINE JMC(Z, I1, I2, I1M, I2M)
C----------------------------------------------------------------
C     CALCULATES THE BESSEL FUNCTION OF THE FIRST
C     KIND FOR ORDERS 1/3, 2/3, -1/3, AND -2/3 AND FOR COMPLEX
C     ARGUMENT Z. THE MACLAURIN EXPANSION AND BACKWARD RECURRENCE
C     ARE USED. I1 AND I2 ARE REPLACED BY THE FUNCTIONS OF ORDERS
C     1/3 AND 2/3, RESPECTIVELY, AND I1M AND I2M BY THE FUNCTIONS
C     OF ORDERS -1/3 AND -2/3, RESPECTIVELY.  FOR GREATEST
C     ACCURACY, Z SHOULD LIE IN THE REGION REAL(Z) .GE. 0.
C----------------------------------------------------------------
      COMPLEX Z,IA1,IA2,IA3,IB1,IB2,IB3,I1,I2,I1M,I2M,SZ,ZH,E,
     *        CF1,CF2,CF3,CF4
      REAL M
C
C     GM1 = GAMMA(4.0/3.0)
C     GM2 = GAMMA(5.0/3.0)
C
      DATA C1/.333333333333333E+00/
      DATA C2/.666666666666667E+00/
      DATA GM1/.892979511569248E+00/
      DATA GM2/.902745292950932E+00/
      ZH = 0.5*Z
      SZ = ZH*ZH
      A = REAL(ZH)
      B = AIMAG(ZH)
      AN = AINT(A*A + B*B)
      CN1 = C1 + AN
      CN2 = C2 + AN
C
C     CALCULATION OF INITIAL VALUES FOR BACKWARD RECURRENCE BY
C     USE OF THE MACLAURIN EXPANSION.
C
      CALL BJM(Z, CN1, IA1)
      CALL BJM(Z, CN1 + 1.0, IA2)
      CALL BJM(Z, CN2, IB1)
      CALL BJM(Z, CN2 + 1.0, IB2)
C
C     BACKWARD RECURRENCE
C
      N = AN
      N1 = N + 1
      M = AN
      DO 10 I = 1, N1
         IA3 = IA2
         IA2 = IA1
         IB3 = IB2
         IB2 = IB1
         CFA = (M + C1)*(M + C1 + 1.0)
         CFB = (M + C2)*(M + C2 + 1.0)
         M = M - 1.0
         IA1 = IA2 - (SZ/CFA)*IA3
   10    IB1 = IB2 - (SZ/CFB)*IB3
      E = CEXP(C1*CLOG(ZH))
      CF1 = E/GM1
      CF2 = E*E/GM2
      CF3 = C2*CF2/ZH
      CF4 = C1*CF1/ZH
      I1 = CF1*IA2
      I2 = CF2*IB2
      I1M = CF3*IB1
      I2M = CF4*IA1
      RETURN
      END
      SUBROUTINE BJM(Z,CN,W)
C-------------------------------------------------------------
C     CALCULATES THE BESSEL FUNCTION OF THE FIRST KIND
C     FOR REAL ORDER CN .GT. -1 AND COMPLEX ARGUMENT Z BY MEANS
C     OF THE MACLAURIN EXPANSION.  W IS REPLACED BY THE
C     CALCULATED VALUE.
C-------------------------------------------------------------
      REAL M
      COMPLEX Z, W, SZ, T
C------------------
      ANORM(Z) = AMAX1(ABS(REAL(Z)),ABS(AIMAG(Z)))
C-------------------------------------------------------------
C     EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE SMALLEST
C     NUMBER SUCH THAT 1 + EPS .GT. 1.
C
      EPS = SPMPAR(1)
C
C-------------------------------------------------------------
      SZ = -0.25*Z*Z
C
C     INITIALIZATION OF MACLAURIN EXPANSION
C
      M = 1.0
      T = SZ/(CN + 1.0)
      W = T
C
C     SUMMATION OF MACLAURIN EXPANSION
C
   10    M = M + 1.0
         D = M*(CN + M)
         T = T*(SZ/D)
         W = W + T
         IF(ANORM(T) .GT. EPS*ANORM(W)) GO TO 10
C
      W = W + 1.0
      RETURN
      END
      SUBROUTINE KA(IND, Z, K1, K2)
C------------------------------------------------------------
C     CALCULATES THE MODIFIED BESSEL FUNCTION OF THE SECOND
C     KIND FOR ORDERS 1/3 AND 2/3 AND FOR COMPLEX ARGUMENT Z,
C     WHERE -PI .LT. ARG(Z) .LE PI.  K1 IS REPLACED BY THE
C     FUNCTION OF ORDER 1/3, AND K2 BY THE FUNCTION OF ORDER
C     2/3.
C------------------------------------------------------------
      COMPLEX Z,K1,K2,I1,I2,I1M,I2M,CZ,EX13C,EX23C,J,E
C
C     EX13C = EXP(-PI*I/3)
C     EX23C = EXP(-2*PI*I/3)
C
      DATA PI/3.14159265358979E+00/
      DATA EX13C/(5.0E-01, -8.66025403784439E-01)/
      DATA EX23C/(-5.0E-01, -8.66025403784439E-01)/
      DATA J/(0.0, 1.0)/
      A = REAL(Z)
      B = AIMAG(Z)
      IF (ABS(B) .LT. -0.5*A) GO TO 10
C
C            ----  ABS(B) .GE. -0.5*A  ----
C
         CALL KML(IND, Z, K1, K2)
         RETURN
C
C            ----  ABS(B) .LT. -0.5*A  ----
C
   10    CZ = -Z
         IF(AIMAG(Z) .LT. 0.0) CZ = CONJG(CZ)
         IND1 = 0
         CALL KML(IND1, CZ, K1, K2)
         CALL IMC(CZ, I1, I2, I1M, I2M)
         K1 = EX13C*K1 - J*PI*I1
         K2 = EX23C*K2 - J*PI*I2
         IF (IND .EQ. 0) GO TO 20
         E = CEXP(Z)
         K1 = K1*E
         K2 = K2*E
   20    IF(AIMAG(Z) .GE. 0.0) RETURN
            K1 = CONJG(K1)
            K2 = CONJG(K2)
            RETURN
      END
      SUBROUTINE KML(IND, Z, K1, K2)
C------------------------------------------------------------
C     CALCULATES THE MODIFIED BESSEL FUNCTION OF THE SECOND
C     KIND FOR ORDERS 1/3 AND 2/3 AND FOR COMPLEX ARGUMENT Z
C     BY USE OF THE MILLER ALGORITHM.  K1 IS REPLACED BY THE
C     FUNCTION OF ORDER 1/3, AND K2 BY THE FUNCTION OF ORDER
C     2/3.  FOR GREATEST ACCURACY, Z SHOULD LIE IN THE REGION
C     REAL(Z) .GE. 0.
C------------------------------------------------------------
      COMPLEX Z, K1, K2, BI, U1, U2, U3, S, E
C
C     C1 = SQRT(PI/2)
C
      DATA C1/1.25331413731550E+00/
      EPS = SPMPAR(1)
      X1 = REAL(Z)
      X2 = AIMAG(Z)
C
C     CALCULATION OF M FOR USE IN MILLER ALGORITHM.
C
      CALL CAPO(X1, X2, R, TH)
      A = 3.0/(1.0 + R)
      B = 14.7/(28.0 + R)
      C = 2.0/(C1*EPS*(2.0*R)**(0.25))
      M = (0.485/R)*(ALOG(C) + R*COS(A*TH)/(1.0 + 0.008*R))**2/
     1    (2.0*COS(B*TH))**2 + 1.5
C
C     BACKWARD RECURRENCE IN MILLER ALGORITHM.
C
      S = 0.0
      U2 = 0.0
      U1 = EPS
      L = M
      DO 10 I = 1, M
         AL = L
         U3 = U2
         U2 = U1
         AI = ((AL - 0.5)**2 - 1.0/9.0)/(AL*(AL + 1.0))
         BI = 2.0*(AL + Z)/(AL + 1.0)
         U1 = (BI*U2 - U3)/AI
         S = S + U1
   10    L = L - 1
C
C     FINAL ASSEMBLY
C
      K1 = C1*U1/(S*CSQRT(Z))
      K2 = K1*(Z  + 1.0/6.0 - U2/U1)/Z
      IF (IND .NE. 0) RETURN
         E = CEXP(-Z)
         K1 = K1*E
         K2 = K2*E
         RETURN
      END
      REAL FUNCTION AI(X)
C-----------------------------------------------------------------------
C     EVALUATION OF THE AIRY FUNCTION AI(X)
C-----------------------------------------------------------------------
C     X0 = 2**(2/3)
C     C = EXP(2/3)
C-----------------------
      DATA X0/1.58740105196820/
      DATA C /1.94773404105468/
C-----------------------
      DATA AN0/ .355028053887818E+00/, AN1/-.187394912983414E+00/,
     *     AN2/-.383735973881972E-01/, AN3/ .491952571236878E-01/,
     *     AN4/-.967017625191329E-02/, AN5/-.205648610308316E-02/,
     *     AN6/ .114176040526844E-02/, AN7/-.117114823456866E-03/,
     *     AN8/-.270165470074755E-04/, AN9/ .789002965889206E-05/
      DATA AD0/ .100000000000000E+01/, AD1/ .201179850513612E+00/,
     *     AD2/ .385762517106249E-01/, AD3/ .230887443780120E-04/
C-----------------------
      DATA BN0/ .355028053887817E+00/, BN1/-.997169317338190E-01/,
     *     BN2/-.602216060213075E-01/, BN3/ .297705337630730E-01/,
     *     BN4/-.152969932286570E-02/, BN5/-.147868368189372E-02/,
     *     BN6/ .350518617006107E-03/, BN7/-.257766924610873E-04/
      DATA BD0/.100000000000000E+01/, BD1/.448140563306831E+00/,
     *     BD2/.157074537566686E+00/, BD3/.316964519364865E-01/,
     *     BD4/.485922740843953E-02/, BD5/.423326964456309E-03/
C-----------------------
      DATA PN0/.282094378896566E+00/, PN1/.807868561687271E-01/,
     *     PN2/.630644564152247E-02/, PN3/.147116711467936E-03/,
     *     PN4/.750490748341483E-06/
      DATA PD0/.100000000000000E+01/, PD1/.292890323271551E+00/,
     *     PD2/.239376862143358E-01/, PD3/.612353984250624E-03/,
     *     PD4/.384461189764830E-05/, PD5/.123247804102182E-08/
C-----------------------
      DATA QN0/.282094791017188E+00/, QN1/.149585822742689E+00/,
     *     QN2/.241876418864958E-01/, QN3/.138190913282142E-02/,
     *     QN4/.241862862465003E-04/, QN5/.709733720554615E-07/
      DATA QD0/.100000000000000E+01/, QD1/.536778341756648E+00/,
     *     QD2/.889112579703465E-01/, QD3/.533368703697049E-02/,
     *     QD4/.103812739863315E-03/, QD5/.408838544650398E-06/
C-----------------------
      DATA RN0/.282094791773878E+00/, RN1/.203731967781874E+00/,
     *     RN2/.436660479870037E-01/, RN3/.306595563073142E-02/,
     *     RN4/.517398800281618E-04/
      DATA RD0/.100000000000000E+01/, RD1/.728721438361672E+00/,
     *     RD2/.159210021472267E+00/, RD3/.116985268534248E-01/,
     *     RD4/.225973894323078E-03/, RD5/.232707159780478E-06/
C-----------------------------------------------------------------------
      IF (X .GE. -1.0) GO TO 10
      CALL AIMP (-X, R, PHI)
      AI = R*SIN(PHI)
      RETURN
C
   10 IF (X .GE. 0.0) GO TO 20
      AI = (((((((((AN9*X + AN8)*X + AN7)*X + AN6)*X + AN5)*X
     *           + AN4)*X + AN3)*X + AN2)*X + AN1)*X + AN0) /
     *           (((AD3*X + AD2)*X + AD1)*X + AD0)
      RETURN
C
   20 IF (X .GE. 1.0) GO TO 30
      AI = (((((((BN7*X + BN6)*X + BN5)*X + BN4)*X + BN3)*X + BN2)*X
     *                  + BN1)*X + BN0) /
     *     (((((BD5*X + BD4)*X + BD3)*X + BD2)*X + BD1)*X + BD0)
      RETURN
C
   30 RTX = SQRT(X)
      IF (X .GT. X0) GO TO 40
      T = 16.0/(X*RTX)
      W = ((((PN4*T + PN3)*T + PN2)*T + PN1)*T + PN0) /
     *    (((((PD5*T + PD4)*T + PD3)*T + PD2)*T + PD1)*T + PD0)
      AI = (W/SQRT(RTX)) * EXP(-2.0*X*RTX/3.0)
      RETURN
C
   40 IF (X .GT. 4.0D0) GO TO 50
      T = 16.0/(X*RTX)
      W = (((((QN5*T + QN4)*T + QN3)*T + QN2)*T + QN1)*T + QN0) /
     *    (((((QD5*T + QD4)*T + QD3)*T + QD2)*T + QD1)*T + QD0)
      AI = (W/SQRT(RTX)) * EXP(-2.0*X*RTX/3.0)
      RETURN
C
   50 IF (X*RTX .GT. 1.5*EXPARG(0)) GO TO 60
      T = 16.0/(X*RTX)
      W = ((((RN4*T + RN3)*T + RN2)*T + RN1)*T + RN0) /
     *    (((((RD5*T + RD4)*T + RD3)*T + RD2)*T + RD1)*T + RD0)
      N = RTX
      N2 = N*N
      T = (X - N2)/(RTX + N)
      AI = ((W/SQRT(RTX)) / C**(N2*N)) * EXP(-2.0*T*(N*RTX + T*T/3.0))
      RETURN
C
   60 AI = 0.0
      RETURN
      END
      REAL FUNCTION AIE(X)
C-----------------------------------------------------------------------
C
C                   SCALED AIRY FUNCTION AI(X)
C
C
C             AIE(X) = EXP(ZETA)*AI(X)  WHEN X .GE. 0
C             AIE(X) = AI(X)            WHEN X .LT. 0
C
C             ZETA = (2/3) * X**(3/2)
C
C-----------------------------------------------------------------------
C     X0 = 2**(2/3)
C-----------------------
      DATA X0/.158740105196820E+01/
C-----------------------
      DATA AN0/ .355028053887818E+00/, AN1/-.187394912983414E+00/,
     *     AN2/-.383735973881972E-01/, AN3/ .491952571236878E-01/,
     *     AN4/-.967017625191329E-02/, AN5/-.205648610308316E-02/,
     *     AN6/ .114176040526844E-02/, AN7/-.117114823456866E-03/,
     *     AN8/-.270165470074755E-04/, AN9/ .789002965889206E-05/
      DATA AD0/ .100000000000000E+01/, AD1/ .201179850513612E+00/,
     *     AD2/ .385762517106249E-01/, AD3/ .230887443780120E-04/
C-----------------------
      DATA BN0/ .355028053887817E+00/, BN1/-.997169317338190E-01/,
     *     BN2/-.602216060213075E-01/, BN3/ .297705337630730E-01/,
     *     BN4/-.152969932286570E-02/, BN5/-.147868368189372E-02/,
     *     BN6/ .350518617006107E-03/, BN7/-.257766924610873E-04/
      DATA BD0/.100000000000000E+01/, BD1/.448140563306831E+00/,
     *     BD2/.157074537566686E+00/, BD3/.316964519364865E-01/,
     *     BD4/.485922740843953E-02/, BD5/.423326964456309E-03/
C-----------------------
      DATA PN0/.282094378896566E+00/, PN1/.807868561687271E-01/,
     *     PN2/.630644564152247E-02/, PN3/.147116711467936E-03/,
     *     PN4/.750490748341483E-06/
      DATA PD0/.100000000000000E+01/, PD1/.292890323271551E+00/,
     *     PD2/.239376862143358E-01/, PD3/.612353984250624E-03/,
     *     PD4/.384461189764830E-05/, PD5/.123247804102182E-08/
C-----------------------
      DATA QN0/.282094791017188E+00/, QN1/.149585822742689E+00/,
     *     QN2/.241876418864958E-01/, QN3/.138190913282142E-02/,
     *     QN4/.241862862465003E-04/, QN5/.709733720554615E-07/
      DATA QD0/.100000000000000E+01/, QD1/.536778341756648E+00/,
     *     QD2/.889112579703465E-01/, QD3/.533368703697049E-02/,
     *     QD4/.103812739863315E-03/, QD5/.408838544650398E-06/
C-----------------------
      DATA RN0/.282094791773878E+00/, RN1/.203731967781874E+00/,
     *     RN2/.436660479870037E-01/, RN3/.306595563073142E-02/,
     *     RN4/.517398800281618E-04/
      DATA RD0/.100000000000000E+01/, RD1/.728721438361672E+00/,
     *     RD2/.159210021472267E+00/, RD3/.116985268534248E-01/,
     *     RD4/.225973894323078E-03/, RD5/.232707159780478E-06/
C-----------------------------------------------------------------------
      IF (X .GE. -1.0) GO TO 10
      CALL AIMP (-X, R, PHI)
      AIE = R*SIN(PHI)
      RETURN
C
   10 IF (X .GE. 0.0) GO TO 20
      AIE = (((((((((AN9*X + AN8)*X + AN7)*X + AN6)*X + AN5)*X
     *            + AN4)*X + AN3)*X + AN2)*X + AN1)*X + AN0) /
     *            (((AD3*X + AD2)*X + AD1)*X + AD0)
      RETURN
C
   20 IF (X .GE. 1.0) GO TO 30
      AIE = (((((((BN7*X + BN6)*X + BN5)*X + BN4)*X + BN3)*X + BN2)*X
     *                   + BN1)*X + BN0) /
     *      (((((BD5*X + BD4)*X + BD3)*X + BD2)*X + BD1)*X + BD0)
      IF (X .GT. 1.E-20) AIE = AIE * EXP(2.0*X*SQRT(X)/3.0)
      RETURN
C
   30 RTX = SQRT(X)
      IF (X .GT. X0) GO TO 40
      T = 16.0/(X*RTX)
      W = ((((PN4*T + PN3)*T + PN2)*T + PN1)*T + PN0) /
     *    (((((PD5*T + PD4)*T + PD3)*T + PD2)*T + PD1)*T + PD0)
      AIE = W/SQRT(RTX)
      RETURN
C
   40 IF (X .GT. 4.0D0) GO TO 50
      T = 16.0/(X*RTX)
      W = (((((QN5*T + QN4)*T + QN3)*T + QN2)*T + QN1)*T + QN0) /
     *    (((((QD5*T + QD4)*T + QD3)*T + QD2)*T + QD1)*T + QD0)
      AIE = W/SQRT(RTX)
      RETURN
C
   50 IF (X .GT. 1.E20) GO TO 60
      T = 16.0/(X*RTX)
      W = ((((RN4*T + RN3)*T + RN2)*T + RN1)*T + RN0) /
     *    (((((RD5*T + RD4)*T + RD3)*T + RD2)*T + RD1)*T + RD0)
      AIE = W/SQRT(RTX)
      RETURN
C
   60 AIE = RN0/SQRT(RTX)
      RETURN
      END
      REAL FUNCTION BI(X)
C-----------------------------------------------------------------------
C
C             EVALUATION OF THE AIRY FUNCTION BI(X)
C
C
C     NOTE... IF X IS A POSITIVE NUMBER WHERE BI(X) IS TOO LARGE
C     TO BE COMPUTED, THEN BI(X) IS SET TO 0.
C
C-----------------------------------------------------------------------
C     X0 = 16**(2/3)
C     C = EXP(2/3)
C-----------------------
      DATA X0/6.3496042078728/
      DATA C /1.94773404105468/
C-----------------------
      DATA AN0/ .614926627446001E+00/, AN1/ .462726943978834E+00/,
     *     AN2/ .867811386408974E-02/, AN3/ .974670609357959E-01/,
     *     AN4/ .370856545413908E-01/, AN5/ .569193415071716E-03/,
     *     AN6/ .269172131237236E-02/, AN7/ .746473849872868E-03/,
     *     AN8/ .105638036899269E-04/, AN9/ .242726195973978E-04/,
     *     AN10/.557260250681542E-05/
      DATA AD0/ .100000000000000E+01/, AD1/ .234801779278695E-01/,
     *     AD2/-.300487317759152E-02/, AD3/-.597414466459612E-02/
C-----------------------
      DATA BN0/ .614926627446001E+00/, BN1/ .548653374523520E+00/,
     *     BN2/ .582684047163842E-01/, BN3/ .871954925712688E-01/,
     *     BN4/ .508547058449004E-01/, BN5/ .361412623711710E-02/,
     *     BN6/ .177269722794511E-02/, BN7/ .117774184027185E-02/,
     *     BN8/ .627004834186143E-04/, BN9/ .774782269814080E-06/,
     *     BN10/.118116474369315E-04/
      DATA BD0/ .100000000000000E+01/, BD1/ .163214622184402E+00/,
     *     BD2/-.242285981710408E-01/, BD3/-.720554280297616E-02/
C-----------------------
      DATA PN0/.619911943572678E+00/, PN1/.100411558489626E+01/,
     *     PN2/.563659963795768E+00/, PN3/.274925508033015E+00/,
     *     PN4/.115641822943246E+00/, PN5/.120048517441127E-01/,
     *     PN6/.501838091254330E-02/
      DATA PD0/.100000000000000E+01/, PD1/.159751878026937E+01/,
     *     PD2/.104664867034140E+01/, PD3/.512560333664022E+00/,
     *     PD4/.159144727666995E+00/, PD5/.394456748956258E-01/,
     *     PD6/.529926873250079E-02/, PD7/.288921845412576E-03/
C-----------------------
      DATA QN0/.595123543430856E+00/, QN1/.652692120245803E+00/,
     *     QN2/.436851872835894E+00/, QN3/.201626141057807E+00/,
     *     QN4/.649535170626944E-01/, QN5/.171798867787816E-01/,
     *     QN6/.287998748038892E-02/, QN7/.359634362348937E-03/
      DATA QD0/.100000000000000E+01/, QD1/.114259871204893E+01/,
     *     QD2/.766390439057101E+00/, QD3/.348287281255683E+00/,
     *     QD4/.117049276946157E+00/, QD5/.294545450289541E-01/,
     *     QD6/.523951773968125E-02/, QD7/.622692248774973E-03/,
     *     QD8/.674811395957744E-06/
C-----------------------
      DATA RN0 / .568067636505865E+00/, RN1 / .462183136291541E-01/,
     *     RN2 / .268519638203645E+00/, RN3 / .199427104235673E-02/,
     *     RN4 / .135599161332010E-03/, RN5 / .229937707171804E-04/,
     *     RN6 / .697888081361175E-05/, RN7 / .153277172934286E-05/,
     *     RN8 /-.149322381877245E-05/, RN9 /-.113533571972859E-05/,
     *     RN10/ .740721412702102E-06/, RN11/-.120160431596119E-06/
      DATA RD0 / .100000000000000E+01/, RD1 / .741293424676788E-01/,
     *     RD2 / .471695968238457E+00/
C-----------------------
      DATA SN0 /.564189583547757E+00/, SN1 / .112605519585866E+00/,
     *     SN2 /.893329124921909E-03/, SN3 / .532139134120350E-04/,
     *     SN4 /.592725458717738E-05/, SN5 / .921448923850546E-06/,
     *     SN6 /.404558310611815E-06/, SN7 /-.660517686759109E-06/,
     *     SN8 /.174667472383815E-05/, SN9 /-.287037710548882E-05/,
     *     SN10/.322304072982791E-05/, SN11/-.231569499551950E-05/,
     *     SN12/.963478964685941E-06/, SN13/-.173784488565533E-06/
      DATA SD0 /.100000000000000E+01/, SD1 / .193077670156841E+00/
C-----------------------------------------------------------------------
      IF (X .GE. -1.0) GO TO 10
      CALL AIMP (-X, R, PHI)
      BI = R*COS(PHI)
      RETURN
C
   10 IF (X .GE. 0.0) GO TO 20
      BI = ((((((((((AN10*X + AN9)*X + AN8)*X + AN7)*X
     *             + AN6)*X + AN5)*X + AN4)*X + AN3)*X
     *             + AN2)*X + AN1)*X + AN0) /
     *             (((AD3*X + AD2)*X + AD1)*X + AD0)
      RETURN
C
   20 IF (X .GT. 1.0) GO TO 30
      BI = ((((((((((BN10*X + BN9)*X + BN8)*X + BN7)*X
     *             + BN6)*X + BN5)*X + BN4)*X + BN3)*X
     *             + BN2)*X + BN1)*X + BN0) /
     *             (((BD3*X + BD2)*X + BD1)*X + BD0)
      RETURN
C
   30 RTX = SQRT(X)
      IF (X .GT. 2.0) GO TO 40
      T = X - 1.0
      W = ((((((PN6*T + PN5)*T + PN4)*T + PN3)*T + PN2)*T
     *                + PN1)*T + PN0) /
     *    (((((((PD7*T + PD6)*T + PD5)*T + PD4)*T + PD3)*T
     *                 + PD2)*T + PD1)*T + PD0)
      BI = (W/SQRT(RTX)) * EXP(2.0*X*RTX/3.0)
      RETURN
C
   40 IF (X .GT. 4.0) GO TO 50
      T = X - 2.0
      W = (((((((QN7*T + QN6)*T + QN5)*T + QN4)*T + QN3)*T
     *                 + QN2)*T + QN1)*T + QN0) /
     *    ((((((((QD8*T + QD7)*T + QD6)*T + QD5)*T + QD4)*T
     *                  + QD3)*T + QD2)*T + QD1)*T + QD0)
      BI = (W/SQRT(RTX)) * EXP(2.0*X*RTX/3.0)
      RETURN
C
   50 IF (X .GT. X0) GO TO 60
      T = 16.0/(X*RTX) - 1.0
      W = (((((((((((RN11*T + RN10)*T + RN9)*T + RN8)*T
     *     + RN7)*T + RN6)*T + RN5)*T + RN4)*T + RN3)*T
     *     + RN2)*T + RN1)*T + RN0) /
     *      ((RD2*T + RD1)*T + RD0)
      BI = (W/SQRT(RTX)) * EXP(2.0*X*RTX/3.0)
      RETURN
C
   60 IF (X*RTX .GT. 1.5*EXPARG(0)) GO TO 70
      T = 16.0/(X*RTX)
      W = (((((((((((((SN13*T + SN12)*T + SN11)*T + SN10)*T
     *         + SN9)*T + SN8)*T + SN7)*T + SN6)*T + SN5)*T
     *         + SN4)*T + SN3)*T + SN2)*T + SN1)*T + SN0) /
     *           (SD1*T + SD0)
      N = RTX
      N2 = N*N
      T = (X - N2)/(RTX + N)
      BI = (W/SQRT(RTX)) * C**(N2*N) * EXP(2.0*T*(N*RTX + T*T/3.0))
      RETURN
C
   70 BI = 0.0
      RETURN
      END
      REAL FUNCTION BIE(X)
C-----------------------------------------------------------------------
C
C                    SCALED AIRY FUNCTION BI(X)
C
C
C             BIE(X) = EXP(-ZETA)*BI(X)  WHEN X .GE. 0
C             BIE(X) = BI(X)             WHEN X .LT. 0
C
C             ZETA = (2/3) * X**(3/2)
C
C-----------------------------------------------------------------------
C     X0 = 16**(2/3)
C-----------------------
      DATA X0/6.3496042078728/
C-----------------------
      DATA AN0/ .614926627446001E+00/, AN1/ .462726943978834E+00/,
     *     AN2/ .867811386408974E-02/, AN3/ .974670609357959E-01/,
     *     AN4/ .370856545413908E-01/, AN5/ .569193415071716E-03/,
     *     AN6/ .269172131237236E-02/, AN7/ .746473849872868E-03/,
     *     AN8/ .105638036899269E-04/, AN9/ .242726195973978E-04/,
     *     AN10/.557260250681542E-05/
      DATA AD0/ .100000000000000E+01/, AD1/ .234801779278695E-01/,
     *     AD2/-.300487317759152E-02/, AD3/-.597414466459612E-02/
C-----------------------
      DATA BN0/ .614926627446001E+00/, BN1/ .548653374523520E+00/,
     *     BN2/ .582684047163842E-01/, BN3/ .871954925712688E-01/,
     *     BN4/ .508547058449004E-01/, BN5/ .361412623711710E-02/,
     *     BN6/ .177269722794511E-02/, BN7/ .117774184027185E-02/,
     *     BN8/ .627004834186143E-04/, BN9/ .774782269814080E-06/,
     *     BN10/.118116474369315E-04/
      DATA BD0/ .100000000000000E+01/, BD1/ .163214622184402E+00/,
     *     BD2/-.242285981710408E-01/, BD3/-.720554280297616E-02/
C-----------------------
      DATA PN0/.619911943572678E+00/, PN1/.100411558489626E+01/,
     *     PN2/.563659963795768E+00/, PN3/.274925508033015E+00/,
     *     PN4/.115641822943246E+00/, PN5/.120048517441127E-01/,
     *     PN6/.501838091254330E-02/
      DATA PD0/.100000000000000E+01/, PD1/.159751878026937E+01/,
     *     PD2/.104664867034140E+01/, PD3/.512560333664022E+00/,
     *     PD4/.159144727666995E+00/, PD5/.394456748956258E-01/,
     *     PD6/.529926873250079E-02/, PD7/.288921845412576E-03/
C-----------------------
      DATA QN0/.595123543430856E+00/, QN1/.652692120245803E+00/,
     *     QN2/.436851872835894E+00/, QN3/.201626141057807E+00/,
     *     QN4/.649535170626944E-01/, QN5/.171798867787816E-01/,
     *     QN6/.287998748038892E-02/, QN7/.359634362348937E-03/
      DATA QD0/.100000000000000E+01/, QD1/.114259871204893E+01/,
     *     QD2/.766390439057101E+00/, QD3/.348287281255683E+00/,
     *     QD4/.117049276946157E+00/, QD5/.294545450289541E-01/,
     *     QD6/.523951773968125E-02/, QD7/.622692248774973E-03/,
     *     QD8/.674811395957744E-06/
C-----------------------
      DATA RN0 / .568067636505865E+00/, RN1 / .462183136291541E-01/,
     *     RN2 / .268519638203645E+00/, RN3 / .199427104235673E-02/,
     *     RN4 / .135599161332010E-03/, RN5 / .229937707171804E-04/,
     *     RN6 / .697888081361175E-05/, RN7 / .153277172934286E-05/,
     *     RN8 /-.149322381877245E-05/, RN9 /-.113533571972859E-05/,
     *     RN10/ .740721412702102E-06/, RN11/-.120160431596119E-06/
      DATA RD0 / .100000000000000E+01/, RD1 / .741293424676788E-01/,
     *     RD2 / .471695968238457E+00/
C-----------------------
      DATA SN0 /.564189583547757E+00/, SN1 / .112605519585866E+00/,
     *     SN2 /.893329124921909E-03/, SN3 / .532139134120350E-04/,
     *     SN4 /.592725458717738E-05/, SN5 / .921448923850546E-06/,
     *     SN6 /.404558310611815E-06/, SN7 /-.660517686759109E-06/,
     *     SN8 /.174667472383815E-05/, SN9 /-.287037710548882E-05/,
     *     SN10/.322304072982791E-05/, SN11/-.231569499551950E-05/,
     *     SN12/.963478964685941E-06/, SN13/-.173784488565533E-06/
      DATA SD0 /.100000000000000E+01/, SD1 / .193077670156841E+00/
C-----------------------------------------------------------------------
      IF (X .GE. -1.0) GO TO 10
      CALL AIMP (-X, R, PHI)
      BIE = R*COS(PHI)
      RETURN
C
   10 IF (X .GE. 0.0) GO TO 20
      BIE = ((((((((((AN10*X + AN9)*X + AN8)*X + AN7)*X
     *              + AN6)*X + AN5)*X + AN4)*X + AN3)*X
     *              + AN2)*X + AN1)*X + AN0) /
     *              (((AD3*X + AD2)*X + AD1)*X + AD0)
      RETURN
C
   20 IF (X .GT. 1.0) GO TO 30
      BIE = ((((((((((BN10*X + BN9)*X + BN8)*X + BN7)*X
     *              + BN6)*X + BN5)*X + BN4)*X + BN3)*X
     *              + BN2)*X + BN1)*X + BN0) /
     *              (((BD3*X + BD2)*X + BD1)*X + BD0)
      IF (X .GT. 1.E-20) BIE = BIE * EXP(-2.0*X*SQRT(X)/3.0)
      RETURN
C
   30 RTX = SQRT(X)
      IF (X .GT. 2.0) GO TO 40
      T = X - 1.0
      W = ((((((PN6*T + PN5)*T + PN4)*T + PN3)*T + PN2)*T
     *                + PN1)*T + PN0) /
     *    (((((((PD7*T + PD6)*T + PD5)*T + PD4)*T + PD3)*T
     *                 + PD2)*T + PD1)*T + PD0)
      BIE = W/SQRT(RTX)
      RETURN
C
   40 IF (X .GT. 4.0) GO TO 50
      T = X - 2.0
      W = (((((((QN7*T + QN6)*T + QN5)*T + QN4)*T + QN3)*T
     *                 + QN2)*T + QN1)*T + QN0) /
     *    ((((((((QD8*T + QD7)*T + QD6)*T + QD5)*T + QD4)*T
     *                  + QD3)*T + QD2)*T + QD1)*T + QD0)
      BIE = W/SQRT(RTX)
      RETURN
C
   50 IF (X .GT. X0) GO TO 60
      T = 16.0/(X*RTX) - 1.0
      W = (((((((((((RN11*T + RN10)*T + RN9)*T + RN8)*T
     *     + RN7)*T + RN6)*T + RN5)*T + RN4)*T + RN3)*T
     *     + RN2)*T + RN1)*T + RN0) /
     *      ((RD2*T + RD1)*T + RD0)
      BIE = W/SQRT(RTX)
      RETURN
C
   60 IF (X .GT. 1.E20) GO TO 70
      T = 16.0/(X*RTX)
      W = (((((((((((((SN13*T + SN12)*T + SN11)*T + SN10)*T
     *         + SN9)*T + SN8)*T + SN7)*T + SN6)*T + SN5)*T
     *         + SN4)*T + SN3)*T + SN2)*T + SN1)*T + SN0) /
     *           (SD1*T + SD0)
      BIE = W/SQRT(RTX)
      RETURN
C
   70 BIE = SN0/SQRT(RTX)
      RETURN
      END
      SUBROUTINE AIMP (X, R, PHI)
C-----------------------------------------------------------------------
C     COMPUTATION OF THE AIRY MODULUS AND PHASE FOR X .GE. 1
C-----------------------------------------------------------------------
      DATA PI4 /.785398163397448/
C-----------------------
      DATA AN0/.297640916735064E+00/, AN1/.772796814419809E+00/,
     *     AN2/.764990563560236E+00/, AN3/.375694096095838E+00/,
     *     AN4/.978661044870204E-01/, AN5/.110446639522696E-01/,
     *     AN6/.145271249611697E-05/
      DATA AD0/.100000000000000E+01/, AD1/.247380029946443E+01/,
     *     AD2/.240125897828762E+01/, AD3/.118267264172257E+01/,
     *     AD4/.306942883081787E+00/, AD5/.347670057203535E-01/
C-----------------------
      DATA BN0/.593601051670149E+00/, BN1/.223281495955754E+01/,
     *     BN2/.317718143418600E+01/, BN3/.229890914530923E+01/,
     *     BN4/.933580623665765E+00/, BN5/.209164380960390E+00/,
     *     BN6/.207910965366403E-01/
      DATA BD0/.100000000000000E+01/, BD1/.345985556561483E+01/,
     *     BD2/.479629661187354E+01/, BD3/.345429311552596E+01/,
     *     BD4/.140017214942186E+01/, BD5/.313770549939860E+00/,
     *     BD6/.311852186700025E-01/
C-----------------------
      DATA CN0/.313541841678871E+00/, CN1/.470104287134296E+00/,
     *     CN2/.291795874641314E+00/, CN3/.962250689852768E-01/,
     *     CN4/.171024484244850E-01/, CN5/.134933201907052E-02/
      DATA CD0/.100000000000000E+01/, CD1/.148070947673639E+01/,
     *     CD2/.917484386216329E+00/, CD3/.302281922152536E+00/,
     *     CD4/.537309296828367E-01/, CD5/.423890576557513E-02/,
     *     CD6/.525954318463502E-08/
C-----------------------
      DATA DN0/.654836896032068E+00/, DN1/.117099614856528E+01/,
     *     DN2/.831899010444840E+00/, DN3/.301060337976575E+00/,
     *     DN4/.564712748150658E-01/, DN5/.444134415666317E-02/
      DATA DD0/.100000000000000E+01/, DD1/.176306543768126E+01/,
     *     DD2/.124897609613487E+01/, DD3/.451576491257036E+00/,
     *     DD4/.847085955634988E-01/, DD5/.666188176245820E-02/,
     *     DD6/.537600060708764E-08/
C-----------------------
      DATA PN0/.318309886183791E+00/, PN1/.100996327221962E+01/,
     *     PN2/.902315148591491E+00/, PN3/.259820640977615E+00/,
     *     PN4/.203717769716282E-01/, PN5/.216893438784765E-03/
      DATA PD0/.100000000000000E+01/, PD1/.317533460265059E+01/,
     *     PD2/.284232123705698E+01/, PD3/.822777439238360E+00/,
     *     PD4/.656865942543526E-01/, PD5/.775376048996392E-03/
C-----------------------
      DATA QN0/.666666666666667E+00/, QN1/.141905542385598E+01/,
     *     QN2/.772778148352443E+00/, QN3/.115170415082442E+00/,
     *     QN4/.326457319318373E-02/
      DATA QD0/.100000000000000E+01/, QD1/.213102454203392E+01/,
     *     QD2/.116432601041188E+01/, QD3/.175509465791633E+00/,
     *     QD4/.528319849831061E-02/, QD5/.867802002275824E-05/
C-----------------------------------------------------------------------
      IF (X .GT. 2.0) GO TO 10
      Z = X - 1.0
      R =   ((((((AN6*Z + AN5)*Z + AN4)*Z + AN3)*Z + AN2)*Z
     *                  + AN1)*Z + AN0) /
     *      (((((AD5*Z + AD4)*Z + AD3)*Z + AD2)*Z + AD1)*Z + AD0)
      PHI = ((((((BN6*Z + BN5)*Z + BN4)*Z + BN3)*Z + BN2)*Z
     *                  + BN1)*Z + BN0) /
     *      ((((((BD6*Z + BD5)*Z + BD4)*Z + BD3)*Z + BD2)*Z
     *                  + BD1)*Z + BD0)
      GO TO 40
C
   10 IF (X .GE. 4.0) GO TO 20
      Z = X - 2.0
      R =   (((((CN5*Z + CN4)*Z + CN3)*Z + CN2)*Z + CN1)*Z + CN0) /
     *      ((((((CD6*Z + CD5)*Z + CD4)*Z + CD3)*Z + CD2)*Z
     *                  + CD1)*Z + CD0)
      PHI = (((((DN5*Z + DN4)*Z + DN3)*Z + DN2)*Z + DN1)*Z + DN0) /
     *      ((((((DD6*Z + DD5)*Z + DD4)*Z + DD3)*Z + DD2)*Z
     *                  + DD1)*Z + DD0)
      GO TO 40
C
   20 IF (X .GT. 1.E10) GO TO 30
      Z = 64.0/X**3
      R =   (((((PN5*Z + PN4)*Z + PN3)*Z + PN2)*Z + PN1)*Z + PN0) /
     *      (((((PD5*Z + PD4)*Z + PD3)*Z + PD2)*Z + PD1)*Z + PD0)
      PHI = ((((QN4*Z + QN3)*Z + QN2)*Z + QN1)*Z + QN0) /
     *      (((((QD5*Z + QD4)*Z + QD3)*Z + QD2)*Z + QD1)*Z + QD0)
      GO TO 40
C
   30 R = PN0
      PHI = QN0
C
 40   RTX = SQRT(X)
      R = SQRT(R/RTX)
      PHI = PI4 + X*RTX*PHI
      RETURN
      END
      COMPLEX FUNCTION CK(K,L)
C     ------------------------------------------------------------------
C     THIS FUNCTION CALCULATES THE COMPLETE ELLIPTIC INTEGRAL F(K)
C     FOR COMPLEX VALUES OF THE MODULUS K. IT IS ASSUMED THAT L.NE.0
C     AND THAT K**2 + L**2 = 1.
C     ------------------------------------------------------------------
      COMPLEX K,L,AK,AL,AK1,AL1,AL2,CKK,CKP,F1,F2,F3,FXK,AKTEMP,CK1,J
      COMPLEX CFLECT,KM,Z
      REAL LN4,X1(12),X2(12),W1(12),W2(12),FL(12),FA(12),FB(12)
      LOGICAL BRANCH
C     --------------------------------------------------------------
      DATA X1(1)/ 6.5487222790801E-03/, X1(2)/ 3.8946809560450E-02/,
     1     X1(3)/ 9.8150263106007E-02/, X1(4)/ 1.8113858159063E-01/,
     2     X1(5)/ 2.8322006766737E-01/, X1(6)/ 3.9843443516344E-01/,
     3     X1(7)/ 5.1995262679235E-01/, X1(8)/ 6.4051091671611E-01/,
     4     X1(9)/ 7.5286501205183E-01/, X1(10)/8.5024002416230E-01/,
     5     X1(11)/9.2674968322391E-01/, X1(12)/9.7775612969000E-01/
C     --------------------------------------------------------------
      DATA W1(1)/ 9.3192691443932E-02/, W1(2)/ 1.4975182757632E-01/,
     1     W1(3)/ 1.6655745436459E-01/, W1(4)/ 1.5963355943699E-01/,
     2     W1(5)/ 1.3842483186484E-01/, W1(6)/ 1.1001657063572E-01/,
     3     W1(7)/ 7.9961821770829E-02/, W1(8)/ 5.2406954824642E-02/,
     4     W1(9)/ 3.0071088873761E-02/, W1(10)/1.4249245587998E-02/,
     5     W1(11)/4.8999245823217E-03/, W1(12)/8.3402903805690E-04/
C     --------------------------------------------------------------
      DATA FL(1)/ 1.5708005371203E+00/, FL(2)/ 1.5709452753591E+00/,
     1     FL(3)/ 1.5717433742881E+00/, FL(4)/ 1.5740325056162E+00/,
     2     FL(5)/ 1.5787613653341E+00/, FL(6)/ 1.5867393901613E+00/,
     3     FL(7)/ 1.5983969635617E+00/, FL(8)/ 1.6135762587884E+00/,
     4     FL(9)/ 1.6313677113831E+00/, FL(10)/1.6500349733510E+00/,
     5     FL(11)/1.6671202200919E+00/, FL(12)/1.6798403417359E+00/
C     --------------------------------------------------------------
      DATA X2(1)/-9.8156063424672E-01/, X2(2)/-9.0411725637048E-01/,
     1     X2(3)/-7.6990267419431E-01/, X2(4)/-5.8731795428662E-01/,
     2     X2(5)/-3.6783149899818E-01/, X2(6)/-1.2523340851147E-01/,
     3     X2(7)/ 1.2523340851147E-01/, X2(8)/ 3.6783149899818E-01/,
     4     X2(9)/ 5.8731795428662E-01/, X2(10)/7.6990267419431E-01/,
     5     X2(11)/9.0411725637048E-01/, X2(12)/9.8156063424672E-01/
C     --------------------------------------------------------------
      DATA W2(1)/ 4.7175336386512E-02/, W2(2)/ 1.0693932599532E-01/,
     1     W2(3)/ 1.6007832854335E-01/, W2(4)/ 2.0316742672307E-01/,
     2     W2(5)/ 2.3349253653836E-01/, W2(6)/ 2.4914704581340E-01/,
     3     W2(7)/ 2.4914704581340E-01/, W2(8)/ 2.3349253653836E-01/,
     4     W2(9)/ 2.0316742672307E-01/, W2(10)/1.6007832854335E-01/,
     5     W2(11)/1.0693932599532E-01/, W2(12)/4.7175336386512E-02/
C     --------------------------------------------------------------
      DATA FA(1)/ 2.0794472764428E+00/, FA(2)/ 2.0795966441739E+00/,
     1     FA(3)/ 2.0803359313463E+00/, FA(4)/ 2.0823286205438E+00/,
     2     FA(5)/ 2.0862633195105E+00/, FA(6)/ 2.0926508621232E+00/,
     3     FA(7)/ 2.1016440761258E+00/, FA(8)/ 2.1128974786197E+00/,
     4     FA(9)/ 2.1254857173540E+00/, FA(10)/2.1379218133017E+00/,
     5     FA(11)/2.1483404506064E+00/, FA(12)/2.1548934173960E+00/
C     --------------------------------------------------------------
      DATA FB(1)/ 1.5744273529551E+00/, FB(2)/ 1.5899097325063E+00/,
     1     FB(3)/ 1.6176685384410E+00/, FB(4)/ 1.6574605448620E+00/,
     2     FB(5)/ 1.7087245795822E+00/, FB(6)/ 1.7703459462057E+00/,
     3     FB(7)/ 1.8403280188791E+00/, FB(8)/ 1.9154060277115E+00/,
     4     FB(9)/ 1.9907093877047E+00/, FB(10)/2.0596975322636E+00/,
     5     FB(11)/2.1146977530430E+00/, FB(12)/2.1482986855683E+00/
C     --------------------------------------------------------------
      DATA J/(0.0, 1.0)/
      DATA LN4 /1.3862943611199/
      DATA C1  /.20264236728467/, C2/.15915494309189/
C     ---------------------------------------------------
C
C     EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE
C     SMALLEST NUMBER SUCH THAT 1. + EPS .GT. 1.
C
      EPS = SPMPAR(1)
C
C     ---------------------------------------------------
      IF (L .EQ. (0.0, 0.0)) GO TO 200
      IND = 0
      BRANCH = .TRUE.
      TOL = 8.0*AMAX1(EPS, 1.E-14)
C
      AK1 = CFLECT(K)
      AL1 = CFLECT(L)
      AK = AK1
      AL = AL1
C
      X = REAL(AK)
      Y = AIMAG(AK)
      U = REAL(AL)
      V = AIMAG(AL)
      IF (AMAX1(X,ABS(Y)) .GE. 1.0/EPS) GO TO 90
      IF (AMAX1(U,ABS(V)) .GE. 1.1/EPS) GO TO 200
C
C     CHECK THAT K**2 + L**2 = 1
C
      IF (X .LT. U) GO TO 1
         T = U/X
         IF (ABS(X*X/(V*V + 1.0/(1.0 + T*T)) - 1.0) .GT. TOL) GO TO 200
         IF (ABS(Y + T*V) .GT. TOL*AMAX1(1.0, ABS(V))) GO TO 200
         GO TO 10
    1 T = X/U
      IF (ABS(U*U/(Y*Y + 1.0/(1.0 + T*T)) - 1.0) .GT. TOL) GO TO 200
      IF (ABS(V + T*Y) .GT. TOL*AMAX1(1.0, ABS(Y))) GO TO 200
C
C     USES  LOGARITHMIC SERIES WHEN CABS(AL)
C     IS LESS THAN OR EQUAL TO 0.55
C
   10 IF (U .GT. 1.42 .OR. ABS(V) .GT. 1.42) GO TO 50
   11 IF (CABS(AL) .GT. 0.55) GO TO 20
      CALL KL(AL,CKK,CKP)
      IF (BRANCH) GO TO 22
      CK1 = CKK
      CK = CKP
      AL = AK
      GO TO 80
C
C     USES MACLAURIN EXPANSION WHEN THE ABSOLUTE VALUE OF
C     THE MODULUS AK IS LESS THAN OR EQUAL TO 0.55
C
   20 R = CABS(AK)
      IF (R .GT. 0.55) GO TO 30
      IF (BRANCH) GO TO 21
      CALL KL(AK,CKP,CK1)
      CK = CKP
      AL = AK
      GO TO 80
   21 CKK = KM(AK*AK)
   22 CK = CKK
      GO TO 70
C
C     NUMERICAL QUADRATURE APPROXIMATION
C
   30 IF (IND .EQ. 0 .AND. R .GT. 1.0) GO TO 50
   31 AL2 = AL*AL
C
      F1 = (0.0, 0.0)
      DO 40 I = 1,12
         XX = X1(I)/2.
         FXK = AK*XX
   40    F1 = F1 + W1(I)*FL(I)/(AL2 + FXK*FXK)
      F2 = (0.0, 0.0)
      DO 41 I = 1,12
         XX = .25*(1.+ X2(I))
         FXK = AK*XX
   41    F2 = F2 + W2(I)*FA(I)/(AL2 + FXK*FXK)
      F3 = (0.0, 0.0)
      DO 42 I = 1,12
         XX = .25*(3.- X2(I))
         FXK = AK*XX
   42    F3 = F3 + W2(I)*FB(I)/(AL2 + FXK*FXK)
C
      CK = AL*(C1*F1 + C2*(F2 + F3))
C
C     END OF NUMERICAL QUADRATURE APPROXIMATION
C
      IF (BRANCH) GO TO 70
      CK1 = CK
      BRANCH = .TRUE.
C
C     INTERCHANGE AK AND AL
C
      AKTEMP = AK
      AK = AL
      AL = AKTEMP
      GO TO 31
C
C     USES INVERSE MODULUS TRANSFORMATION WHEN CABS(AK) IS GREATER
C     THAN 1 AND REAL(AK**2) IS GREATER THAN 0.5.
C
   50 IF (X*X .LE. Y*Y + 0.5) GO TO 60
      IND = 1
      BRANCH = .FALSE.
      AK = 1.0/AK1
      AL = CFLECT(J*AL1/AK1)
      GO TO 11
C
C     USES COMPLEMENTARY INVERSE MODULUS TRANSFORMATION WHEN CABS(AK)
C     IS GREATER THAN 1 AND REAL(AK**2) IS LESS THAN OR EQUAL TO 0.5
C
   60 IND = 2
      AK = CFLECT(J*AK1/AL1)
      AL = 1.0/AL1
      GO TO 11
C
C     RETURN IF NO TRANSFORMATIONS HAVE BEEN PERFORMED
C
   70 IF (IND .EQ. 0) RETURN
      IF (IND .EQ. 1) GO TO 80
C
C     COMPLEMENTARY INVERSE MODULUS TRANSFORMATION
C
      CK = AL*CK
      RETURN
C
C     INVERSE MODULUS TRANSFORMATION
C
   80 IF (AIMAG(AK1) .GE. 0.0) GO TO 81
         CK = AL*(CK1 - J*CK)
         RETURN
   81 CK = AL*(CK1 + J*CK)
      RETURN
C
C     CALCULATION OF F(K) FOR LARGE K AND L
C
   90 IF (X .LE. ABS(Y)) GO TO 100
      IF (ABS(ABS(V/X) - 1.0) .GT. TOL) GO TO 200
      IF (ABS(U/X + Y/V) .GT. TOL) GO TO 200
      T = Y/X
      PHI = ATAN2(X,ABS(Y))
      R = (LN4 + 0.5*ALNREL(T*T)) + ALOG(X)
      IF (Y .LT. 0.0) R = -R
      CK = (CMPLX(PHI,R)/CMPLX(1.0,T))/X
      RETURN
C
  100 IF (ABS(ABS(U/Y) - 1.0) .GT. TOL) GO TO 200
      IF (ABS(X/U + V/Y) .GT. TOL) GO TO 200
      T = V/U
      Z = CMPLX((LN4 + 0.5*ALNREL(T*T)) + ALOG(U), ATAN2(V,U))
      CK = (Z/CMPLX(1.0,T))/U
      RETURN
C
C     ERROR RETURN
C
  200 CK = (0.0, 0.0)
      RETURN
      END
      COMPLEX FUNCTION CFLECT(Z)
C---------------------------------------------------------
C     REFLECTS Z WITH RESPECT TO THE ORIGIN IF REAL(Z)
C     .LT. 0.0 OR IF Z IS ON THE NEGATIVE IMAGINARY AXIS.
C---------------------------------------------------------
      COMPLEX Z
C     ----------
      IF (REAL(Z)) 10,20,30
   10 CFLECT = -Z
      RETURN
   20 CFLECT = CMPLX(0.0, ABS(AIMAG(Z)))
      RETURN
   30 CFLECT = Z
      RETURN
      END
      COMPLEX FUNCTION KM(K2)
      COMPLEX K2
C---------------------------------------------------------------------
C     KM COMPUTES THE COMPLETE ELLIPTIC INTEGRAL F(K) FOR A GIVEN
C     VALUE OF K2 = K**2 BY USE OF THE MACLAURIN EXPANSION.
C---------------------------------------------------------------------
      COMPLEX AN,S1
      DATA HPI /1.5707963267949/
C ---------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C ---------------
C
      TOL = AMAX1(EPS,1.E-14)
      S1 = (1.0, 0.0)
      AN = (1.0, 0.0)
      DO 10 I = 1,50
         RI = I
         C = ((RI - 0.5)/RI)**2
         AN = C*(AN*K2)
         S1 = S1 + AN
         IF (ABS(REAL(AN)) + ABS(AIMAG(AN)) .LT. TOL) GO TO 20
   10 CONTINUE
C
   20 KM = HPI*S1
      RETURN
      END
      SUBROUTINE KL (L, FK, FL)
      COMPLEX L, FK, FL
C ----------------------------------------------------------------------
C     KL COMPUTES THE COMPLETE ELLIPTIC INTEGRALS F(K) AND F(L) FOR
C     A GIVEN VALUE OF L, WHERE CABS(L) .LT. 1 AND K**2 + L**2 = 1.
C     IT IS ASSUMED THAT -PI .LE. ARG(L**2) .LT. PI FOR THE RESULTING
C     VALUE FOR F(K) TO BE MEANINGFUL.
C ----------------------------------------------------------------------
      COMPLEX AN,L2,S1,S2,W
      REAL LN4
C     --------------
      DATA HPI /1.5707963267949/
      DATA LN4 /1.3862943611199/
C ---------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C ---------------
C
C            THE LOGARITHMIC EXPANSION IS USED FOR F(K)
C              AND THE MACLAURIN EXPANSION FOR F(L)
C
      TOL = AMAX1(EPS,1.E-14)
      L2 = L*L
      S1 = (0.0, 0.0)
      S2 = (0.0, 0.0)
      AN = (1.0, 0.0)
      BN = 0.0
      DO 10 I = 1,50
         RI = I
         C = ((RI - 0.5)/RI)**2
         AN = C*(AN*L2)
         BN = BN + 1.0/(RI*(2.0*RI - 1.0))
         S1 = S1 + AN
         S2 = S2 + AN*BN
         IF (ABS(REAL(AN)) + ABS(AIMAG(AN)) .LT. TOL) GO TO 20
   10 CONTINUE
   20 S1 = S1 + (1.0, 0.0)
C
C                   SET W = 0.5*CLOG(16.0/L2)
C
      X = REAL(L)
      Y = AIMAG(L)
      IF (X .NE. 0.0) GO TO 30
         W = CMPLX(LN4 - ALOG(ABS(Y)), HPI)
         GO TO 50
C
   30 IF (ABS(X) .GT. ABS(Y)) GO TO 31
         U = (LN4 - 0.5*ALNREL((X/Y)**2)) - ALOG(ABS(Y))
         GO TO 40
   31 U = (LN4 - 0.5*ALNREL((Y/X)**2)) - ALOG(ABS(X))
C
   40 IF (X .GT. 0.0) GO TO 41
         W = CMPLX(U, -ATAN2(-Y,-X))
         GO TO 50
   41 W = CMPLX(U, -ATAN2(Y,X))
C
C                        FINAL ASSEMBLY
C
   50 FK = W*S1 - S2
      FL = HPI*S1
      RETURN
      END
      SUBROUTINE CKE(K,L,CK,CE,IERR)
C     ------------------------------------------------------------------
C     THIS FUNCTION CALCULATES THE COMPLETE ELLIPTIC INTEGRALS F(K)
C     AND E(K) FOR COMPLEX VALUES OF THE MODULUS K. IT IS ASSUMED
C     THAT L.NE.0 AND THAT K**2 + L**2 = 1.
C     ------------------------------------------------------------------
      COMPLEX K,L,AK,AL,AK1,AL1,CKK,CKP,F1,F2,F3,AKTEMP,CK1,J
      COMPLEX CE,CK,CEE,CEP,CE1,E1,E2,E3,AT,FX,FXK,ATN
      COMPLEX CFLECT,K1,L1,AK2,AL2,Z,G,G1,GG,GP
      REAL LN4,X1(12),X2(12),W1(12),W2(12),FL(12),FA(12),FB(12)
      LOGICAL BRANCH
C     --------------------------------------------------------------
      DATA X1(1)/ 6.5487222790801E-03/, X1(2)/ 3.8946809560450E-02/,
     1     X1(3)/ 9.8150263106007E-02/, X1(4)/ 1.8113858159063E-01/,
     2     X1(5)/ 2.8322006766737E-01/, X1(6)/ 3.9843443516344E-01/,
     3     X1(7)/ 5.1995262679235E-01/, X1(8)/ 6.4051091671611E-01/,
     4     X1(9)/ 7.5286501205183E-01/, X1(10)/8.5024002416230E-01/,
     5     X1(11)/9.2674968322391E-01/, X1(12)/9.7775612969000E-01/
C     --------------------------------------------------------------
      DATA W1(1)/ 9.3192691443932E-02/, W1(2)/ 1.4975182757632E-01/,
     1     W1(3)/ 1.6655745436459E-01/, W1(4)/ 1.5963355943699E-01/,
     2     W1(5)/ 1.3842483186484E-01/, W1(6)/ 1.1001657063572E-01/,
     3     W1(7)/ 7.9961821770829E-02/, W1(8)/ 5.2406954824642E-02/,
     4     W1(9)/ 3.0071088873761E-02/, W1(10)/1.4249245587998E-02/,
     5     W1(11)/4.8999245823217E-03/, W1(12)/8.3402903805690E-04/
C     --------------------------------------------------------------
      DATA FL(1)/ 1.5708005371203E+00/, FL(2)/ 1.5709452753591E+00/,
     1     FL(3)/ 1.5717433742881E+00/, FL(4)/ 1.5740325056162E+00/,
     2     FL(5)/ 1.5787613653341E+00/, FL(6)/ 1.5867393901613E+00/,
     3     FL(7)/ 1.5983969635617E+00/, FL(8)/ 1.6135762587884E+00/,
     4     FL(9)/ 1.6313677113831E+00/, FL(10)/1.6500349733510E+00/,
     5     FL(11)/1.6671202200919E+00/, FL(12)/1.6798403417359E+00/
C     --------------------------------------------------------------
      DATA X2(1)/-9.8156063424672E-01/, X2(2)/-9.0411725637048E-01/,
     1     X2(3)/-7.6990267419431E-01/, X2(4)/-5.8731795428662E-01/,
     2     X2(5)/-3.6783149899818E-01/, X2(6)/-1.2523340851147E-01/,
     3     X2(7)/ 1.2523340851147E-01/, X2(8)/ 3.6783149899818E-01/,
     4     X2(9)/ 5.8731795428662E-01/, X2(10)/7.6990267419431E-01/,
     5     X2(11)/9.0411725637048E-01/, X2(12)/9.8156063424672E-01/
C     --------------------------------------------------------------
      DATA W2(1)/ 4.7175336386512E-02/, W2(2)/ 1.0693932599532E-01/,
     1     W2(3)/ 1.6007832854335E-01/, W2(4)/ 2.0316742672307E-01/,
     2     W2(5)/ 2.3349253653836E-01/, W2(6)/ 2.4914704581340E-01/,
     3     W2(7)/ 2.4914704581340E-01/, W2(8)/ 2.3349253653836E-01/,
     4     W2(9)/ 2.0316742672307E-01/, W2(10)/1.6007832854335E-01/,
     5     W2(11)/1.0693932599532E-01/, W2(12)/4.7175336386512E-02/
C     --------------------------------------------------------------
      DATA FA(1)/ 2.0794472764428E+00/, FA(2)/ 2.0795966441739E+00/,
     1     FA(3)/ 2.0803359313463E+00/, FA(4)/ 2.0823286205438E+00/,
     2     FA(5)/ 2.0862633195105E+00/, FA(6)/ 2.0926508621232E+00/,
     3     FA(7)/ 2.1016440761258E+00/, FA(8)/ 2.1128974786197E+00/,
     4     FA(9)/ 2.1254857173540E+00/, FA(10)/2.1379218133017E+00/,
     5     FA(11)/2.1483404506064E+00/, FA(12)/2.1548934173960E+00/
C     --------------------------------------------------------------
      DATA FB(1)/ 1.5744273529551E+00/, FB(2)/ 1.5899097325063E+00/,
     1     FB(3)/ 1.6176685384410E+00/, FB(4)/ 1.6574605448620E+00/,
     2     FB(5)/ 1.7087245795822E+00/, FB(6)/ 1.7703459462057E+00/,
     3     FB(7)/ 1.8403280188791E+00/, FB(8)/ 1.9154060277115E+00/,
     4     FB(9)/ 1.9907093877047E+00/, FB(10)/2.0596975322636E+00/,
     5     FB(11)/2.1146977530430E+00/, FB(12)/2.1482986855683E+00/
C     --------------------------------------------------------------
      DATA J/(0.0, 1.0)/
      DATA LN4 /1.3862943611199/
      DATA C1  /.20264236728467/, C2/.15915494309189/
C     ---------------------------------------------------
C
C     EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE
C     SMALLEST NUMBER SUCH THAT 1. + EPS .GT. 1.
C
      EPS = SPMPAR(1)
C
C     ---------------------------------------------------
      IF (L .EQ. (0.0, 0.0)) GO TO 200
      IND = 0
      BRANCH = .TRUE.
      TOL = 8.0*AMAX1(EPS, 1.E-14)
C
      AK1 = CFLECT(K)
      AL1 = CFLECT(L)
      AK = AK1
      AL = AL1
      IERR = 0
C
      X = REAL(AK)
      Y = AIMAG(AK)
      U = REAL(AL)
      V = AIMAG(AL)
      IF (AMAX1(X,ABS(Y)) .GE. 1.0/EPS) GO TO 90
      IF (AMAX1(U,ABS(V)) .GE. 1.1/EPS) GO TO 210
C
C     CHECK THAT K**2 + L**2 = 1
C
      IF (X .LT. U) GO TO 1
         T = U/X
         IF (ABS(X*X/(V*V + 1.0/(1.0 + T*T)) - 1.0) .GT. TOL) GO TO 210
         IF (ABS(Y + T*V) .GT. TOL*AMAX1(1.0, ABS(V))) GO TO 210
         GO TO 10
    1 T = X/U
      IF (ABS(U*U/(Y*Y + 1.0/(1.0 + T*T)) - 1.0) .GT. TOL) GO TO 210
      IF (ABS(V + T*Y) .GT. TOL*AMAX1(1.0, ABS(Y))) GO TO 210
C
C     USES  LOGARITHMIC SERIES WHEN CABS(AL)
C     IS LESS THAN OR EQUAL TO 0.55
C
   10 IF (U .GT. 1.42 .OR. ABS(V) .GT. 1.42) GO TO 50
   11 IF (CABS(AL) .GT. 0.55) GO TO 20
      CALL EKL(AL,CKK,CKP,CEE,CEP,GG,GP)
      IF (BRANCH) GO TO 22
      CK1 = CKK
      CK = CKP
      CE1 = CEE
      CE = CEP
      G1 = GG
      G = GP
      AK2 = AL*AL
      AL = AK
      AL2 = AL*AL
      GO TO 81
C
C     USES MACLAURIN EXPANSION WHEN THE ABSOLUTE VALUE OF
C     THE MODULUS AK IS LESS THAN OR EQUAL TO 0.55
C
   20 R = CABS(AK)
      IF (R .GT. 0.55) GO TO 30
      IF (BRANCH) GO TO 21
      CALL EKL(AK,CKP,CK1,CEP,CE1,GP,G1)
      CK = CKP
      CE = CEP
      G = GP
      AK2 = AL*AL
      AL = AK
      AL2 = AL*AL
      GO TO 81
   21 CALL EKM(AK*AK,CKK,CEE)
   22 CK = CKK
      CE = CEE
      GO TO 70
C
C     NUMERICAL QUADRATURE APPROXIMATION
C
   30 IF (IND .EQ. 0 .AND. R .GT. 1.0) GO TO 50
   31 AL2 = AL*AL
      AK2 = AK*AK
C
      F1 = (0.0, 0.0)
      E1 = (0.0, 0.0)
      DO 40 I = 1,12
         XX = X1(I)/2.
         FX = AK*XX/AL
         FXK = AK*XX
         AT = ATN(FX)
         E1 = E1 + W1(I)*FL(I)*(1.0 + AT)
   40    F1 = F1 + W1(I)*FL(I)/(AL2 + FXK*FXK)
      F2 = (0.0, 0.0)
      E2 = (0.0, 0.0)
      DO 41 I = 1,12
         XX = .25*(1.+ X2(I))
         FX = AK*XX/AL
         FXK = AK*XX
         AT = ATN(FX)
         E2 = E2 + W2(I)*FA(I)*(1.0 + AT)
   41    F2 = F2 + W2(I)*FA(I)/(AL2 + FXK*FXK)
      F3 = (0.0, 0.0)
      E3 = (0.0, 0.0)
      DO 42 I = 1,12
         XX = .25*(3.- X2(I))
         FX = AK*XX/AL
         FXK = AK*XX
         AT = ATN(FX)
         E3 = E3 + W2(I)*FB(I)*(1.0 + AT)
   42    F3 = F3 + W2(I)*FB(I)/(AL2 + FXK*FXK)
C
      CK = AL*(C1*F1 + C2*(F2 + F3))
      CE = AL*(C1*E1 + C2*(E2 + E3))
C
C     END OF NUMERICAL QUADRATURE APPROXIMATION
C
      IF (BRANCH) GO TO 70
      CK1 = CK
      CE1 = CE
      BRANCH = .TRUE.
C
C     INTERCHANGE AK AND AL
C
      AKTEMP = AK
      AK = AL
      AL = AKTEMP
      GO TO 31
C
C     USES INVERSE MODULUS TRANSFORMATION WHEN CABS(AK) IS GREATER
C     THAN 1 AND REAL(AK**2) IS GREATER THAN 0.5.
C
   50 IF (X*X .LE. Y*Y + 0.5) GO TO 60
      IND = 1
      BRANCH = .FALSE.
      AK = 1.0/AK1
      AL = CFLECT(J*AL1/AK1)
      GO TO 11
C
C     USES COMPLEMENTARY INVERSE MODULUS TRANSFORMATION WHEN CABS(AK)
C     IS GREATER THAN 1 AND REAL(AK**2) IS LESS THAN OR EQUAL TO 0.5
C
   60 IND = 2
      AK = CFLECT(J*AK1/AL1)
      AL = 1.0/AL1
      GO TO 11
C
C     RETURN IF NO TRANSFORMATIONS HAVE BEEN PERFORMED
C
   70 IF (IND .EQ. 0) RETURN
      IF (IND .EQ. 1) GO TO 80
C
C     COMPLEMENTARY INVERSE MODULUS TRANSFORMATION
C
      CK = AL*CK
      CE = CE/AL
      RETURN
C
C     INVERSE MODULUS TRANSFORMATION
C
   80 G = CE - AL2*CK
      G1 = CE1 - AK2*CK1
   81 IF (AIMAG(AK2) .GE. 0.0) GO TO 82
         CE = (G1 + J*G)/AL
         CK = AL*(CK1 - J*CK)
         RETURN
   82 CE = (G1 - J*G)/AL
      CK = AL*(CK1 + J*CK)
      RETURN
C
C     CALCULATION OF F(K) AND E(K) FOR LARGE K AND L
C
   90 IF (X .LE. ABS(Y)) GO TO 100
      IF (ABS(ABS(V/X) - 1.0) .GT. TOL) GO TO 210
      IF (ABS(U/X + Y/V) .GT. TOL) GO TO 210
      T = Y/X
      K1 = CMPLX(1.0,T)
      PHI = ATAN2(X,ABS(Y))
      R = (LN4 + 0.5*ALNREL(T*T)) + ALOG(X)
      C = 0.5*R + 0.25
      Z = CMPLX(Y,-X)
      IF (Y .GE. 0.0) GO TO 91
         R = -R
         C = -C
         Z = -Z
   91 CK = (CMPLX(PHI,R)/K1)/X
      CE = Z + (CMPLX(0.5*PHI,C)/K1)/X
      RETURN
C
  100 IF (ABS(ABS(U/Y) - 1.0) .GT. TOL) GO TO 210
      IF (ABS(X/U + V/Y) .GT. TOL) GO TO 210
      T = V/U
      L1 = CMPLX(1.0,T)
      R = (LN4 + 0.5*ALNREL(T*T)) + ALOG(U)
      PHI = ATAN2(V,U)
      CK = (CMPLX(R, PHI)/L1)/U
      CE = AL + (CMPLX(0.5*R - 0.25, 0.5*PHI)/L1)/U
      RETURN
C
C     ERROR RETURN
C
  200 IERR = 1
      RETURN
  210 IERR = 2
      RETURN
      END
      COMPLEX FUNCTION ATN(Z)
C---------------------------------------------------
C     CALCULATES COMPLEX FUNCTION ATN(Z) = Z*ATAN(Z)
C     USING DOUBLE PRECISION.
C---------------------------------------------------
      COMPLEX Z
      DOUBLE PRECISION DX, DY
      X = REAL(Z)
      Y = AIMAG(Z)
      DX = X
      DY = Y
      T = 1.D0 - DX*DX - DY*DY
      DA = -0.5*ATAN2(-2.0*X, T)
      D = (1.0 - DY)**2 + DX*DX
      DB = 0.25*ALNREL(4.0*Y/D)
      ATN1 = DA*X - DB*Y
      ATN2 = DA*Y + DB*X
      ATN = CMPLX(ATN1, ATN2)
      RETURN
      END
      SUBROUTINE EKM (K2, FK, EK)
      COMPLEX K2,FK,EK
C ----------------------------------------------------------------------
C     EKM COMPUTES THE COMPLETE ELLIPTIC INTEGRALS F(K) AND E(K) FOR
C     A GIVEN VALUE OF K2 = K**2 BY USE OF THE MACLAURIN EXPANSIONS.
C ----------------------------------------------------------------------
      COMPLEX AN,CN,S1,S2
      DATA HPI /1.5707963267949/
C ---------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C ---------------
C
      TOL = AMAX1(EPS,1.E-14)
      S1 = (1.0, 0.0)
      S2 = (1.0, 0.0)
      AN = (1.0, 0.0)
      DO 10 I = 1,50
         RI = I
         C = ((RI - 0.5)/RI)**2
         AN = C*(AN*K2)
         CN = AN/(2.0*RI - 1.0)
         S1 = S1 + AN
         S2 = S2 - CN
         IF (ABS(REAL(AN)) + ABS(AIMAG(AN)) .LT. TOL) GO TO 20
   10 CONTINUE
C
   20 FK = HPI*S1
      EK = HPI*S2
      RETURN
      END
      SUBROUTINE EKL (L,FK,FL,EK,EL,GK,GL)
      COMPLEX L,L2,FK,FL,EK,EL,GK,GL
C ----------------------------------------------------------------------
C     EKL COMPUTES THE COMPLETE ELLIPTIC INTEGRALS F(K), F(L), E(K),
C     E(L) FOR A GIVEN VALUE OF L2, WHERE L2 = L**2 AND K**2 + L**2 = 1.
C     IT IS ASSUMED THAT -PI .LT. ARG(L2) .LE. PI FOR THE RESULTING
C     VALUE FOR F(K) TO BE MEANINGFUL.  THE COMBINATIONS OF FUNCTIONS
C     G(K) = E(K) - L**2*F(K) AND G(L) = E(L) - K**2*F(L) ARE ALSO
C     CALCULATED.
C ----------------------------------------------------------------------
      COMPLEX AN,CN,EN,S1,S2,S3,S4,S5,S6,S7,W
      REAL LN4
C     ------------------
      DATA HPI /1.5707963267949/
      DATA LN4 /1.3862943611199/
C ---------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C ---------------
C
C            THE LOGARITHMIC EXPANSIONS ARE USED FOR F(K) AND E(K)
C            AND THE MACLAURIN EXPANSIONS FOR F(L) AND E(L)
C
      TOL = AMAX1(EPS,1.E-14)
      L2 = L*L
      S1 = (0.0, 0.0)
      S2 = (0.0, 0.0)
      S3 = (0.0, 0.0)
      S4 = (0.0, 0.0)
      S5 = (0.0, 0.0)
      S6 = (0.0, 0.0)
      S7 = (0.0, 0.0)
      AN = (1.0, 0.0)
      BN = 0.0
      DO 10 I = 1,300
         RI = I
         C = ((RI - 0.5)/RI)**2
         AN = C*(AN*L2)
         BN = BN + 1.0/(RI*(2.0*RI - 1.0))
         CN = AN/(2.0*RI - 1.0)
         DN = BN*RI/(RI - 0.5)
         EN = CN/(2.0*RI - 1.0)
         FN = RI/(RI - 0.5)
         GN = 0.5/(RI + 1.0)
         S1 = S1 + AN
         S2 = S2 + AN*BN
         S3 = S3 - CN
         S4 = S4 + AN*DN
         S5 = S5 + EN
         S6 = S6 + AN*FN
         S7 = S7 + AN*GN
         IF (ABS(REAL(AN)) + ABS(AIMAG(AN)) .LT. TOL) GO TO 20
   10 CONTINUE
   20 S1 = S1 + (1.0, 0.0)
      S3 = S3 + (1.0, 0.0)
      S5 = S5 + (1.0, 0.0)
      S7 = S7 + (0.5, 0.0)
C
C              SET W = 0.5*CLOG(16.0/L2)
C
      X = REAL(L)
      Y = AIMAG(L)
      IF (X .NE. 0.0) GO TO 30
         W = CMPLX(LN4 - ALOG(ABS(Y)), HPI)
         GO TO 50
C
   30 IF (ABS(X) .GT. ABS(Y)) GO TO 31
         U = (LN4 - 0.5*ALNREL((X/Y)**2)) - ALOG(ABS(Y))
         GO TO 40
   31 U = (LN4 - 0.5*ALNREL((Y/X)**2)) - ALOG(ABS(X))
C
   40 IF (X .GT. 0.0) GO TO 41
         W = CMPLX(U, -ATAN2(-Y,-X))
         GO TO 50
   41 W = CMPLX(U, -ATAN2(Y,X))
C
C              FINAL ASSEMBLY
C
   50 FK = W*S1 - S2
      FL = HPI*S1
      EK = W*S6 - S4 + S5
      EL = HPI*S3
      GK = -W*S7*L2 -S4 + S5 + S2*L2
      GL = HPI*S7*L2
      RETURN
      END
      SUBROUTINE ELLPI (PHI, CPHI, K, L, F, E, IERR)
C-----------------------------------------------------------------------
C
C          REAL ELLIPTIC INTEGRALS OF THE FIRST AND SECOND KINDS
C
C                        -----------------
C
C     PHI = ARGUMENT                    (0.0 .LE. PHI  .LE. PI/2)
C     CPHI = PI/2 - PHI                 (0.0 .LE. CPHI .LE. PI/2)
C     K = MODULUS                       (ABS(K) .LE. 1.0)
C     L = COMODULUS = SQRT (1 - K*K)    (ABS(L) .LE. 1.0)
C     F = ELLIPTIC INTEGRAL OF FIRST KIND = F(PHI, K)
C     E = ELLIPTIC INTEGRAL OF SECOND KIND = E(PHI, K)
C     IERR = ERROR INDICATOR (IERR = 0  IF NO ERRORS)
C-----------------------------------------------------------------------
      REAL K, L, K2, L2, LN4
C------------------------
C     LN4 = LN(4)
C     TH1 = TANH(1)
C------------------------
      DATA LN4/1.3862943611199/
      DATA TH1/.76159415595576/
C------------------------
      IF (PHI .LT. 0.0 .OR. CPHI .LT. 0.0) GO TO 100
      IF (ABS(K) .GT. 1.0 .OR. ABS(L) .GT. 1.0) GO TO 110
      IERR = 0
      IF (PHI .NE. 0.0) GO TO 10
         F = 0.0
         E = 0.0
         RETURN
C
   10 IF (PHI .LT. 0.79) GO TO 11
         SN = COS(CPHI)
         CN = SIN(CPHI)
         GO TO 20
   11 SN = SIN(PHI)
      CN = COS(PHI)
C
   20 K2 = K*K
      L2 = L*L
      SS = SN*SN
      PX = ABS(K*SN)
      QX = ABS(K*CN)
      IF (PX .GE. TH1) GO TO 50
C
C     SERIES EXPANSION FOR ABS(K*SIN(PHI)) .LE. TANH(1)
C
      PN = 1.0
      QN = 2.0
      AN = PHI
      HN = 1.0
      S1 = 0.0
      S2 = 0.0
      TR = PHI*SS
      TS = SN*CN
C
   30 AN = (PN*AN - TS)/QN
      R  = K2*HN/QN
      S2 = S2 + R*AN
      HN = PN*R
      S0 = S1
      S1 = S1 + HN*AN
      IF (ABS(TR) .LT. ABS(AN)) GO TO 40
      IF (ABS(S1) .LE. ABS(S0)) GO TO 40
      PN = QN + 1.0
      QN = PN + 1.0
      TR = SS*TR
      TS = SS*TS
      GO TO 30
C
   40 F = PHI + S1
      E = PHI - S2
      RETURN
C
C     SERIES EXPANSION FOR ABS(K*SIN(PHI)) .GT. TANH(1)
C
   50 R = CPABS(L,QX)
      IF (R .EQ. 0.0) GO TO 120
      R2 = R*R
      SI = 1.0
      SJ = 1.0
      SK = 0.0
      RM = 0.0
      RN = 0.0
      S1 = 0.0
      S2 = 0.0
      S3 = 0.0
      S4 = 0.0
      TD = QX*R
      DN = 2.0
      GO TO 70
C
   60 SI = RI
      SJ = RJ
      SK = RK
      DN = DN + 2.0
      TD = R2*TD
   70 PN = (DN - 1.0)/DN
      QN = (DN + 1.0)/(DN + 2.0)
      RI = PN*SI
      RJ = PN*PN*L2*SJ
      RK = SK + 2.0/(DN*(DN - 1.0))
      R0 = TD/DN
      RM = QN*QN*L2*(RM - R0*RI)
      RN = PN*QN*L2*(RN - R0*SI)
      D1 = RJ
      D2 = QN*RJ
      D3 = RM - RJ*RK
      D4 = RN - PN*L2*SJ*RK + L2*SJ/(DN*DN)
      R0 = S3
      S1 = S1 + D1
      S2 = S2 + D2
      S3 = S3 + D3
      S4 = S4 + D4
      IF (S3 .LT. R0) GO TO 60
C
      W = 1.0 + PX
      P = LN4 - ALOG(R + QX)
      T1 = (1.0 + S1)*P + QX/R*ALNREL(-0.5*R2/W)
      T2 = (0.5 + S2)*L2*P + (1.0 - QX*R/W)
      F = T1 + S3
      E = T2 + S4
      RETURN
C
C     ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
      END
      SUBROUTINE DELLPI (PHI, CPHI, K, L, F, E, IERR)
C-----------------------------------------------------------------------
C
C                  DOUBLE PRECISION COMPUTATION OF THE
C          REAL ELLIPTIC INTEGRALS OF THE FIRST AND SECOND KINDS
C
C                        -----------------
C
C     PHI = ARGUMENT                    (0.0 .LE. PHI  .LE. PI/2)
C     CPHI = PI/2 - PHI                 (0.0 .LE. CPHI .LE. PI/2)
C     K = MODULUS                       (DABS(K) .LE. 1.0)
C     L = COMODULUS = SQRT (1 - K*K)    (DABS(L) .LE. 1.0)
C     F = ELLIPTIC INTEGRAL OF FIRST KIND = F(PHI, K)
C     E = ELLIPTIC INTEGRAL OF SECOND KIND = E(PHI, K)
C     IERR = ERROR INDICATOR (IERR = 0  IF NO ERRORS)
C-----------------------------------------------------------------------
      DOUBLE PRECISION PHI, CPHI, K, L, F, E
      DOUBLE PRECISION AN, CN, DN, D1, D2, D3, D4, HN, K2, L2, LN4,
     *                 P, PN, PX, QN, QX, R, RI, RJ, RK, RM, RN, R0,
     *                 R2, SI, SJ, SK, SN, SS, S0, S1, S2, S3, S4,
     *                 TD, TH1, TR, TS, T1, T2, W
      DOUBLE PRECISION DLNREL, DCPABS
C------------------------
C     LN4 = LN(4)
C     TH1 = TANH(1)
C------------------------
      DATA LN4 /.1386294361119890618834464242916353136151D+01/
      DATA TH1 /.7615941559557648881194582826047935904128D+00/
C------------------------
      IF (PHI .LT. 0.D0 .OR. CPHI .LT. 0.D0) GO TO 100
      IF (DABS(K) .GT. 1.D0 .OR. DABS(L) .GT. 1.D0) GO TO 110
      IERR = 0
      IF (PHI .NE. 0.D0) GO TO 10
         F = 0.D0
         E = 0.D0
         RETURN
C
   10 IF (PHI .LT. 0.79D0) GO TO 11
         SN = DCOS(CPHI)
         CN = DSIN(CPHI)
         GO TO 20
   11 SN = DSIN(PHI)
      CN = DCOS(PHI)
C
   20 K2 = K*K
      L2 = L*L
      SS = SN*SN
      PX = DABS(K*SN)
      QX = DABS(K*CN)
      IF (PX .GE. TH1) GO TO 50
C
C     SERIES EXPANSION FOR ABS(K*SIN(PHI)) .LE. TANH(1)
C
      PN = 1.D0
      QN = 2.D0
      AN = PHI
      HN = 1.D0
      S1 = 0.D0
      S2 = 0.D0
      TR = PHI*SS
      TS = SN*CN
C
   30 AN = (PN*AN - TS)/QN
      R  = K2*HN/QN
      S2 = S2 + R*AN
      HN = PN*R
      S0 = S1
      S1 = S1 + HN*AN
      IF (DABS(TR) .LT. DABS(AN)) GO TO 40
      IF (DABS(S1) .LE. DABS(S0)) GO TO 40
      PN = QN + 1.D0
      QN = PN + 1.D0
      TR = SS*TR
      TS = SS*TS
      GO TO 30
C
   40 F = PHI + S1
      E = PHI - S2
      RETURN
C
C     SERIES EXPANSION FOR ABS(K*SIN(PHI)) .GT. TANH(1)
C
   50 R = DCPABS(L,QX)
      IF (R .EQ. 0.D0) GO TO 120
      R2 = R*R
      SI = 1.D0
      SJ = 1.D0
      SK = 0.D0
      RM = 0.D0
      RN = 0.D0
      S1 = 0.D0
      S2 = 0.D0
      S3 = 0.D0
      S4 = 0.D0
      TD = QX*R
      DN = 2.D0
      GO TO 70
C
   60 SI = RI
      SJ = RJ
      SK = RK
      DN = DN + 2.D0
      TD = R2*TD
   70 PN = (DN - 1.D0)/DN
      QN = (DN + 1.D0)/(DN + 2.D0)
      RI = PN*SI
      RJ = PN*PN*L2*SJ
      RK = SK + 2.D0/(DN*(DN - 1.D0))
      R0 = TD/DN
      RM = QN*QN*L2*(RM - R0*RI)
      RN = PN*QN*L2*(RN - R0*SI)
      D1 = RJ
      D2 = QN*RJ
      D3 = RM - RJ*RK
      D4 = RN - PN*L2*SJ*RK + L2*SJ/(DN*DN)
      R0 = S3
      S1 = S1 + D1
      S2 = S2 + D2
      S3 = S3 + D3
      S4 = S4 + D4
      IF (S3 .LT. R0) GO TO 60
C
      W = 1.D0 + PX
      P = LN4 - DLOG(R + QX)
      T1 = (1.D0 + S1)*P + QX/R*DLNREL(-0.5D0*R2/W)
      T2 = (0.5D0 + S2)*L2*P + (1.D0 - QX*R/W)
      F = T1 + S3
      E = T2 + S4
      RETURN
C
C     ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
      END
      SUBROUTINE EPI (PHI, CPHI, K2, L2, N, M, P, IERR)
C-----------------------------------------------------------------------
C             REAL ELLIPTIC INTEGRAL OF THE THIRD KIND
C-----------------------------------------------------------------------
      REAL PHI, CPHI, K2, L2, N, M, P
      REAL A, B, C, EPS, PIHALF, R, RF, S, S2, TOL
      REAL SPMPAR
C---------------------
      DATA PIHALF /1.5707963267948966192/
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0.
C
                      EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      TOL = 4.0 * EPS
      IF (AMIN1(PHI,CPHI) .LT. 0.0) GO TO 100
      IF (ABS((PHI + CPHI) - PIHALF) .GT. TOL * PIHALF) GO TO 100
      IF (ABS(N) .GT. 1.0) GO TO 110
      IF (K2 .LT. 0.0 .OR. L2 .LT. 0.0) GO TO 120
      IF (ABS((K2 + L2) - 1.0) .GT. TOL) GO TO 120
C
      IF (PHI .LT. 0.79) GO TO 10
          S = COS(CPHI)
          C = SIN(CPHI)
          GO TO 11
   10 S = SIN(PHI)
      C = COS(PHI)
   11 A = C*C
      B = L2 + K2*A
      S2 = S*S
C
      IF (N .GT. 0.0) GO TO 20
          R = 1.0 - N*S2
          GO TO 30
   20 IF (M .LT. 0.0 .OR. M .GT. 1.0) GO TO 110
      IF (ABS((M + N) - 1.0) .GT. TOL) GO TO 110
      R = M + N*A
C
   30 CALL RJVAL (A, B, 1.0, R, P, IERR)
      IF (IERR .NE. 0) GO TO 130
      P = P * (S * S2) * N/3.0
      CALL RFVAL (A, B, 1.0, RF, IERR)
      P = P + S * RF
      RETURN
C
C     ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE DEPI (PHI, CPHI, K2, L2, N, M, P, IERR)
C-----------------------------------------------------------------------
C               DOUBLE PRECISION COMPUTATION OF THE
C             REAL ELLIPTIC INTEGRAL OF THE THIRD KIND
C-----------------------------------------------------------------------
      DOUBLE PRECISION PHI, CPHI, K2, L2, N, M, P
      DOUBLE PRECISION A, B, C, EPS, PIHALF, R, RF, S, S2, TOL
      DOUBLE PRECISION DPMPAR
C---------------------
      DATA PIHALF /1.570796326794896619231321691639751442099D0/
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0.
C
                      EPS = DPMPAR(1)
C
C-----------------------------------------------------------------------
      TOL = 4.D0 * EPS
      IF (DMIN1(PHI,CPHI) .LT. 0.D0) GO TO 100
      IF (DABS((PHI + CPHI) - PIHALF) .GT. TOL * PIHALF) GO TO 100
      IF (DABS(N) .GT. 1.D0) GO TO 110
      IF (K2 .LT. 0.D0 .OR. L2 .LT. 0.D0) GO TO 120
      IF (DABS((K2 + L2) - 1.D0) .GT. TOL) GO TO 120
C
      IF (PHI .LT. 0.79D0) GO TO 10
          S = DCOS(CPHI)
          C = DSIN(CPHI)
          GO TO 11
   10 S = DSIN(PHI)
      C = DCOS(PHI)
   11 A = C*C
      B = L2 + K2*A
      S2 = S*S
C
      IF (N .GT. 0.D0) GO TO 20
          R = 1.D0 - N*S2
          GO TO 30
   20 IF (M .LT. 0.D0 .OR. M .GT. 1.D0) GO TO 110
      IF (DABS((M + N) - 1.D0) .GT. TOL) GO TO 110
      R = M + N*A
C
   30 CALL DRJVAL (A, B, 1.D0, R, P, IERR)
      IF (IERR .NE. 0) GO TO 130
      P = P * (S * S2) * N/3.D0
      CALL DRFVAL (A, B, 1.D0, RF, IERR)
      P = P + S * RF
      RETURN
C
C     ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE RFVAL (X, Y, Z, RF, IERR)
C-----------------------------------------------------------------------
C
C          THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL
C          OF THE FIRST KIND
C
C          RF(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                                -1/2     -1/2     -1/2
C                      (1/2)(T+X)    (T+Y)    (T+Z)    DT,
C
C          WHERE X, Y, AND Z ARE NONNEGATIVE AND AT MOST ONE OF THEM
C          IS ZERO.  IF ONE OF THEM IS ZERO, THE INTEGRAL IS COMPLETE.
C          THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE
C          NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR
C          SERIES TO FIFTH ORDER.  REFERENCE. B. C. CARLSON, COMPUTING
C          ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979),
C          1-16.  CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES
C          LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011.
C          MARCH 1, 1980. MODIFIED BY A.H. MORRIS (NSWC).
C
C-----------------------------------------------------------------------
      INTEGER IERR
      REAL RF,C1,C2,C3,E2,E3,EPSLON,ERRTOL,LAMDA
      REAL LOLIM,MU,S,UPLIM,X,XN,XNDEV,XNROOT
      REAL Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT
      REAL SPMPAR
C-----------------------------------------------------------------------
C
C          INPUT ...
C
C          X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RF(X,Y,Z).
C
C          OUTPUT ...
C
C          RF IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C          IERR IS THE RETURN ERROR CODE.
C               IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C               IERR = 1  X, Y, OR Z IS NEGATIVE.
C               IERR = 2  X+Y, X+Z, OR Y+Z IS TOO SMALL.
C               IERR = 3  X, Y, OR Z IS TOO LARGE.
C
C-----------------------------------------------------------------------
C
C          MACHINE DEPENDENT PARAMETERS ...
C
C          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C          LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5.
C          UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5.
C
                      LOLIM = 5.0 * SPMPAR(2)
                      UPLIM = 0.2 * SPMPAR(3)
C
C          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C          RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN
C          ERRTOL ** 6 / (4 * (1 - ERRTOL)).
C
               ERRTOL = (3.6 * SPMPAR(1))**(1.0/6.0)
C
C-----------------------------------------------------------------------
C          WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C          EXPENSE OF ROBUSTNESS.
C-----------------------------------------------------------------------
C
      IF (AMIN1(X,Y,Z) .LT. 0.0) GO TO 100
      IF (AMIN1(X+Y,X+Z,Y+Z) .LT. LOLIM) GO TO 110
      IF (AMAX1(X,Y,Z) .GT. UPLIM) GO TO 120
C
      IERR = 0
      XN = X
      YN = Y
      ZN = Z
C
   10 MU = (XN + YN + ZN) / 3.0
      XNDEV = 2.0 - (MU + XN) / MU
      YNDEV = 2.0 - (MU + YN) / MU
      ZNDEV = 2.0 - (MU + ZN) / MU
      EPSLON = AMAX1(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV))
      IF (EPSLON .LT. ERRTOL) GO TO 20
      XNROOT = SQRT(XN)
      YNROOT = SQRT(YN)
      ZNROOT = SQRT(ZN)
      LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
      XN = (XN + LAMDA) * 0.25
      YN = (YN + LAMDA) * 0.25
      ZN = (ZN + LAMDA) * 0.25
      GO TO 10
C
   20 C1 = 1.0 / 24.0
      C2 = 3.0 / 44.0
      C3 = 1.0 / 14.0
      E2 = XNDEV * YNDEV - ZNDEV * ZNDEV
      E3 = XNDEV * YNDEV * ZNDEV
      S = 1.0 + (C1 * E2 - 0.1 - C2 * E3) * E2 + C3 * E3
      RF = S / SQRT(MU)
      RETURN
C
C                      ERROR RETURN
C
  100 RF = 0.0
      IERR = 1
      RETURN
  110 RF = 0.0
      IERR = 2
      RETURN
  120 RF = 0.0
      IERR = 3
      RETURN
      END
      SUBROUTINE DRFVAL (X, Y, Z, RF, IERR)
C-----------------------------------------------------------------------
C
C          THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL
C          OF THE FIRST KIND
C
C          RF(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                                -1/2     -1/2     -1/2
C                      (1/2)(T+X)    (T+Y)    (T+Z)    DT,
C
C          WHERE X, Y, AND Z ARE NONNEGATIVE AND AT MOST ONE OF THEM
C          IS ZERO.  IF ONE OF THEM IS ZERO, THE INTEGRAL IS COMPLETE.
C          THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE
C          NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR
C          SERIES TO FIFTH ORDER.  REFERENCE. B. C. CARLSON, COMPUTING
C          ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979),
C          1-16.  CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES
C          LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011.
C          MARCH 1, 1980. MODIFIED BY A.H. MORRIS (NSWC).
C
C-----------------------------------------------------------------------
      INTEGER IERR
      DOUBLE PRECISION RF,C1,C2,C3,E2,E3,EPSLON,ERRTOL,LAMDA
      DOUBLE PRECISION LOLIM,MU,S,UPLIM,X,XN,XNDEV,XNROOT
      DOUBLE PRECISION Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT
      DOUBLE PRECISION DPMPAR
C-----------------------------------------------------------------------
C
C          INPUT ...
C
C          X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RF(X,Y,Z).
C
C          OUTPUT ...
C
C          RF IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C          IERR IS THE RETURN ERROR CODE.
C               IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C               IERR = 1  X, Y, OR Z IS NEGATIVE.
C               IERR = 2  X+Y, X+Z, OR Y+Z IS TOO SMALL.
C               IERR = 3  X, Y, OR Z IS TOO LARGE.
C
C-----------------------------------------------------------------------
C
C          MACHINE DEPENDENT PARAMETERS ...
C
C          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C          LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5.
C          UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5.
C
                      LOLIM = 5.0D0 * DPMPAR(2)
                      UPLIM = 0.2D0 * DPMPAR(3)
C
C          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C          RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN
C          ERRTOL ** 6 / (4 * (1 - ERRTOL)).
C
             ERRTOL = (3.6 * SNGL(DPMPAR(1)))**(1.0/6.0)
C
C-----------------------------------------------------------------------
C          WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C          EXPENSE OF ROBUSTNESS.
C-----------------------------------------------------------------------
C
      IF (DMIN1(X,Y,Z) .LT. 0.D0) GO TO 100
      IF (DMIN1(X+Y,X+Z,Y+Z) .LT. LOLIM) GO TO 110
      IF (DMAX1(X,Y,Z) .GT. UPLIM) GO TO 120
C
      IERR = 0
      XN = X
      YN = Y
      ZN = Z
C
   10 MU = (XN + YN + ZN) / 3.D0
      XNDEV = 2.D0 - (MU + XN) / MU
      YNDEV = 2.D0 - (MU + YN) / MU
      ZNDEV = 2.D0 - (MU + ZN) / MU
      EPSLON = DMAX1(DABS(XNDEV),DABS(YNDEV),DABS(ZNDEV))
      IF (EPSLON .LT. ERRTOL) GO TO 20
      XNROOT = DSQRT(XN)
      YNROOT = DSQRT(YN)
      ZNROOT = DSQRT(ZN)
      LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
      XN = (XN + LAMDA) * 0.25D0
      YN = (YN + LAMDA) * 0.25D0
      ZN = (ZN + LAMDA) * 0.25D0
      GO TO 10
C
   20 C1 = 1.D0 / 24.D0
      C2 = 3.D0 / 44.D0
      C3 = 1.D0 / 14.D0
      E2 = XNDEV * YNDEV - ZNDEV * ZNDEV
      E3 = XNDEV * YNDEV * ZNDEV
      S = 1.D0 + (C1 * E2 - 0.1D0 - C2 * E3) * E2 + C3 * E3
      RF = S / DSQRT(MU)
      RETURN
C
C                      ERROR RETURN
C
  100 RF = 0.D0
      IERR = 1
      RETURN
  110 RF = 0.D0
      IERR = 2
      RETURN
  120 RF = 0.D0
      IERR = 3
      RETURN
      END
      SUBROUTINE RDVAL (X, Y, Z, RD, IERR)
C-----------------------------------------------------------------------
C
C          THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL
C          OF THE SECOND KIND
C
C          RD(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                                -1/2     -1/2     -3/2
C                      (3/2)(T+X)    (T+Y)    (T+Z)    DT,
C
C          WHERE X AND Y ARE NONNEGATIVE, X + Y IS POSITIVE, AND Z IS
C          POSITIVE.  IF X OR Y IS ZERO, THE INTEGRAL IS COMPLETE.
C          THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE
C          NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR
C          SERIES TO FIFTH ORDER.  REFERENCE. B. C. CARLSON, COMPUTING
C          ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979),
C          1-16.  CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES
C          LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011.
C          MARCH 1, 1980. MODIFIED BY A.H. MORRIS (NSWC).
C
C-----------------------------------------------------------------------
      INTEGER IERR
      REAL RD,C1,C2,C3,C4,EA,EB,EC,ED,EF,EPSLON,ERRTOL,LAMDA
      REAL LOLIM,MU,POWER4,SIGMA,S1,S2,UPLIM,X,XN,XNDEV
      REAL XNROOT,Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT
      REAL SPMPAR
C-----------------------------------------------------------------------
C
C          INPUT ...
C
C          X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RD(X,Y,Z).
C
C          OUTPUT ...
C
C          RD IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C          IERR IS THE RETURN ERROR CODE.
C               IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C               IERR = 1  X, Y, OR Z IS NEGATIVE.
C               IERR = 2  X+Y OR Z IS TOO SMALL.
C               IERR = 3  X, Y, OR Z IS TOO LARGE.
C
C-----------------------------------------------------------------------
C
C          MACHINE DEPENDENT PARAMETERS ...
C
C          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C          RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN
C          3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C
              ERRTOL = (.28 * SPMPAR(1)) ** (1.0/6.0)
C
C          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C          LOLIM IS NOT LESS THAN 2 / (MACHINE MAXIMUM) ** (2/3).
C          UPLIM IS NOT GREATER THAN (0.1 * ERRTOL / MACHINE
C          MINIMUM) ** (2/3).
C
              MU = -2.0/3.0
              LOLIM = 2.0001 * SPMPAR(3) ** MU
              UPLIM = (10.0 * SPMPAR(2) / ERRTOL) ** MU
C
C-----------------------------------------------------------------------
C          WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C          EXPENSE OF ROBUSTNESS.
C-----------------------------------------------------------------------
C
      IF (AMIN1(X,Y,Z) .LT. 0.0) GO TO 100
      IF (AMIN1(X+Y,Z) .LT. LOLIM) GO TO 110
      IF (AMAX1(X,Y,Z) .GT. UPLIM) GO TO 120
C
      IERR = 0
      XN = X
      YN = Y
      ZN = Z
      SIGMA = 0.0
      POWER4 = 1.0
C
   10 MU = (XN + YN + 3.0 * ZN) * 0.2
      XNDEV = (MU - XN) / MU
      YNDEV = (MU - YN) / MU
      ZNDEV = (MU - ZN) / MU
      EPSLON = AMAX1(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV))
      IF (EPSLON .LT. ERRTOL) GO TO 20
      XNROOT = SQRT(XN)
      YNROOT = SQRT(YN)
      ZNROOT = SQRT(ZN)
      LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
      SIGMA = SIGMA + POWER4 / (ZNROOT * (ZN + LAMDA))
      POWER4 = POWER4 * 0.25
      XN = (XN + LAMDA) * 0.25
      YN = (YN + LAMDA) * 0.25
      ZN = (ZN + LAMDA) * 0.25
      GO TO 10
C
   20 C1 = 3.0 / 14.0
      C2 = 1.0 / 6.0
      C3 = 9.0 / 22.0
      C4 = 3.0 / 26.0
      EA = XNDEV * YNDEV
      EB = ZNDEV * ZNDEV
      EC = EA - EB
      ED = EA - 6.0 * EB
      EF = ED + EC + EC
      S1 = ED * (- C1 + 0.25 * C3 * ED - 1.5 * C4 * ZNDEV * EF)
      S2 = ZNDEV * (C2 * EF + ZNDEV * (- C3 * EC + ZNDEV * C4 * EA))
      RD = 3.0 * SIGMA + POWER4 * (1.0 + S1 + S2) / (MU * SQRT(MU))
      RETURN
C
C                        ERROR RETURN
C
  100 RD = 0.0
      IERR = 1
      RETURN
  110 RD = 0.0
      IERR = 2
      RETURN
  120 RD = 0.0
      IERR = 3
      RETURN
      END
      SUBROUTINE DRDVAL (X, Y, Z, RD, IERR)
C-----------------------------------------------------------------------
C
C          THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL
C          OF THE SECOND KIND
C
C          RD(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                                -1/2     -1/2     -3/2
C                      (3/2)(T+X)    (T+Y)    (T+Z)    DT,
C
C          WHERE X AND Y ARE NONNEGATIVE, X + Y IS POSITIVE, AND Z IS
C          POSITIVE.  IF X OR Y IS ZERO, THE INTEGRAL IS COMPLETE.
C          THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE
C          NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR
C          SERIES TO FIFTH ORDER.  REFERENCE. B. C. CARLSON, COMPUTING
C          ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979),
C          1-16.  CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES
C          LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011.
C          MARCH 1, 1980. MODIFIED BY A.H. MORRIS (NSWC).
C
C-----------------------------------------------------------------------
      INTEGER IERR
      DOUBLE PRECISION RD,C1,C2,C3,C4,EA,EB,EC,ED,EF,EPSLON,ERRTOL,LAMDA
      DOUBLE PRECISION LOLIM,MU,POWER4,SIGMA,S1,S2,UPLIM,X,XN,XNDEV
      DOUBLE PRECISION XNROOT,Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT
      DOUBLE PRECISION DPMPAR
C-----------------------------------------------------------------------
C
C          INPUT ...
C
C          X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RD(X,Y,Z).
C
C          OUTPUT ...
C
C          RD IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C          IERR IS THE RETURN ERROR CODE.
C               IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C               IERR = 1  X, Y, OR Z IS NEGATIVE.
C               IERR = 2  X+Y OR Z IS TOO SMALL.
C               IERR = 3  X, Y, OR Z IS TOO LARGE.
C
C-----------------------------------------------------------------------
C
C          MACHINE DEPENDENT PARAMETERS ...
C
C          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C          RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN
C          3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C
              ERRTOL = (.28 * SNGL(DPMPAR(1)))**(1.0/6.0)
C
C          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C          LOLIM IS NOT LESS THAN 2 / (MACHINE MAXIMUM) ** (2/3).
C          UPLIM IS NOT GREATER THAN (0.1 * ERRTOL / MACHINE
C          MINIMUM) ** (2/3).
C
              MU = -2.D0/3.D0
              LOLIM = 2.00000000001D0 * DPMPAR(3) ** MU
              UPLIM = (10.D0 * DPMPAR(2) / ERRTOL) ** MU
C
C-----------------------------------------------------------------------
C          WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C          EXPENSE OF ROBUSTNESS.
C-----------------------------------------------------------------------
C
      IF (DMIN1(X,Y,Z) .LT. 0.D0) GO TO 100
      IF (DMIN1(X+Y,Z) .LT. LOLIM) GO TO 110
      IF (DMAX1(X,Y,Z) .GT. UPLIM) GO TO 120
C
      IERR = 0
      XN = X
      YN = Y
      ZN = Z
      SIGMA = 0.D0
      POWER4 = 1.D0
C
   10 MU = (XN + YN + 3.D0 * ZN) * 0.2D0
      XNDEV = (MU - XN) / MU
      YNDEV = (MU - YN) / MU
      ZNDEV = (MU - ZN) / MU
      EPSLON = DMAX1(DABS(XNDEV),DABS(YNDEV),DABS(ZNDEV))
      IF (EPSLON .LT. ERRTOL) GO TO 20
      XNROOT = DSQRT(XN)
      YNROOT = DSQRT(YN)
      ZNROOT = DSQRT(ZN)
      LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
      SIGMA = SIGMA + POWER4 / (ZNROOT * (ZN + LAMDA))
      POWER4 = POWER4 * 0.25D0
      XN = (XN + LAMDA) * 0.25D0
      YN = (YN + LAMDA) * 0.25D0
      ZN = (ZN + LAMDA) * 0.25D0
      GO TO 10
C
   20 C1 = 3.D0 / 14.D0
      C2 = 1.D0 / 6.D0
      C3 = 9.D0 / 22.D0
      C4 = 3.D0 / 26.D0
      EA = XNDEV * YNDEV
      EB = ZNDEV * ZNDEV
      EC = EA - EB
      ED = EA - 6.D0 * EB
      EF = ED + EC + EC
      S1 = ED * (- C1 + 0.25D0 * C3 * ED - 1.5D0 * C4 * ZNDEV * EF)
      S2 = ZNDEV * (C2 * EF + ZNDEV * (- C3 * EC + ZNDEV * C4 * EA))
      RD = 3.D0 * SIGMA + POWER4 * (1.D0 + S1 + S2) / (MU * DSQRT(MU))
      RETURN
C
C                        ERROR RETURN
C
  100 RD = 0.D0
      IERR = 1
      RETURN
  110 RD = 0.D0
      IERR = 2
      RETURN
  120 RD = 0.D0
      IERR = 3
      RETURN
      END
      SUBROUTINE RJVAL (X, Y, Z, P, RJ, IERR)
C-----------------------------------------------------------------------
C
C          THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL
C          OF THE THIRD KIND
C
C          RJ(X,Y,Z,P) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                                  -1/2     -1/2     -1/2     -1
C                        (3/2)(T+X)    (T+Y)    (T+Z)    (T+P)  DT,
C
C          WHERE X, Y, AND Z ARE NONNEGATIVE, AT MOST ONE OF THEM IS
C          ZERO, AND P IS POSITIVE.  IF X OR Y OR Z IS ZERO, THE
C          INTEGRAL IS COMPLETE.  THE DUPLICATION THEOREM IS ITERATED
C          UNTIL THE VARIABLES ARE NEARLY EQUAL, AND THE FUNCTION IS
C          THEN EXPANDED IN TAYLOR SERIES TO FIFTH ORDER.  REFERENCE.
C          B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION,
C          NUMER. MATH. 33 (1979), 1-16.  CODED BY B. C. CARLSON AND
C          ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY,
C          AMES, IOWA 50011.  MARCH 1, 1980. MODIFIED BY A.H. MORRIS
C          (NSWC).
C
C-----------------------------------------------------------------------
      INTEGER IERR
      REAL RJ,RC,ALFA,BETA,C1,C2,C3,C4,EA,EB,EC,E2,E3
      REAL EPSLON,ERRTOL,ETOLRC,LAMDA,LOLIM,MU,P,PN,PNDEV
      REAL POWER4,SIGMA,S1,S2,S3,UPLIM,X,XN,XNDEV
      REAL XNROOT,Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT
      REAL SPMPAR
C-----------------------------------------------------------------------
C
C          INPUT ...
C
C          X, Y, Z, AND P ARE THE VARIABLES IN THE INTEGRAL RJ(X,Y,Z,P).
C
C          OUTPUT ...
C
C          RJ IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C          IERR IS THE RETURN ERROR CODE.
C               IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C               IERR = 1  X, Y, Z, OR P IS NEGATIVE.
C               IERR = 2  X+Y, X+Z, Y+Z, OR P IS TOO SMALL.
C               IERR = 3  X, Y, Z, OR P IS TOO LARGE.
C
C-----------------------------------------------------------------------
C
C          MACHINE DEPENDENT PARAMETERS ...
C
C          RC IS A FUNCTION COMPUTED BY THE SUBROUTINE RCVAL1.
C          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C          LOLIM IS NOT LESS THAN THE CUBE ROOT OF THE VALUE
C          OF LOLIM USED IN THE CODE FOR RC, AND
C          UPLIM IS NOT GREATER THAN 0.3 TIMES THE CUBE ROOT OF
C          THE VALUE OF UPLIM USED IN THE CODE FOR RC.
C
               MU = 1.0/3.0
               LOLIM = 1.0001 * (5.0 * SPMPAR(2))**MU
               UPLIM = .29999 * (0.2 * SPMPAR(3))**MU
C
C          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. THE
C          RELATIVE ERROR DUE TO TRUNCATION OF THE SERIES FOR RJ
C          IS LESS THAN 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C          AN ERROR TOLERANCE (ETOLRC) WILL BE PASSED TO THE CODE FOR
C          RC TO MAKE THE TRUNCATION ERROR FOR RC LESS THAN FOR RJ.
C
               ERRTOL = (.28 * SPMPAR(1))**(1.0/6.0)
C
C-----------------------------------------------------------------------
C          WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C          EXPENSE OF ROBUSTNESS.
C-----------------------------------------------------------------------
C
      IF (AMIN1(X,Y,Z,P) .LT. 0.0) GO TO 100
      IF (AMIN1(X+Y,X+Z,Y+Z,P) .LT. LOLIM) GO TO 110
      IF (AMAX1(X,Y,Z,P) .GT. UPLIM) GO TO 120
C
      IERR = 0
      XN = X
      YN = Y
      ZN = Z
      PN = P
      SIGMA = 0.0
      POWER4 = 1.0
      ETOLRC = 0.5 * ERRTOL
C
   10 MU = (XN + YN + ZN + PN + PN) * 0.2
      XNDEV = (MU - XN) / MU
      YNDEV = (MU - YN) / MU
      ZNDEV = (MU - ZN) / MU
      PNDEV = (MU - PN) / MU
      EPSLON = AMAX1(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV),ABS(PNDEV))
      IF (EPSLON .LT. ERRTOL) GO TO 20
      XNROOT = SQRT(XN)
      YNROOT = SQRT(YN)
      ZNROOT = SQRT(ZN)
      LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
      ALFA = PN * (XNROOT + YNROOT + ZNROOT) + XNROOT * YNROOT * ZNROOT
      ALFA = ALFA * ALFA
      BETA = PN * (PN + LAMDA) * (PN + LAMDA)
      CALL RCVAL1 (ALFA, BETA, ETOLRC, RC, IERR)
      IF (IERR .NE. 0) RETURN
      SIGMA = SIGMA + POWER4 * RC
      POWER4 = POWER4 * 0.25
      XN = (XN + LAMDA) * 0.25
      YN = (YN + LAMDA) * 0.25
      ZN = (ZN + LAMDA) * 0.25
      PN = (PN + LAMDA) * 0.25
      GO TO 10
C
   20 C1 = 3.0 / 14.0
      C2 = 1.0 / 3.0
      C3 = 3.0 / 22.0
      C4 = 3.0 / 26.0
      EA = XNDEV * (YNDEV + ZNDEV) + YNDEV * ZNDEV
      EB = XNDEV * YNDEV * ZNDEV
      EC = PNDEV * PNDEV
      E2 = EA - 3.0 * EC
      E3 = EB + 2.0 * PNDEV * (EA - EC)
      S1 = 1.0 + E2 * (-C1 + 0.75 * C3 * E2 - 1.5 * C4 * E3)
      S2 = EB * (0.5 * C2 + PNDEV * (- C3 - C3 + PNDEV * C4))
      S3 = PNDEV * EA * (C2 - PNDEV * C3) - C2 * PNDEV * EC
      RJ = 3.0 * SIGMA + POWER4 * (S1 + S2 + S3) / (MU * SQRT(MU))
      RETURN
C
C                        ERROR RETURN
C
  100 RJ = 0.0
      IERR = 1
      RETURN
  110 RJ = 0.0
      IERR = 2
      RETURN
  120 RJ = 0.0
      IERR = 3
      RETURN
      END
      SUBROUTINE DRJVAL (X, Y, Z, P, RJ, IERR)
C-----------------------------------------------------------------------
C
C          THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL
C          OF THE THIRD KIND
C
C          RJ(X,Y,Z,P) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                                  -1/2     -1/2     -1/2     -1
C                        (3/2)(T+X)    (T+Y)    (T+Z)    (T+P)  DT,
C
C          WHERE X, Y, AND Z ARE NONNEGATIVE, AT MOST ONE OF THEM IS
C          ZERO, AND P IS POSITIVE.  IF X OR Y OR Z IS ZERO, THE
C          INTEGRAL IS COMPLETE.  THE DUPLICATION THEOREM IS ITERATED
C          UNTIL THE VARIABLES ARE NEARLY EQUAL, AND THE FUNCTION IS
C          THEN EXPANDED IN TAYLOR SERIES TO FIFTH ORDER.  REFERENCE.
C          B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION,
C          NUMER. MATH. 33 (1979), 1-16.  CODED BY B. C. CARLSON AND
C          ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY,
C          AMES, IOWA 50011.  MARCH 1, 1980. MODIFIED BY A.H. MORRIS
C          (NSWC).
C
C-----------------------------------------------------------------------
      INTEGER IERR
      DOUBLE PRECISION RJ,RC,ALFA,BETA,C1,C2,C3,C4,EA,EB,EC,E2,E3
      DOUBLE PRECISION EPSLON,ERRTOL,ETOLRC,LAMDA,LOLIM,MU,P,PN,PNDEV
      DOUBLE PRECISION POWER4,SIGMA,S1,S2,S3,UPLIM,X,XN,XNDEV
      DOUBLE PRECISION XNROOT,Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT
      DOUBLE PRECISION DPMPAR
C-----------------------------------------------------------------------
C
C          INPUT ...
C
C          X, Y, Z, AND P ARE THE VARIABLES IN THE INTEGRAL RJ(X,Y,Z,P).
C
C          OUTPUT ...
C
C          RJ IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL.
C
C          IERR IS THE RETURN ERROR CODE.
C               IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C               IERR = 1  X, Y, Z, OR P IS NEGATIVE.
C               IERR = 2  X+Y, X+Z, Y+Z, OR P IS TOO SMALL.
C               IERR = 3  X, Y, Z, OR P IS TOO LARGE.
C
C-----------------------------------------------------------------------
C
C          MACHINE DEPENDENT PARAMETERS ...
C
C          RC IS A FUNCTION COMPUTED BY THE SUBROUTINE DRCVL1.
C          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C          LOLIM IS NOT LESS THAN THE CUBE ROOT OF THE VALUE
C          OF LOLIM USED IN THE CODE FOR RC, AND
C          UPLIM IS NOT GREATER THAN 0.3 TIMES THE CUBE ROOT OF
C          THE VALUE OF UPLIM USED IN THE CODE FOR RC.
C
               MU = 1.D0/3.D0
               LOLIM = 1.00000000001D0 * (5.0D0 * DPMPAR(2))**MU
               UPLIM = .299999999999D0 * (0.2D0 * DPMPAR(3))**MU
C
C          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C          RELATIVE ERROR DUE TO TRUNCATION OF THE SERIES FOR RJ
C          IS LESS THAN 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2.
C          AN ERROR TOLERANCE (ETOLRC) WILL BE PASSED TO THE CODE FOR
C          RC TO MAKE THE TRUNCATION ERROR FOR RC LESS THAN FOR RJ.
C
             ERRTOL = (.28 * SNGL(DPMPAR(1)))**(1.0/6.0)
C
C-----------------------------------------------------------------------
C          WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C          EXPENSE OF ROBUSTNESS.
C-----------------------------------------------------------------------
C
      IF (DMIN1(X,Y,Z,P) .LT. 0.D0) GO TO 100
      IF (DMIN1(X+Y,X+Z,Y+Z,P) .LT. LOLIM) GO TO 110
      IF (DMAX1(X,Y,Z,P) .GT. UPLIM) GO TO 120
C
      IERR = 0
      XN = X
      YN = Y
      ZN = Z
      PN = P
      SIGMA = 0.D0
      POWER4 = 1.D0
      ETOLRC = 0.5D0 * ERRTOL
C
   10 MU = (XN + YN + ZN + PN + PN) * 0.2D0
      XNDEV = (MU - XN) / MU
      YNDEV = (MU - YN) / MU
      ZNDEV = (MU - ZN) / MU
      PNDEV = (MU - PN) / MU
      EPSLON = DMAX1(DABS(XNDEV),DABS(YNDEV),DABS(ZNDEV),DABS(PNDEV))
      IF (EPSLON .LT. ERRTOL) GO TO 20
      XNROOT = DSQRT(XN)
      YNROOT = DSQRT(YN)
      ZNROOT = DSQRT(ZN)
      LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT
      ALFA = PN * (XNROOT + YNROOT + ZNROOT) + XNROOT * YNROOT * ZNROOT
      ALFA = ALFA * ALFA
      BETA = PN * (PN + LAMDA) * (PN + LAMDA)
      CALL DRCVL1 (ALFA, BETA, ETOLRC, RC, IERR)
      IF (IERR .NE. 0) RETURN
      SIGMA = SIGMA + POWER4 * RC
      POWER4 = POWER4 * 0.25D0
      XN = (XN + LAMDA) * 0.25D0
      YN = (YN + LAMDA) * 0.25D0
      ZN = (ZN + LAMDA) * 0.25D0
      PN = (PN + LAMDA) * 0.25D0
      GO TO 10
C
   20 C1 = 3.D0 / 14.D0
      C2 = 1.D0 / 3.D0
      C3 = 3.D0 / 22.D0
      C4 = 3.D0 / 26.D0
      EA = XNDEV * (YNDEV + ZNDEV) + YNDEV * ZNDEV
      EB = XNDEV * YNDEV * ZNDEV
      EC = PNDEV * PNDEV
      E2 = EA - 3.D0 * EC
      E3 = EB + 2.D0 * PNDEV * (EA - EC)
      S1 = 1.D0 + E2 * (- C1 + 0.75D0 * C3 * E2 - 1.5D0 * C4 * E3)
      S2 = EB * (0.5D0 * C2 + PNDEV * (- C3 - C3 + PNDEV * C4))
      S3 = PNDEV * EA * (C2 - PNDEV * C3) - C2 * PNDEV * EC
      RJ = 3.D0 * SIGMA + POWER4 * (S1 + S2 + S3) / (MU * DSQRT(MU))
      RETURN
C
C                        ERROR RETURN
C
  100 RJ = 0.D0
      IERR = 1
      RETURN
  110 RJ = 0.D0
      IERR = 2
      RETURN
  120 RJ = 0.D0
      IERR = 3
      RETURN
      END
      SUBROUTINE RCVAL1 (X, Y, ERRTOL, RC, IERR)
C-----------------------------------------------------------------------
C
C          THIS SUBROUTINE COMPUTES THE INTEGRAL
C
C          RC(X,Y) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                              -1/2     -1
C                    (1/2)(T+X)    (T+Y)  DT,
C
C          WHERE X IS NONNEGATIVE AND Y IS POSITIVE.  THE DUPLICATION
C          THEOREM IS ITERATED UNTIL THE VARIABLES ARE NEARLY EQUAL,
C          AND THE FUNCTION IS THEN EXPANDED IN TAYLOR SERIES TO FIFTH
C          ORDER.  LOGARITHMIC, INVERSE CIRCULAR, AND INVERSE HYPER-
C          BOLIC FUNCTIONS CAN BE EXPRESSED IN TERMS OF RC.  REFERENCE.
C          B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION,
C          NUMER. MATH. 33 (1979), 1-16.  CODED BY B. C. CARLSON AND
C          ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY,
C          AMES, IOWA 50011.  MARCH 1, 1980. MODIFIED BY A.H. MORRIS
C          (NSWC).
C
C-----------------------------------------------------------------------
      INTEGER IERR
      REAL RC,C1,C2,ERRTOL,LAMDA,LOLIM
      REAL MU,S,SN,UPLIM,X,XN,Y,YN
      REAL SPMPAR
C-----------------------------------------------------------------------
C
C          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C          LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5.
C          UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5.
C
                      LOLIM = 5.0 * SPMPAR(2)
                      UPLIM = 0.2 * SPMPAR(3)
C
C          INPUT ...
C
C          X AND Y ARE THE VARIABLES IN THE INTEGRAL RC(X,Y).
C
C          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C          RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN
C          16 * ERRTOL ** 6 / (1 - 2 * ERRTOL).
C
C          SAMPLE CHOICES   ERRTOL   RELATIVE TRUNCATION
C                                    ERROR LESS THAN
C                           1.E-3    2.E-17
C                           3.E-3    2.E-14
C                           1.E-2    2.E-11
C                           3.E-2    2.E-8
C                           1.E-1    2.E-5
C
C          OUTPUT ...
C
C          RC IS THE VALUE OF THE INTEGRAL.
C
C          IERR IS THE RETURN ERROR CODE.
C               IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C               IERR = 1  X OR Y IS NEGATIVE, OR Y = 0.
C               IERR = 2  X+Y IS TOO SMALL.
C               IERR = 3  X OR Y IS TOO LARGE.
C
C-----------------------------------------------------------------------
C          WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C          EXPENSE OF ROBUSTNESS.
C-----------------------------------------------------------------------
C
      IF (X .LT. 0.0 .OR. Y .LE. 0.0) GO TO 100
      IF ((X + Y) .LT. LOLIM) GO TO 110
      IF (AMAX1(X,Y) .GT. UPLIM) GO TO 120
C
      IERR = 0
      XN = X
      YN = Y
C
   10 MU = (XN + YN + YN) / 3.0
      SN = (YN + MU) / MU - 2.0
      IF (ABS(SN) .LT. ERRTOL) GO TO 20
      LAMDA = 2.0 * SQRT(XN) * SQRT(YN) + YN
      XN = (XN + LAMDA) * 0.25
      YN = (YN + LAMDA) * 0.25
      GO TO 10
C
   20 C1 = 1.0 / 7.0
      C2 = 9.0 / 22.0
      S = SN * SN * (0.3 + SN * (C1 + SN * (0.375 + SN * C2)))
      RC = (1.0 + S) / SQRT(MU)
      RETURN
C
C                      ERROR RETURN
C
  100 RC = 0.0
      IERR = 1
      RETURN
  110 RC = 0.0
      IERR = 2
      RETURN
  120 RC = 0.0
      IERR = 3
      RETURN
      END
      SUBROUTINE DRCVL1 (X, Y, ERRTOL, RC, IERR)
C-----------------------------------------------------------------------
C
C          THIS SUBROUTINE COMPUTES THE INTEGRAL
C
C          RC(X,Y) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                              -1/2     -1
C                    (1/2)(T+X)    (T+Y)  DT,
C
C          WHERE X IS NONNEGATIVE AND Y IS POSITIVE.  THE DUPLICATION
C          THEOREM IS ITERATED UNTIL THE VARIABLES ARE NEARLY EQUAL,
C          AND THE FUNCTION IS THEN EXPANDED IN TAYLOR SERIES TO FIFTH
C          ORDER.  LOGARITHMIC, INVERSE CIRCULAR, AND INVERSE HYPER-
C          BOLIC FUNCTIONS CAN BE EXPRESSED IN TERMS OF RC.  REFERENCE.
C          B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION,
C          NUMER. MATH. 33 (1979), 1-16.  CODED BY B. C. CARLSON AND
C          ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY,
C          AMES, IOWA 50011.  MARCH 1, 1980. MODIFIED BY A.H. MORRIS
C          (NSWC).
C
C-----------------------------------------------------------------------
      INTEGER IERR
      DOUBLE PRECISION RC,C1,C2,ERRTOL,LAMDA,LOLIM
      DOUBLE PRECISION MU,S,SN,UPLIM,X,XN,Y,YN
      DOUBLE PRECISION DPMPAR
C-----------------------------------------------------------------------
C
C          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C          LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5.
C          UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5.
C
                      LOLIM = 5.0D0 * DPMPAR(2)
                      UPLIM = 0.2D0 * DPMPAR(3)
C
C          INPUT ...
C
C          X AND Y ARE THE VARIABLES IN THE INTEGRAL RC(X,Y).
C
C          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C          RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN
C          16 * ERRTOL ** 6 / (1 - 2 * ERRTOL).
C
C          OUTPUT ...
C
C          RC IS THE VALUE OF THE INTEGRAL.
C
C          IERR IS THE RETURN ERROR CODE.
C               IERR = 0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C               IERR = 1  X OR Y IS NEGATIVE, OR Y = 0.
C               IERR = 2  X+Y IS TOO SMALL.
C               IERR = 3  X OR Y IS TOO LARGE.
C
C-----------------------------------------------------------------------
C          WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C          EXPENSE OF ROBUSTNESS.
C-----------------------------------------------------------------------
C
      IF (X .LT. 0.D0  .OR.  Y .LE. 0.D0) GO TO 100
      IF ((X + Y) .LT. LOLIM) GO TO 110
      IF (DMAX1(X,Y) .GT. UPLIM) GO TO 120
C
      IERR = 0
      XN = X
      YN = Y
C
   10 MU = (XN + YN + YN) / 3.D0
      SN = (YN + MU) / MU - 2.D0
      IF (DABS(SN) .LT. ERRTOL) GO TO 20
      LAMDA = 2.D0 * DSQRT(XN) * DSQRT(YN) + YN
      XN = (XN + LAMDA) * 0.25D0
      YN = (YN + LAMDA) * 0.25D0
      GO TO 10
C
   20 C1 = 1.D0 / 7.D0
      C2 = 9.D0 / 22.D0
      S = SN * SN * (0.3D0 + SN * (C1 + SN * (0.375D0 + SN * C2)))
      RC = (1.D0 + S) / DSQRT(MU)
      RETURN
C
C                      ERROR RETURN
C
  100 RC = 0.D0
      IERR = 1
      RETURN
  110 RC = 0.D0
      IERR = 2
      RETURN
  120 RC = 0.D0
      IERR = 3
      RETURN
      END
      SUBROUTINE ELLPF(U,K,L,S,C,D,IERR)
C     -------------------------------------------------------------
C     ELLPF CALCULATES THE ELLIPTIC FUNCTIONS SN(U,K), CN(U,K), AND
C     DN(U,K) FOR REAL U AND REAL MODULUS K.  IT IS ASSUMED THAT
C     ABS(K) .LE. 1. AND K**2 + L**2 = 1.
C     -------------------------------------------------------------
      REAL K, L
      DATA PIHALF /1.5707963267949/
C     ----------------
C     ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS.
C            MAX IS THE LARGEST POSITIVE INTEGER THAT MAY
C            BE USED, AND EPS IS THE SMALLEST REAL NUMBER
C            FOR WHICH 1 + EPS .GT. 1.
C
                    MAX = IPMPAR(3)
                    EPS = SPMPAR(1)
C
C     ----------------
C     CALCULATION FOR L = 0.0
C
      IF (L .NE. 0.0) GO TO 10
      S = TANH(U)
      E = EXP(-ABS(U))
      C = 2.0*E/(1.0 + E*E)
      D = C
      IERR = 0
      RETURN
C
C     CHECK THAT K**2 + L**2 = 1
C
   10 TOL = 2.0*EPS
      Z = DBLE(K*K) + (DBLE(L*L) - 1.D0)
      IF (ABS(Z) .GT. TOL) GO TO 100
C
      F = PIHALF
      IF (K .NE. 0.0) CALL ELLPI(PIHALF,0.0,K,L,F,E,IERR)
      F2 = 2.0*F
C
C                   ARGUMENT REDUCTION
C
      U1 = ABS(U)
      R = U1/F2
      IF (R .GE. AMIN1(FLOAT(MAX),1.0/EPS)) GO TO 110
      N = INT(R)
      U1 = U1 - FLOAT(N)*F2
      SG = 1.0
      IF (MOD(N,2) .NE. 0) SG = -1.0
C
      IF (U1 .LE. 0.0) GO TO 30
      IF (U1 .LE. F) GO TO 20
      U1 = U1 - F2
      SG = -SG
      IF (U1 .GE. 0.0) GO TO 30
C
C     CALCULATION OF ELLIPTIC FUNCTIONS FOR 0.0 .LE. U2 .LE. F(K)
C
   20 U2 = ABS(U1)
      CALL SCD (U2,ABS(K),ABS(L),F,S,C,D)
      IERR = 0
      IF (U1 .LT. 0.0) S = -S
C
C     FINAL ASSEMBLY
C
      S = SG*S
      C = SG*C
      IF (U .LT. 0.0) S = -S
      RETURN
C
C             U IS AN INTEGER MULTIPLE OF F2
C
   30 S = 0.0
      C = SG
      D = 1.0
      IERR = 0
      RETURN
C
C                      ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE SCD(U,K,L,F,S,C,D)
C     --------------------------------------------------------
C     SCD COMPUTES THE ELLIPTIC FUNCTIONS SN(U,K), CN(U,K),
C     AND DN(U,K) FOR REAL U AND REAL MODULUS K SUCH THAT
C     0.0 .LE. U .LE. F AND 0.0 .LE. K .LT. 1.0, WHERE
C     F = F(K) IS THE COMPLETE ELLIPTIC INTEGRAL OF THE
C     FIRST KIND, AND F1 = F(L) IS THE COMPLEMENTARY INTEGRAL.
C     IT IS ASSUMED THAT K**2 + L**2 = 1.
C     --------------------------------------------------------
      REAL K, L
      DATA PIHALF /1.5707963267949/
C     ------------------------
      IF (K .EQ. 0.0) GO TO 40
      V = F - U
C
C     USES MACLAURIN EXPANSION WHEN U OR V .LE. 0.01
C
      IF (U .GT. 0.01) GO TO 10
         CALL SCDM (U,K,S,C,D)
         RETURN
   10 IF (V .GT. 0.01) GO TO 20
      CALL SCDM (V,K,S1,C1,D1)
      S = C1/D1
      C = L*S1/D1
      D = L/D1
      RETURN
C
C     USES FOURIER EXPANSION WHEN K .LE. L
C
   20 CALL ELLPI(PIHALF,0.0,L,K,F1,E1,IERR)
C
      IF (K .GT. L) GO TO 30
      CALL SCDF (U,K,L,F,F1,S,C,D)
      RETURN
C
C     USES IMAGINARY TRANSFORMATION OF JACOBI AND FOURIER
C     EXPANSION WHEN K .GT. L
C
   30 CALL SCDJ (U,K,L,F,F1,S,C,D)
      RETURN
C
C     COMPUTATION FOR K = 0.0
C
   40 S = SIN(U)
      C = COS(U)
      D = 1.0
      RETURN
      END
      SUBROUTINE SCDM(U,K,S,C,D)
C     -------------------------------------------------
C     CALCULATES SN(U,K), CN(U,K), AND DN(U,K) FOR
C     0.0 .LE. U .LE. 0.01 AND FOR 0.0 .LE. K .LE. 1.0
C     BY USE OF THE MACLAURIN EXPANSION FOR SN(U,K)
C     -------------------------------------------------
      REAL K, K2
C
      K2 = K*K
      U2 = U*U
      C1 = -(1.0 + K2)/6.0
      C2 = (1.0 + K2*(14.0 + K2))/120.0
      C3 = -(1.0 + K2*(135.0 + K2*(135.0 + K2)))/5040.0
      C4 = (1.0 + K2*(1228.0 + K2*(5478.0 + K2*(1228.0 + K2))))/
     *     362880.0
      S = U*(1.0 + U2*(C1 + U2*(C2 + U2*(C3 + C4*U2))))
      C = SQRT(1.0 - S*S)
      D = SQRT(1.0 - (K*S)**2)
      RETURN
      END
      SUBROUTINE SCDF(U,K,L,F,F1,S,C,D)
C     -------------------------------------------------------------
C     SCDF COMPUTES SN(U,K), CN(U,K), AND DN(U,K) FOR REAL U AND
C     K BY USE OF THE FOURIER EXPANSION FOR SN(U,K).  IT IS
C     ASSUMED THAT 0.0 .LE. K .LT. 1.0 AND 0.0 .LE. U .LE. F,
C     WHERE F = F(K) IS THE COMPLETE ELLIPTIC INTEGRAL OF THE
C     FIRST KIND AND F1 = F(L) IS THE COMPLEMENTARY INTEGRAL, WITH
C     L .NE. 0. AND K**2 + L**2 = 1.
C     -------------------------------------------------------------
      REAL I, K, L
      DATA PIHALF /1.5707963267949/
C     -------------------------------------------------
C     EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE
C     SMALLEST NUMBER SUCH THAT 1. + EPS .GT. 1.
C
      EPS = SPMPAR(1)
C
C     -------------------------------------------------
      TOL = EPS/10.0
      V = F - U
      QH = EXP(-PIHALF*F1/F)
      Q1 = QH*QH
      Q2 = Q1*Q1
      COEF = 4.*PIHALF*QH/(K*F)
      QN = 1.0
      QD = Q1
      W = AMIN1(U,V)
      X = PIHALF*W/F
C
C     CALCULATION OF SERIES FOR W = AMIN1(U,V)
C
      I = 1.0
      SUM = 0.0
   10 AI = QN/(1.0 - QD)
      A = AI*SIN(I*X)
      SUM = SUM + A
      IF (ABS(AI) .LT. TOL*ABS(SUM)) GO TO 20
      QN = QN*Q1
      QD = QD*Q2
      I = I + 2.0
      GO TO 10
C
C     ASSEMBLY FOR U .LE. V
C
   20 S = COEF*SUM
      C = SQRT(1.0 - S*S)
      D = SQRT(1.0 - (K*S)**2)
      IF (U .EQ. W) RETURN
C
C     ASSEMBLY FOR U .GT. V
C
      TEMP = S
      S = C/D
      C = L*TEMP/D
      D = L/D
      RETURN
      END
      SUBROUTINE SCDJ(U,K,L,F,F1,S,C,D)
C     ----------------------------------------------------------------
C     SCDJ COMPUTES SN(U,K), CN(U,K), AND DN(U,K) FOR REAL U AND
C     K USING THE IMAGINARY TRANSFORMATION OF JACOBI AND A
C     FOURIER EXPANSION.  IT IS ASSUMED THAT 0.0 .LE. K .LT. 1.0
C     AND 0.0 .LE. U .LE. F, WHERE F = F(K) IS THE COMPLETE ELLIPTIC
C     INTEGRAL OF THE FIRST KIND AND F1 = F(L) IS THE COMPLEMENTARY
C     INTEGRAL, AND THAT L .NE. 0. AND K**2 + L**2 = 1.
C     ----------------------------------------------------------------
      REAL K, L, N
      DATA PIHALF /1.5707963267949/
      DATA PI /3.1415926535898/
C     ------------------------------------------------
C     EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE
C     SMALLEST NUMBER SUCH THAT 1. + EPS .GT. 1.
C
      EPS = SPMPAR(1)
C
C     ------------------------------------------------
      TOL = EPS/10.0
      V = F - U
      Q1 = -EXP(-PI*F/F1)
      Q2 = Q1*Q1
C
      W = AMIN1(U,V)
      E1 = PI*AMAX1(U,V)/F1
      E2 = PI*(F + W)/F1
      E1 = EXP(-E1)
      E2 = EXP(-E2)
C
      COEF = PIHALF/(K*F1)
      X = PIHALF*W/F1
      X2 = 2.0*X
C
C     CALCULATION OF SERIES FOR W = AMIN1(U,V)
C
      N = 1.0
      Q1N = Q1
      Q2N = Q2
      E1N = E1
      E2N = E2
      SUM = 0.0
C
   20 XN = N*X2
      IF (XN .GT. 1.0) GO TO 30
         CALL SNHCSH(SH,CH,XN,-1)
         SH = SH + XN
         A = 2.0*Q1N*ABS(Q1N)*SH/(1.0 + Q2N)
         GO TO 40
   30 A = Q1N*(E1N - E2N)/(1.0 + Q2N)
   40 SUM = SUM + A
      IF (ABS(A) .LT. TOL*ABS(SUM)) GO TO 50
      Q1N = Q1N*Q1
      Q2N = Q2N*Q2
      E1N = E1N*E1
      E2N = E2N*E2
      N = N + 1.0
      GO TO 20
C
C     ASSEMBLY FOR U .LE. V
C
   50 S = COEF*(TANH(X) + 2.0*SUM)
      C = SQRT(1.0 - S*S)
      D = SQRT(1.0 - (K*S)**2)
      IF (U .EQ. W) RETURN
C
C     ASSEMBLY FOR U .GT. V
C
      TEMP = S
      S = C/D
      C = L*TEMP/D
      D = L/D
      RETURN
      END
      SUBROUTINE ELPFC1 (U,K,L,S,C,D,IERR)
C     -------------------------------------------------------------
C     ELPFC1 CALCULATES THE ELLIPTIC FUNCTIONS SN(U,K), CN(U,K),
C     DN(U,K) FOR COMPLEX U AND REAL MODULUS K.  IT IS ASSUMED THAT
C     ABS(K) .LE. 1. AND K**2 + L**2 = 1.
C     -------------------------------------------------------------
      COMPLEX U, S, C, D
      REAL K, L, K2
C
      U1 = REAL(U)
      U2 = AIMAG(U)
      K2 = K*K
      IF (U1 .EQ. 0.0) GO TO 10
      IF (U2 .NE. 0.0) GO TO 20
C
C     CALCULATION FOR U2 = 0.
C
      CALL ELLPF (U1,K,L,S1,C1,D1,IERR)
      IF (IERR .NE. 0) RETURN
      S2 = 0.0
      C2 = 0.0
      D2 = 0.0
      GO TO 40
C
C     CALCULATION FOR U1 = 0.
C
   10 CALL ELLPF (U2,L,K,S2,C2,D2,IERR)
      IF  (IERR .NE. 0) RETURN
      IF (C2 .EQ. 0.0) GO TO 50
      S1 = 0.0
      S2 = S2/C2
      D1 = D2/C2
      D2 = 0.0
      C1 = 1.0/C2
      C2 = 0.0
      GO TO 40
C
C     CALCULATION FOR U1 AND U2 .NE. 0.
C
   20 CALL ELLPF (U1,K,L,SK,CK,DK,IERR)
      IF (IERR .NE. 0) RETURN
      CALL ELLPF (U2,L,K,SL,CL,DL,IERR)
      IF (IERR .NE. 0) RETURN
      COEF = ABS(K)*SL
      T1 = CL
      T2 = COEF*SK
      TD1 = COEF*T1
      TD2 = COEF*T2
      IF (ABS(T2) .LE. ABS(T1)) GO TO 30
      IF (T2 .EQ. 0.0) GO TO 50
      IF (TD2 .EQ. 0.0) GO TO 50
      T = T1/T2
      R = 1.0/(1.0 + T*T)
      S1 = DL*R/TD2
      S2 = CK*DK*SL*T*R/T2
      C1 = CK*T*R/T2
      C2 = -DK*SL*DL*R/TD2
      D1 = DK*DL*T*R/T2
      D2 = -K2*CK*SL*R/TD2
      GO TO 40
   30 IF (T1 .EQ. 0.0) GO TO 50
      IF (TD1 .EQ. 0.0) GO TO 50
      T = T2/T1
      R = 1.0/(1.0 + T*T)
      S1 = DL*T*R/TD1
      S2 = CK*DK*SL*R/T1
      C1 = CK*R/T1
      C2 = -DK*SL*DL*T*R/TD1
      D1 = DK*DL*R/T1
      D2 = -K2*CK*SL*T*R/TD1
C
C     FINAL ASSEMBLY
C
   40 S = CMPLX (S1, S2)
      C = CMPLX (C1, C2)
      D = CMPLX (D1, D2)
      RETURN
C
C     ERROR RETURN
C
   50 IERR = 3
      RETURN
      END
      SUBROUTINE PEQ(Z, W, IERR)
C
C     WEIERSTRASS P-FUNCTION IN THE EQUIANHARMONIC CASE
C     FOR COMPLEX ARGUMENT WITH UNIT PERIOD PARALLELOGRAM
C
      COMPLEX Z, Z1, Z4, Z6, W
      REAL ZR, ZI
      INTEGER IERR, M, N
C
C     REDUCTION TO FUNDAMENTAL PARALLELOGRAM
C
      ZI = 1.1547005383792515E0*AIMAG(Z) + 0.5E0
      M = INT(ZI)
      IF (ZI.LT.0E0) M = M - 1
      ZR = REAL(Z) - 0.5E0*FLOAT(M) + 0.5E0
      N = INT(ZR)
      IF (ZR.LT.0E0) N = N - 1
      Z1 = Z - FLOAT(N) - (0.5E0,0.86602540378443865E0)*FLOAT(M)
C
C     IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT.
C     THE LATTICE POINTS ARE POLES FOR P.
C
      W = Z1*Z1
      ZR = ABS(REAL(W)) + ABS(AIMAG(W))
      IF (ZR.NE.0E0) GO TO 10
      IERR = 1
      RETURN
C
C     EVALUATION OF P(Z1)
C
   10 IERR = 0
      Z4 = W*W
      Z6 = Z4*W
      W = 1E0/W + 6E0*Z4*(5E0+Z6)/(1E0-Z6)**2 + Z4*
     * (((((-2.6427662E-10*Z6+1.610954818E-8)*Z6+7.38610752879E-6)*
     * Z6+4.3991444671178E-4)*Z6+7.477288220490697E-2)*
     * Z6-6.8484153287299201E-1)/(((((6.2252191E-10*Z6+2.553314573E-7)*
     * Z6-2.619832920421E-5)*Z6-5.6444801847646E-4)*
     * Z6+4.565553484820106E-2)*Z6+1E0)
      RETURN
      END
      SUBROUTINE PEQ1(Z, W, IERR)
C
C     FIRST DERIVATIVE OF WEIERSTRASS P-FUNCTION IN THE
C     EQUIANHARMONIC CASE FOR COMPLEX ARGUMENT
C     WITH UNIT PERIOD PARALLELOGRAM
C
      COMPLEX Z, Z1, Z3, Z6, W
      REAL ZR, ZI
      INTEGER IERR, M, N
C
C     REDUCTION TO FUNDAMENTAL PARALLELOGRAM
C
      ZI = 1.1547005383792515E0*AIMAG(Z) + 0.5E0
      M = INT(ZI)
      IF (ZI.LT.0E0) M = M - 1
      ZR = REAL(Z) - 0.5E0*FLOAT(M) + 0.5E0
      N = INT(ZR)
      IF (ZR.LT.0E0) N = N - 1
      Z1 = Z - FLOAT(N) - (0.5E0,0.86602540378443865E0)*FLOAT(M)
C
C     IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT.
C     THE LATTICE POINTS ARE POLES FOR DP.
C
      Z3 = Z1*Z1*Z1
      Z6 = Z3*Z3
      W = Z3*(1E0-Z6)**3
      ZR = ABS(REAL(W)) + ABS(AIMAG(W))
      IF (ZR.NE.0E0) GO TO 10
      IERR = 1
      RETURN
C
C     EVALUATION OF DP(Z1)
C
   10 IERR = 0
      W = (((14E0*Z6+294E0)*Z6+126E0)*Z6-2E0)/W +
     * Z3*((((((-2.95539175E-9*Z6-2.6764693031E-7)*Z6+2.402192743346E-5)
     * *Z6+1.9656661451391E-4)*Z6+1.760135529461036E-2)*
     * Z6+8.1026243498822636E-1)*Z6-2.73936613149196804E0)/
     * ((((((4.6397763E-10*Z6+5.413482233E-8)*Z6-1.56293298374E-6)*
     * Z6-1.0393701076352E-4)*Z6+9.5553182532237E-4)*
     * Z6+9.131106969640212E-2)*Z6+1E0)
      RETURN
      END
      SUBROUTINE PLEM(Z, W, IERR)
C
C     WEIERSTRASS P-FUNCTION IN THE LEMNISCATIC CASE
C     FOR COMPLEX ARGUMENT WITH UNIT PERIOD PARALLELOGRAM
C
      COMPLEX Z, Z1, Z4, Z6, W
      REAL ZR, ZI
      INTEGER IERR, M, N
C
C     REDUCTION TO FUNDAMENTAL PARALLELOGRAM
C
      ZR = REAL(Z) + 0.5E0
      ZI = AIMAG(Z) + 0.5E0
      M = INT(ZR)
      N = INT(ZI)
      IF (ZR.LT.0E0) M = M - 1
      IF (ZI.LT.0E0) N = N - 1
      Z1 = Z - FLOAT(M) - (0E0,1E0)*FLOAT(N)
C
C     IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT.
C     THE LATTICE POINTS ARE POLES FOR P.
C
      W = Z1*Z1
      ZR = ABS(REAL(W)) + ABS(AIMAG(W))
      IF (ZR.NE.0E0) GO TO 10
      IERR = 1
      RETURN
C
C     EVALUATION OF P(Z1)
C
   10 IERR = 0
      Z4 = W*W
      Z6 = Z4*W
      W = 1E0/W + 4E0*W*(3E0+Z4)/(1E0-Z4)**2 +
     * W*((((((((-7.233108E-11*Z4+1.714197273E-8)*Z4-2.5369036492E-7)*
     * Z4-7.98710206868E-6)*Z4+6.4850606909737E-4)*Z4+7.39624629362938E-
     * 3)*Z4+2.012382768497244E-2)*Z4+7.1177297543136598E-1)*
     * Z4-2.54636399353830738E0)/((((((((5.1161516E-10*Z4+6.61289408E-9)
     * *Z4+4.4618987048E-7)*Z4-8.42694918892E-6)*Z4+4.42886829095E-6)*
     * Z4-4.22629935217101E-3)*Z4+2.577496871700433E-2)*
     * Z4+4.2359940482277074E-1)*Z4+1E0)
      RETURN
      END
      SUBROUTINE PLEM1(Z, W, IERR)
C
C     FIRST DERIVATIVE OF WEIERSTRASS P-FUNCTION IN THE
C     LEMNISCATIC CASE FOR COMPLEX ARGUMENT
C     WITH UNIT PERIOD PARALLELOGRAM
C
      COMPLEX Z, Z1, Z3, Z4, W
      REAL ZR, ZI
      INTEGER IERR, M, N
C
C     REDUCTION TO FUNDAMENTAL PARALLELOGRAM
C
      ZR = REAL(Z) + 0.5E0
      ZI = AIMAG(Z) + 0.5E0
      M = INT(ZR)
      N = INT(ZI)
      IF (ZR.LT.0E0) M = M - 1
      IF (ZI.LT.0E0) N = N - 1
      Z1 = Z - FLOAT(M) - (0E0,1E0)*FLOAT(N)
C
C     IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT.
C     THE LATTICE POINTS ARE POLES FOR DP.
C
      Z3 = Z1*Z1*Z1
      Z4 = Z3*Z1
      W = (Z1*(1E0-Z4))**3
      ZR = ABS(REAL(W)) + ABS(AIMAG(W))
      IF (ZR.NE.0E0) GO TO 10
      IERR = 1
      RETURN
C
C     EVALUATION OF DP(Z1)
C
   10 IERR = 0
      W = (((1E1*Z4+9E1)*Z4+3E1)*Z4-2E0)/W +
     * Z1*((((((((((-3.9046302E-9*Z4-1.001487137E-8)*Z4+5.9573043092E-7)
     * *Z4-2.482518130524E-5)*Z4+1.4557266595395E-4)*
     * Z4+4.56633655643206E-3)*Z4+6.224782572111135E-2)*
     * Z4+1.038527937794269E-2)*Z4+1.19804620802637942E0)*
     * Z4+6.42791439683811718E0)*Z4-5.09272798707661477E0)/
     * ((((((((((4.726888E-11*Z4-3.0667983E-9)*Z4+1.0087596089E-7)*
     * Z4-8.060683451E-8)*Z4+1.184299251664E-5)*Z4-2.3096723361547E-4)*
     * Z4-2.90730903142055E-3)*Z4+1.338392411135511E-2)*
     * Z4+2.3098639320021426E-1)*Z4+8.4719880964554148E-1)*Z4+1E0)
      RETURN
      END
      SUBROUTINE VALR2(X,Y,N0,P,IOP,A,IND,KO)
C     -------------------
      DIMENSION X(*),Y(*),G(2),H(2)
      DIMENSION E(5),E2(10),E3(15)
      DIMENSION APH1(3),APH2(3),APH4(3)
      DIMENSION RSQ(3),A3D8(3),CST(3)
      REAL KOM,L
C     -------------------
      DATA PI/3.1415926535898/
      DATA TWOPI/6.28318530717958/
      DATA ALNPI/1.14472988584940/
      DATA RTPI/1.77245385090552/
      DATA RTPII/.56418958354776/
C     -------------------
      DATA E(1)/.885777518572895E+00/,  E(2)/-.981151952778050E+00/,
     1     E(3)/.759305502082485E+00/,  E(4)/-.353644980686977E+00/,
     2     E(5)/.695232092435207E-01/
      DATA E2(1) /.886226470016632E+00/,  E2(2) /-.999950714561036E+00/,
     1     E2(3) /.885348820003892E+00/,  E2(4) /-.660611239043357E+00/,
     2     E2(5) /.421821197160099E+00/,  E2(6) /-.222898055667208E+00/,
     3     E2(7) /.905057384150449E-01/,  E2(8) /-.254906111884287E-01/,
     4     E2(9) /.430895168984138E-02/,  E2(10)/-.323377239693247E-03/
      DATA E3(1) /.886226924931465E+00/,  E3(2) /-.999999899776252E+00/,
     1     E3(3) /.886223733186722E+00/,  E3(4) /-.666626670510907E+00/,
     2     E3(5) /.442851899328569E+00/,  E3(6) /-.265638206366025E+00/,
     3     E3(7) /.145060043403014E+00/,  E3(8) /-.714909837799889E-01/,
     4     E3(9) /.309199295521210E-01/,  E3(10)/-.112323532148441E-01/,
     5     E3(11)/.324944543171185E-02/,  E3(12)/-.704260243309096E-03/,
     6     E3(13)/.105787574480633E-03/,  E3(14)/-.971864864160461E-05/,
     7     E3(15)/.408335517232165E-06/
      DATA APH1(1)/2.02E-7/, APH1(2)/2.08E-13/, APH1(3)/2.71E-19/
      DATA APH2(1)/1.22E-2/, APH2(2)/1.23E-4/, APH2(3)/1.34E-6/
      DATA APH4(1)/.6962E-1/, APH4(2)/.6990E-2/, APH4(3)/.7311E-3/
      DATA RSQ(1)/6.0516/, RSQ(2)/12.60605/, RSQ(3)/19.201924/
      DATA A3D8(1)/0.28125E-4/, A3D8(2)/0.285E-7/, A3D8(3)/0.32625E-10/
      DATA CST(1)/.5625E-4/, CST(2)/.57E-7/, CST(3)/.6512E-10/
C     -------------------
C     TAU IS A MACHINE DEPENDENT TOLERANCE. IT IS ASSUMED THAT A
C     7 OR MORE DIGIT FLOATING POINT ARITHMETIC IS BEING USED.
C     -------------------
      TAU=2.0*SPMPAR(1)
      IF (TAU.LT.3.E-11) TAU=AMAX1(5.0*TAU,1.E-14)
C     -------------------
      N=N0
      IF (N.EQ.2.OR.N.LT.1) GO TO 4021
      TAUSQ=TAU*TAU
C
      P=0.0
      IND=0
      A=0.0
      KOM=0.0
      K=1
      IF (N.NE.1) GO TO 10
C
      W=X(2)-X(1)
      Z=Y(2)-Y(1)
      U=X(3)-X(1)
      V=Y(3)-Y(1)
      XK=0.0
      PSI1=V*W-U*Z
      IF (PSI1.GE.0.0) GO TO 21
C
      P=-1.0
      T1=W
      W=U
      U=T1
      T1=V
      V=Z
      Z=T1
      GO TO 21
C
   10 KO=0
      X(N+1)=X(1)
      Y(N+1)=Y(1)
      U=X(2)-X(1)
      V=Y(2)-Y(1)
      XK=X(1)
      YK=Y(1)
C
   20 W=X(1)-X(N)
      Z=Y(1)-Y(N)
   21 D1SQ=W*W+Z*Z
      IF (D1SQ.GT.TAUSQ) GO TO 30
      IF (N.EQ.1) GO TO 4011
      N=N-1
      IF (N.EQ.2) RETURN
      GO TO 20
C
   30 D2SQ=U*U+V*V
      IF (D2SQ.GT.TAUSQ) GO TO 40
      IF (N.EQ.1) GO TO 4011
   31 K=K+1
      U=X(K+1)-XK
      V=Y(K+1)-YK
      D2SQ=U*U+V*V
      IF (D2SQ.LE.TAUSQ) GO TO 31
      IF (K.EQ.N-1) RETURN
C
   40 A=XK*(Y(K+1)-Y(N))
      BGD1=SQRT(D1SQ+D1SQ)
      BGD2=SQRT(D2SQ+D2SQ)
C
C             PROCESSING VERTEX (XK,YK)
C
   50 PSI1=V*W-U*Z
      CEE=U*W+V*Z
      AJ0=ATAN2(PSI1,CEE)
      KOM=KOM+AJ0
      L=0.0
      B=.5*(X(K)*X(K)+Y(K)*Y(K))
      IF (B.GT.APH1(IOP)) GO TO 60
      P1=AJ0/TWOPI
      GO TO 3621
C
   60 G(1)=(W*X(K)+Z*Y(K))/BGD1
      G(2)=(U*X(K)+V*Y(K))/BGD2
      H(1)=(-Y(K)*W+X(K)*Z)/BGD1
      H(2)=(-Y(K)*U+X(K)*V)/BGD2
      IF (ABS(PSI1).GT.BGD1*BGD2*A3D8(IOP)) GO TO 80
      IF (CEE.LT.0.0) GO TO 70
      IF (ABS(AJ0).GT.TAU.AND.G(1).LT.0.0) GO TO 80
      P1=0.0
      GO TO 3621
C
   70 IF (ABS(PSI1).LE.(.5*TAU*BGD1*BGD2)) IND=2
      IF (PSI1.LT.0.0) GO TO 71
      P1=.5*ERFC1(0,H(2))
      GO TO 3621
   71 P1=-.5*ERFC1(0,H(1))
      GO TO 3621
C
   80 IF (B.GT.APH2(IOP)) GO TO 90
      C=RTPI*(H(2)-H(1))-(G(2)*H(2)-G(1)*H(1))
      P1=(AJ0-C)/TWOPI
      GO TO 3621
C
C                 COMPUTATION OF L
C
   90 IF (G(1).LT.0.0) GO TO 100
      IF (G(2).GE.0.0) GO TO 130
      G(2)=-G(2)
      H(2)=-H(2)
      IF (ABS(H(2)).LE.APH4(IOP)) GO TO 91
      L=.5*ERFC1(0,-H(2))
      GO TO 120
   91 L=.5+RTPII*H(2)
      GO TO 120
C
  100 G(1)=-G(1)
      H(1)=-H(1)
      IF (G(2).LT.0.0) GO TO 110
      IF (ABS(H(1)).LE.APH4(IOP)) GO TO 101
      L=.5*ERFC1(0,H(1))
      GO TO 120
  101 L=.5-RTPII*H(1)
      GO TO 120
C
  110 G(2)=-G(2)
      H(2)=-H(2)
      IF (ABS(H(1)).LE.APH4(IOP)) GO TO 112
      IF (ABS(H(2)).LE.APH4(IOP)) GO TO 111
      L=.5*(ERFC1(0,H(1))-ERFC1(0,H(2)))
      GO TO 130
  111 L=RTPII*H(2)-.5*ERF(H(1))
      GO TO 130
  112 IF (ABS(H(2)).LE.APH4(IOP)) GO TO 113
      L=.5*ERF(H(2))-RTPII*H(1)
      GO TO 130
  113 L=RTPII*(H(2)-H(1))
      GO TO 130
C
  120 PSI1=-PSI1
      IF (PSI1.LE.0.0) GO TO 121
      L=L-1.0
      AJ0=AJ0+PI
      GO TO 130
  121 AJ0=AJ0-PI
C
C                 SERIES EVALUATION
C
  130 IF (B.GE.RSQ(IOP)) GO TO 171
      CAPE=AJ0
      CAPH=.5*AJ0
      M=1
      F=0.0
      AJ1=H(2)-H(1)
      CIRCM=AJ1
      IF (IOP-2) 140,150,160
C
  140 SUM=E(M)*AJ1
  141 M=M+1
      H(1)=H(1)*G(1)
      H(2)=H(2)*G(2)
      T=H(2)-H(1)
      F=F+B
      CAPV=(F*CAPE+T)/M
      SUM=SUM+E(M)*CAPV
      IF (M.GE.5) GO TO 170
      CAPE=CIRCM
      CIRCM=CAPV
      GO TO 141
C
  150 SUM=E2(M)*AJ1
  151 M=M+1
      H(1)=H(1)*G(1)
      H(2)=H(2)*G(2)
      T=H(2)-H(1)
      F=F+B
      CAPV=(F*CAPE+T)/M
      SUM=SUM+E2(M)*CAPV
      IF (M.GE.10) GO TO 170
      CAPE=CIRCM
      CIRCM=CAPV
      GO TO 151
C
  160 SUM=E3(M)*AJ1
  161 M=M+1
      H(1)=H(1)*G(1)
      H(2)=H(2)*G(2)
      T=H(2)-H(1)
      F=F+B
      CAPV=(F*CAPE+T)/M
      SUM=SUM+E3(M)*CAPV
      IF (M.GE.15) GO TO 170
      CAPE=CIRCM
      CIRCM=CAPV
      GO TO 161
C
  170 P1=L+EXP(-(B+ALNPI))*(CAPH-SUM)
      GO TO 3621
  171 P1=L
C
C               STANDARD TERMINATION
C
 3621 IF (K.NE.N) GO TO 3651
      IF (N.NE.1) GO TO 3631
      P=ABS(P+ABS(P1))
      RETURN
C
 3631 P=P-P1
      KOM=KOM/TWOPI
      A=.5*A
      IF (KOM.LT.0.0) GO TO 3641
      KO=INT(KOM+.125)
      GO TO 3645
 3641 KO=INT(KOM-.125)
 3645 P=P+FLOAT(KO)
      RETURN
C
C              SET UP THE NEXT VERTEX
C
 3651 W=U
      Z=V
      BGD1=BGD2
      XK=X(K+1)
      YK=Y(K+1)
      YKM1=Y(K)
 3661 K=K+1
      U=X(K+1)-XK
      V=Y(K+1)-YK
      D2SQ=U*U+V*V
      IF (D2SQ.LE.TAUSQ) GO TO 3661
      BGD2=SQRT(D2SQ+D2SQ)
      P=P-P1
      A=A+XK*(Y(K+1)-YKM1)
      GO TO 50
C
C                  ERROR RETURN
C
 4011 IND=1
      P=5.0
      RETURN
 4021 IND=3
      RETURN
      END
      SUBROUTINE CIRCV (R, D, J, P, IERR)
C-----------------------------------------------------------------------
C       IF J .NE. 0, OUTPUT IS P = CIRCULAR COVERAGE FUNCTION. P GIVES
C       THE PROBABILITY OF A SHOT FALLING, UNDER A NORMAL DISTRIBUTION
C       WITH MEAN (0,0) AND EQUAL STANDARD DEVIATIONS, S, IN A CIRCLE
C       OF RADIUS R0, OFFSET A DISTANCE D0 FROM (0,0).
C       INPUT IS R = R0/S, D = D0/S.
C
C       IF J = 0, OUTPUT IS P = GENERALIZED CIRCULAR ERROR FUNCTION.
C       P GIVES THE PROBABILITY OF A SHOT FALLING ,UNDER A NORMAL
C       BIVARIATE DISTRIBUTION WITH MEAN (0,0) AND STANDARD DEVIATIONS
C       SMIN AND S, IN A CIRCLE OF RADIUS R0 CENTERED AT (0,0).
C       INPUT FOR J = 0, R = R0/S, D = SMIN/S .LE. 1.
C       IF SMIN = 0, S .NE. 0, P = ERF(R/(SQR(2)).
C
C       IF IERR .NE. 0, SOME PORTION OF THE INPUT IS UNACCEPTABLE.
C       IF R .LT. 0., THEN CIRCV SETS IERR = 1.
C       IF D .LT. 0, OR J = 0 AND D .GT. 1., THEN CIRCV SETS IERR = 2.
C
C       REFERENCES
C       MATH OF COMP APRIL 1961,PP169,173 AND OCT.1961, PP 375, 382.
C       NWL REPORT N0.1768, JAN. 1962. NSWC REPORT N0.83-13, NOV. 1982.
C       IEEE TRANS. INFO. TH. APRIL 1965, P. 312.
C-----------------------------------------------------------------------
C       NEGATIVE R AND D ARE NOT PERMITTED.
C--------------------------------------------
      REAL M, M0
C-----------------------
C     C1 = 1/SQRT(2)
C     C2 = 1/SQRT(PI)
C     C3 = 2*PI
C-----------------------
      DATA E  /2.71828182845905/
      DATA C1 /.707106781186548/
      DATA C2 /.564189583547756/
      DATA C3 /6.28318530717959/
C-----------------------
        P = 0.0
        IF (R .LT. 0.0) GOTO 115
        IF (D .LT. 0.0) GOTO 120
        IERR = 0
        IF (R .EQ. 0.0) RETURN
C
        EPS0 = SPMPAR(1)
        Z = - ALOG(EPS0)
        IF (J .NE. 0) GOTO 40
C------------------------------------------------------------------
C   FOR J = 0, ERROR IN D IF D .LT. 0 OR D .GT. 1
C------------------------------------------------------------------
C                J = 0
C--------------------------------------------------
        IF (D .GT. 1.0) GOTO 120
        IF (D .EQ. 1.0) GOTO 45
        IF (D .NE. 0.0) GOTO 5
C---------------------------------------
C          J = 0,     D = 0
C---------------------------------------
        P = ERF(R*C1)
        RETURN
C-------------------------------------------------
C   J = 0,  (R*R .GT. -2*LOG(EPS0))  P = 1
C-------------------------------------------------
    5   IF (R*R .LT. 2.0*Z) GOTO 10
        P = 1.0
        RETURN
C---------------------------------------------
   10   X = R
        D2 = D*D
        Y1 = R/D
        T = 0.5*Y1
        ZM = (0.5 - D2) + 0.5
        T2 = T*T
        T = T2*ZM
C
        EPS = 10.0*EPS0
        IF (T .GT. 14.0) GO TO 25
C-------------------------------------------------
C    J = 0,   T .LE. 14
C-------------------------------------------------
        ZP = 1.0 + D2
        ZR = ZM/ZP
        ZRS = ZR*ZR
        BK2 = T2*ZP
        C0 = 2.0*D/ZP
        S0 = EXP(-BK2)
        T0 = 0.5 + (0.5 - S0)
        IF (BK2 .LE. 0.15) T0 = -REXP(-BK2)
        T0 = C0*T0
        S0 = C0*S0
C
        P = T0
        AN = 0.0
   20      AN = AN + 2.0
           F = (AN - 1.0)/AN
           W = T/AN
           X = S0*W
           T0 = F*ZRS*T0 - (W + ZR)*X
           S0 = W*X
           P = P + T0
           IF (T0 .GT. EPS*P) GO TO 20
        RETURN
C------------------------------------------------
C   J = 0,    T .GT. 14
C------------------------------------------------
   25   T = 0.25/T
        CONST = D2/ZM
        DELTA = SQRT(ZM)
        X = 2.0*(C1*C2)/(R*DELTA)
        EXPT = EXP(-0.5*R*R)
        CALL ERFC0 (1, C1*R, EXPT, M)
        M = M/DELTA
C
        P = 1.0
        SUM = M
        AN = 0.0
        IF (EXPT*M .LT. 5.E-3) GO TO 30
C
C          SET  P = 1 - EXP(-R*R/2)*M
C
           P = (ERF(C1*R) - D2/(1.0 + DELTA))/DELTA
           SUM = 0.0
C
C          COMPUTE THE ASYMPTOTIC EXPANSION
C
   30      AN = AN + 2.0
           ANM1 = AN - 1.0
           F = ANM1/AN
           M0 = M
           M = CONST*F*(X - M)
           IF (M .GE. M0 .OR. M .LT. 0.0) GO TO 35
           X = ANM1*F*T*X
           SUM = SUM + M
           IF (M .GT. EPS*SUM) GO TO 30
   35   P = P - EXPT*SUM
        GO TO 110
C------------------------------------
C              J .NE. 0
C------------------------------------
   40   A1 = R - D
        T = R*D
        IF (D .NE. 0.0) GO TO 50
C----------------------------------------------
C     J = 0 AND D = 1, OR J .NE. 0 AND D = 0
C----------------------------------------------
   45   P = -REXP(-0.5*R*R)
        RETURN
C----------------------------------------
   50   A = 0.5*(A1*A1)
        IF (A1 .LE. 5.0) GO TO 55
        IF (A .LE. Z) GO TO 60
            P = 1.0
            RETURN
   55   IF (A1 .LT. -5.0 .AND. A .GT. -EXPARG(1)) RETURN
C----------------------------------------
   60   EPS = 1.5E2*EPS0
        IF (R .GE. 1.7 .AND. T .GT. 16.0) GO TO 75
C------------------------------------------------------------------
C      J .NE. 0,    R .LT. 1.7  OR  R*D .LE. 16
C------------------------------------------------------------------
        TR = 0.5*(R*R)
        TD = 0.5*(D*D)
C
C       FIND THE NUMBER N OF TERMS TO BE USED IN THE SERIES
C
        Z = 0.5*T
        N = Z*E + 1.0
        TN = ((E*Z/N)**(N + N))/(C3*N)
   65       N = N + 1
            W = Z/N
            TN = TN*(W*W)
            IF (TN .GT. EPS) GO TO 65
C
C       COMPUTE THE SERIES
C
        M = N
        CALL GRATIO (M + 1.0, TR, S, W, 0)
        W = RCOMP(M,TR)/M
        P = S
        DO 70 I = 1,N
            S = S + W
            W = (M/TR)*W
            P = S + (TD/M)*P
   70       M = M - 1.0
        P = EXP(-TD)*P
        GO TO 110
C------------------------------------------------------------------
C      J .NE. 0,    R .GE. 1.7  AND  R*D .GT. 16
C------------------------------------------------------------------
   75   Z = C1*ABS(A1)
        W = EXP(-A)
        CALL ERFC0 (1, Z, W, S1)
C
        A = 0.5*Z/T
        T = 0.25/T
        M = C2 - Z*S1
        IF (Z .GE. 4.0) M = ERFCR(Z)
        M = 0.5*A*M
        X = 0.5*C2*T
        S1 = S1 + M
        S2 = C2 + X
C
        AN = 2.0
   80       AN = AN + 2.0
            ANM1 = AN - 1.0
            F = ANM1/AN
            M0 = M
            M = F*A*(X - Z*M)
            X = F*(ANM1*T)*X
            S2 = S2 + X
            IF (M .LE. 0.0 .OR. M .GE. M0) GO TO 90
            S1 = S1 + M
            IF (M .GT. EPS*S1) GO TO 80
C
   90       AN = AN + 2.0
            ANM1 = AN - 1.0
            X0 = X
            X = (ANM1/AN)*(ANM1*T)*X
            IF (X .GE. X0) GO TO 100
            S2 = S2 + X
            IF (X .GT. EPS*S2) GO TO 90
C
  100   S1 = 0.5*(R + D)*S1
        S2 = C1*S2
        W = W/SQRT(R*D)
        P = 0.5*W*ABS(S1 - S2)
        IF (A1 .GT. 0.0) P = ABS(1.0 - 0.5*W*(S1 + S2))
C
C       TERMINATION
C
  110   IF (P .GT. 1.0) P = 1.0
        RETURN
  115   IERR = 1
        P = -1.0
        RETURN
  120   IERR = 2
        P = -1.0
        RETURN
        END
      SUBROUTINE ERFC0 (IND, X, E, Y)
C-----------------------------------------------------------------------
C         EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION
C
C               Y = ERFC(X)            IF IND = 0
C               Y = EXP(X*X)*ERFC(X)   OTHERWISE
C
C     E IS AN INPUT/OUTPUT VARIABLE. IF E .GE. 0 THEN IT IS ASSUMED
C     THAT E = EXP(-X*X). IN THIS CASE E IS NOT MODIFIED. IF E IS
C     NEGATIVE THEN E IS SET TO EXP(-X*X) WHEN THIS VALUE IS NEEDED.
C
C-----------------------------------------------------------------------
      REAL A(4),B(4),P(8),Q(8),R(5),S(5)
      DOUBLE PRECISION W
C-------------------------
      DATA C/.564189583547756/
C-------------------------
      DATA A(1)/-1.65581836870402E-4/, A(2)/3.25324098357738E-2/,
     *     A(3)/1.02201136918406E-1/,  A(4)/1.12837916709552E00/
      DATA B(1)/4.64988945913179E-3/,  B(2)/7.01333417158511E-2/,
     *     B(3)/4.23906732683201E-1/,  B(4)/1.00000000000000E00/
      DATA P(1)/-1.36864857382717E-7/, P(2)/5.64195517478974E-1/,
     *     P(3)/7.21175825088309E00/,  P(4)/4.31622272220567E01/,
     *     P(5)/1.52989285046940E02/,  P(6)/3.39320816734344E02/,
     *     P(7)/4.51918953711873E02/,  P(8)/3.00459261020162E02/
      DATA Q(1)/1.00000000000000E00/,  Q(2)/1.27827273196294E01/,
     *     Q(3)/7.70001529352295E01/,  Q(4)/2.77585444743988E02/,
     *     Q(5)/6.38980264465631E02/,  Q(6)/9.31354094850610E02/,
     *     Q(7)/7.90950925327898E02/,  Q(8)/3.00459260956983E02/
      DATA R(1)/2.10144126479064E00/,  R(2)/2.62370141675169E01/,
     *     R(3)/2.13688200555087E01/,  R(4)/4.65807828718470E00/,
     *     R(5)/2.82094791773523E-1/
      DATA S(1)/9.41537750555460E01/,  S(2)/1.87114811799590E02/,
     *     S(3)/9.90191814623914E01/,  S(4)/1.80124575948747E01/,
     *     S(5)/1.00000000000000E00/
C-------------------------
C
C                     ABS(X) .LT. 0.47
C
      AX = ABS(X)
      IF (AX .GE. 0.47) GO TO 10
      T = X*X
      TOP = ((A(1)*T + A(2))*T + A(3))*T + A(4)
      BOT = ((B(1)*T + B(2))*T + B(3))*T + B(4)
      Y = 0.5 + (0.5 - X*TOP/BOT)
      IF (IND .EQ. 0) RETURN
C
      IF (E .LT. 0.0) E = EXP(-T)
      Y = Y/E
      RETURN
C
C                  0.47 .LE. ABS(X) .LE. 4
C
   10 IF (AX .GT. 4.0) GO TO 30
      TOP = ((((((P(1)*AX + P(2))*AX + P(3))*AX + P(4))*AX + P(5))*AX
     *                    + P(6))*AX + P(7))*AX + P(8)
      BOT = ((((((Q(1)*AX + Q(2))*AX + Q(3))*AX + Q(4))*AX + Q(5))*AX
     *                    + Q(6))*AX + Q(7))*AX + Q(8)
      Y = TOP/BOT
C
   20 IF (IND .EQ. 0) GO TO 21
         IF (X .GE. 0.0) RETURN
         IF (E .LT. 0.0) E = EXP(-X*X)
         Y = 2.0/E - Y
         RETURN
   21 W = DBLE(X)*DBLE(X)
      T = W
      EPS = W - DBLE(T)
      IF (E .LT. 0.0) E = EXP(-T)
      Y = ((0.5 + (0.5 - EPS)) * E) * Y
      IF (X .LT. 0.0) Y = 2.0 - Y
      RETURN
C
C                      ABS(X) .GT. 4
C
   30 IF (X .LE. -5.5) GO TO 40
      IF (IND .EQ. 0 .AND. X .GT. 50.0) GO TO 50
      T = (1.0/X)**2
      TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5)
      BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + S(5)
      Y = (C - T*TOP/BOT) / AX
      GO TO 20
C
C             LIMIT VALUE FOR LARGE NEGATIVE X
C
   40 Y = 2.0
      IF (IND .EQ. 0) RETURN
      IF (E .LT. 0.0) E = EXP(-X*X)
      Y = 2.0/E
      RETURN
C
C             LIMIT VALUE FOR LARGE POSITIVE X
C                       WHEN IND = 0
C
   50 Y = 0.0
      RETURN
      END
      REAL FUNCTION ERFCR (X)
C-----------------------------------------------------------------------
C     COMPUTATION OF  1/SQRT(PI) - X*EXP(X*X)*ERFC(X)  FOR X .GE. 4
C-----------------------------------------------------------------------
      REAL R(5), S(4)
C------------------------
      DATA R(1)/2.10144126479064E+00/,  R(2)/2.62370141675169E+01/,
     *     R(3)/2.13688200555087E+01/,  R(4)/4.65807828718470E+00/,
     *     R(5)/2.82094791773523E-01/
      DATA S(1)/9.41537750555460E+01/,  S(2)/1.87114811799590E+02/,
     *     S(3)/9.90191814623914E+01/,  S(4)/1.80124575948747E+01/
C------------------------
      T = (1.0/X)**2
      TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5)
      BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + 1.0
      ERFCR = T*TOP/BOT
      RETURN
      END
      SUBROUTINE PKILL (R0, SX, SY, H, K, P)
C-----------------------------------------------------------------------
C
C           COMPUTATION OF THE ELLIPTICAL COVERAGE FUNCTION
C
C                         ---------------
C
C     THE RESULT P IS ACCURATE TO AT LEAST 6 SIGNIFICANT DIGITS IF
C     P .GE. 1.E-20 AND MAX(H/S,K/S,SX/S,SY/S) .LE. 10/SQRT(SPMPAR(1))
C     FOR S = MIN(SX,SY).
C
C-----------------------------------------------------------------------
      REAL K, K8, V(16), W(16)
C-----------------------------------------------------------------------
C   V(*), W(*)-- GAUSSIAN ABSCISSAS AND WEIGHTS OF ORDER 32, ON (-1,1).
C-----------------------------------------------------------------------
      DATA V(1)  /.4830766568773832E-01/, V(2)  /.1444719615827965E+00/,
     *     V(3)  /.2392873622521371E+00/, V(4)  /.3318686022821276E+00/,
     *     V(5)  /.4213512761306353E+00/, V(6)  /.5068999089322294E+00/,
     *     V(7)  /.5877157572407623E+00/, V(8)  /.6630442669302152E+00/,
     *     V(9)  /.7321821187402897E+00/, V(10) /.7944837959679424E+00/,
     *     V(11) /.8493676137325700E+00/, V(12) /.8963211557660521E+00/,
     *     V(13) /.9349060759377397E+00/, V(14) /.9647622555875064E+00/,
     *     V(15) /.9856115115452683E+00/, V(16) /.9972638618494816E+00/
      DATA W(1)  /.9654008851472780E-01/, W(2)  /.9563872007927486E-01/,
     *     W(3)  /.9384439908080457E-01/, W(4)  /.9117387869576388E-01/,
     *     W(5)  /.8765209300440381E-01/, W(6)  /.8331192422694676E-01/,
     *     W(7)  /.7819389578707031E-01/, W(8)  /.7234579410884851E-01/,
     *     W(9)  /.6582222277636185E-01/, W(10) /.5868409347853555E-01/,
     *     W(11) /.5099805926237618E-01/, W(12) /.4283589802222668E-01/,
     *     W(13) /.3427386291302143E-01/, W(14) /.2539206530926206E-01/,
     *     W(15) /.1627439473090567E-01/, W(16) /.7018610009470097E-02/
C----------------------------------------
C     C = (2**.25)*GAMMA(3/4)/PI
C     RPI = 1/SQRT(PI)
C     RT2 = SQRT(2)
C----------------------------------------
      DATA A3  /20.0/
      DATA C   /.4638648042895004/
      DATA RPI /.5641895835477563/
      DATA RT2 /1.414213562373095/
C
      P = 0.0
      IF (SX .GT. 0.0 .AND. SY .GT. 0.0) GO TO 5
         P = -1.E10
         RETURN
    5 J = 0
      EPS = SPMPAR(1)
      SQEPS = SQRT(EPS)
      A = 6.5
C----------------------------------------
C     TEST NO.1 (REPORT 83-13).
C----------------------------------------
      Z3 = AMIN1(SQRT(SQRT(SPMPAR(2))),1.E-30)*SX*SY
      IF (R0*R0 .LE. Z3) RETURN
C
      H2 = H*H + K*K
      H8 = ABS(H)
      K8 = ABS(K)
      DM = AMAX1(SX,SY)
C-----------------------------------------
C     TEST NO.2 (REPORT 83-13).
C-----------------------------------------
      IF ((R0 - H8 + A3*SX) .LE. 0.0) RETURN
      IF ((R0 - K8 + A3*SY) .LE. 0.0) RETURN
C-----------------------------------------
C     TEST NO.3 (REPORT 83-13).
C-----------------------------------------
      C8 = - EPSLN(0)
C-----------EXP(-10.3026) = 3.35E(-5)---------
      A4 = AMAX1(C8 - 1.74249E1, 10.3026)
      A4 = SQRT(A4 + A4)
      H3 = (R0 - H)*(R0 + H)
      H5 = (R0 - K)*(R0 + K)
      S0 = A4*DM
      T = R0 - S0
      IF (T .LT. 0.0) GO TO 25
      IF (T*T .LT. H2) GO TO 25
      IF (R0 .LT. 1/SQEPS) GO TO 20
      T = H3 -2.0*R0*S0 + S0*S0 - K*K
      IF (ABS(H3) .LE. ABS(H5)) GO TO 10
      T = H5 - 2.0*R0*S0 + S0*S0 - H*H
   10 IF (T .LT. 0.0) GO TO 25
   20 P = 1.0
      RETURN
C-----------------------------------------
C     TEST NO.4 (REPORT 83-13).
C-----------------------------------------
   25 S0 = SQRT(H2)
      G2 = 0.0
      IF (S0 .LE. R0) GO TO 30
      D = ((S0 - R0)/DM)**2
      IF (R0*R0*EXP(-0.5*D) .LE. Z3) RETURN
C-----------------------------------------
C     SX - SY .LT. EPS
C-----------------------------------------
   30 IF (ABS(SX - SY) .GT. 20.0*DM*EPS) GO TO 33
      H8 = S0
      K8 = 0.0
      IF ((R0 - H8 + A3*DM) .LE. 0.0) RETURN
      IF (R0 .LT. DM/SQEPS) GO TO 33
      J = 1
      G2 = (K*K - H3)/((R0 + H8)*DM)
      IF (ABS(H3) .LE. ABS(H5)) GO TO 33
      G2 = (H*H - H5)/((R0 + H8)*DM)
C--------------------------
C     SMALL R
C--------------------------
   33 T1 = R0/SX
      T2 = R0/SY
      T3 = T1*T2
      T1 = T1*T1
      T2 = T2*T2
      Z1 = (H/SX)**2
      Z2 = (K/SY)**2
      T = T1*(Z1 - 1.0) + T2*(Z2 - 1.0)
      IF (ABS(T) .GT. 1.E-3) GO TO 35
      T9 = (T*T - 4.0*(T1*T1*(Z1 - 0.5) + T2*T2*(Z2 - 0.5)))/192.0
      IF (ABS(T9) .GT. AMAX1(10.0*EPS,1.E-10)) GO TO 35
      P = 0.5*T3*(1.0 + 0.125*T)*EXP(-0.5*(Z1 + Z2))
      RETURN
C-----------------------------------------------
C     NORMALIZE AMAX1(SX,SY) = 1.
C-----------------------------------------------
   35 R = R0/DM
      S1 = SX/DM
      S2 = SY/DM
      H8 = H8/DM
      K8 = K8/DM
      H2 = H2/(DM*DM)
C---------------------------------
C     S1 = 1 .GE. S2
C---------------------------------
      IF (S1 .GE. S2) GO TO 40
      H1 = S1
      S1 = S2
      S2 = H1
      H1 = H8
      H8 = K8
      K8 = H1
C-----------------------------------------------
C     LIMITING RESULTS FOR AMIN1(S1,S2) = 0
C-----------------------------------------------
   40 SEPS1 = AMIN1(6.71*SQEPS,1.E-5)
C-----------------------------------------------
C            R = K,  S2 SMALL
C-----------------------------------------------
      IF (K8 .NE. R) GO TO 45
      YY = .166484*(R*(H8*H8 + 1.0) + 1.0/R)*S2
      IF (ABS(YY) .GT. SEPS1) GO TO 85
      H1 = H8/RT2
      P = C*EXP(-H1*H1)*SQRT(K8*S2)
      RETURN
C-----------------------------------------------
C            R .GT. K,  S2 SMALL
C-----------------------------------------------
   45 IF (R .LT. K8) GO TO 85
      IF (K8 .NE. 0.0) GO TO 75
      H1 = S2*S2/(4.0*RT2*R)
      G2 = G2/RT2
      IF (J .EQ. 0) G2 = ABS(H8 - R)/RT2
      IF (ABS(G2) .LT. 4.0) GO TO 55
         IF (H1*ABS(G2) .GT. SEPS1) GO TO 85
         P = 0.5*AERF(H8/RT2,R/RT2)
         RETURN
   55 IF (J .NE. 0) GO TO 60
         P = 0.5*AERF(H8/RT2,R/RT2)
         GO TO 70
   60 IF (H8 + R .LT. RT2) GO TO 65
         P = 0.5*(ERFC(G2) - ERFC((H8 + R)/RT2))
         GO TO 70
   65 P = 0.5*(ERF((H8 + R)/RT2) - ERF(G2))
   70 IF (H1*EXP(-G2*G2) .GT. P*SEPS1) GO TO 85
      RETURN
C
   75 Z = (R - K8)*(R + K8)
      G2 = SQRT(Z)
      H1 = ABS(H8 - G2)
      J = 0
      IF (H1 .GT. 5.0) GO TO 80
         J = 1
         Z8 = AERF(H8/RT2,G2/RT2)
         IF (Z8 .EQ. 0.0) GO TO 85
         H1 = EXP(-0.5*(H8 - G2)**2)/Z8
   80 H1 = 1.0/(8.0*RT2*Z)*(K8*K8*ABS(H8 - G2) + R*R/G2)*S2*S2*H1
      IF (ABS(H1) .GT. SEPS1) GO TO 85
      U = 0.5
      IF (J .EQ. 0) Z8 = AERF(H8/RT2,G2/RT2)
      S2 = RT2*S2
      IF (K8 - R .GT. -13.0*S2) U = 0.25*AERF(K8/S2,R/S2)
      P = U*Z8
      RETURN
C----------------------------
C     FIND THE VALUE OF A
C----------------------------
   85 S0 = S1*S1
      S9 = S2*S2
      G3 = H8*H8
      G2 = K8*K8
      Z8 = S0 + S9
      Z = S0*S0 + S9*S9
      H3 = G3*S0 + G2*S9
      T1 = 2.0*(Z + 2*H3)
      YY = R*R*(H2 + Z8)/T1
      T1 = (H2 + Z8)*(H2 + Z8)/T1
      CALL GRATIO (T1,YY,Z,Z8,0)
      Z2 = R/(RT2*S2)
      R8 = R/(RT2*S1)
      H2 = H8/(RT2*S1)
      H3 = K8/(RT2*S2)
      S0 = 0.0
      S9 = 0.0
      IF (Z .LT. 1.E-13 .AND. S2 .GT. 5.E-10) GO TO 90
      IF (H2 .GT. 50.0 .OR. H3 .GT. 50.0) S0 = 1.5
   90 U = AERF(H3,Z2)
      YY = 0.25*U*AERF(H2,R8)
      IF (YY .GT. 0.1) S9 = 0.5
      IF (YY .GE. 5.E-15) GO TO 95
         Z = YY
         GO TO 100
   95 Z = AMIN1(YY,Z)
C
  100 IF (Z .GE. 0.5) GO TO 105
      A = A + .5
      IF (Z .GE. 5.E-4) GO TO 105
      A = A + .5 + S0
      IF (Z .GE. 1.E-6) GO TO 105
      A = A + .5 + S9
      IF (Z .GE. 5.E-9) GO TO 105
      A = A + .5
      IF (Z .GE. 5.E-10) GO TO 105
      A = A + .25
      IF (Z .GE. 5.E-11) GO TO 105
      A = A + .25
      IF (Z .GE. 5.E-12) GO TO 105
      A = A + .25
      IF (Z .GE. 5.E-13) GO TO 105
      A = A + .5 + .5*S9
      IF (Z .GT. 5.E-15) GO TO 105
      A = A + .5
      IF (Z .GT. 1.E-18) GO TO 105
      A = A + .25
      IF (Z .GT. 1.E-20) GO TO 105
      A = A + .25
      IF (Z .GT. 1.E-25) GO TO 105
      A = A + 1.
      IF (Z .GT. 1.E-30) GO TO 105
      A = A + 2.
C
  105 IF (S2 .GE. 5.E-2 .OR. H3 .LE. Z2) GO TO 107
      T9 = R8*U*EXP(-H2*H2)
      IF (T9 .LT. 5.E-2 * Z) A = A + 0.5
C---------------------------------------
C     START INTEGRATION PROCEDURE
C---------------------------------------
  107 S0 = S1
      S9 = S2
      Z8 = S2
      G2 = K8
      G3 = H8
      Z9 = S1
      J8 = 0
C-------------------------------------------------
C     DETERMINE INTERVAL OF INTEGRATION, (A,RT2).
C           E3 = (RT2-A)/2, D1 = (RT2+A)/2.
C-------------------------------------------------
  110 Z = G2 + A*Z8
      H3 = G2 - A*Z8
      H5 = 0.0
      T3 = -1.0
      A1 = (G3 - A*Z9)/R
      IF (ABS(A1 - 0.5) .GE. 0.5) GO TO 115
      A2 = AMAX1(((1.0 - G3/R) + A*Z9/R)*(1.0 + A1), 0.0)
      SA = SQRT(A2)
      IF (SA .LT. H3/R) GO TO 115
      T3 = A1/SQRT(1.0 + SA)
C----------------------------------------
C            T9 = 1.0 - D1
C----------------------------------------
  115 IF (H3 .GT. 0.0) GO TO 135
C----------------------------------------
C            H3 .LE. 0.0
C----------------------------------------
      IF (T3 .LT. 0.0) GO TO 120
         D2 = 0.5*(1.0 + T3)
         E4 = 0.25*SA/D2
         T5 = E4
  120 IF (Z .LT. R) GO TO 125
         E3 = 0.5
         D1 = E3
         T9 = D1
         GO TO 130
  125 D1 = 0.5*(1.0 + SQRT(1.0 - Z/R))
      E3 = 0.25*Z/(R*D1)
      T9 = E3
  130 IF (T3 .LE. D1 - E3)  GO TO 165
      GO TO 160
C----------------------------------------
C            H3 .GT. 0.0
C----------------------------------------
  135 H5 = 1.0
      Q = H3/R
      IF (Q .LE. 1.0) GO TO 140
         E3 = 0.5
         D1 = E3
         T9 = D1
         GO TO 165
  140 IF (T3 .LT. 0.0) GO TO 145
         E4 = AMAX1((1.0 - G2/R) + A*Z8/R, 0.0)
         E4 = SQRT(E4)
         D2 = 0.5*(E4 + T3)
         T5 = 0.5*(Q/(1.0 + E4) + SA/(1.0 + T3))
         E4 = 0.25*(SA - Q)/D2
  145 E3 = AMAX1((1.0 - G2/R) + A*Z8/R, 0.0)
      IF (Z .LT. R) GO TO 150
         E3 = 0.5*SQRT(E3)
         D1 = E3
         T9 = 0.25*(3.0 + H3/R)/(1.0 + E3)
         GO TO 155
  150 T9 = SQRT(E3)
      T2 = SQRT(1.0 - Z/R)
      D1 = 0.5*(T9 + T2)
      E3 = A*Z8/(R*2.0*D1)
      T9 = 0.5*((H3/R)/(1.0 + T9) + (Z/R)/(1.0 + T2))
  155 IF (T3 .LE. D1 - E3) GO TO 165
  160 E3 = E4
      D1 = D2
      T9 = T5
  165 IF (J8 .NE. 0) GO TO 170
      J8 = 1
      F = E3
      T = D1
      T1 = T9
      H6 = H5
      Z8 = S1
      G2 = H8
      G3 = K8
      Z9 = S2
      GO TO 110
C-----------------------------------------------------------------------
C     DETERMINE IN WHICH ORDER THE X AMD Y INTEGRATIONS ARE CARRIED OUT.
C-----------------------------------------------------------------------
  170 IF (S2 .GT. 2.E-2 .AND. H8 + K8 .LT. 2.E2) GO TO 172
      IF (ABS(E3 - F) .GT. 0.4*F) GO TO 172
      IF (D1 - T) 200,180,195
  172 IF (E3 .LT. 2.E4*EPS) GO TO 195
      IF (F .LT. 2.E4*EPS) GO TO 200
      IF (AMAX1(H8/S1,K8/S2) .LT. 2.0) GO TO 175
      IF (S2 .LT. 1.E-5) GO TO 175
      IF (S2 .GE. 5.E-4) GO TO 180
      IF (S1 .NE. S2) GO TO 195
  175 IF (AMIN1(E3,F) .LT. 2.5E-2*SQEPS) GOTO 185
  180 IF (E3 - F) 200,190,195
  185 IF (E3 - F) 195,190,200
  190 IF (S0 .GE. S9) GO TO 200
  195 E3 = F
      D1 = T
      T9 = T1
      S9 = S1
      S0 = S2
      Z8 = H8
      H8 = K8
      K8 = Z8
      H5 = H6
  200 Z2 = R/(RT2*S9)
      R8 = R/(RT2*S0)
      H2 = H8/(RT2*S0)
      H3 = K8/(RT2*S9)
      N1 = 16
      IZ = 0
      IZ3 = 0
      IY = 0
      P = 0.0
      T = H2 - R8 + R8*(D1 - E3*V(16))**2
      IF (T .GT. 0.0 .AND. T*T .GT. -EXPARG(1)) RETURN
C
      Q1 = RPI*E3*R8
      G3 = 0.0
      NT = 2*N1 + 1
      Z = (.5 + D1) +.5
      DO 260 II = 1, NT
         I = II - (N1 + 1)
         IF (I .EQ. 0) GO TO 260
         J = IABS(I)
         Q = E3*ISIGN(1,I)*V(J)
         T = Q + D1
         H6 = Z + Q
         Q = T9 - Q
         F = H6*Q
         T1 = R8*F
         T2 = (H2 - T1)*(H2 - T1)
         IF (H2 - R8 .GE. 0. .OR. T .LT. EPS) T2 =
     *       ((H2 - R8) + R8*T*T)**2
         T4 = EXP(-T2)
         IF (H2 .NE. 0.0) GO TO 210
            T4 = T4 + T4
            GO TO 215
  210    IF (H5 .NE. 0.0) GO TO 215
            T2 = 4.0*H2*T1
            IF (T2 .GT. C8) GO TO 215
            T4 = T4*(1.0 + EXP(-T2))
  215    IF (IZ .NE. 0) GO TO 255
         G2 = SQRT(1.0 + F)
         Z1 = Z2*T*G2
         X1 = H3 - Z1
         IF (X1 .GT. -A) GO TO 225
            IZ = 1
            X5 = 2.0
            GO TO 255
  225    IF (ABS(X1) .GT. 1.E-2*Z1) GO TO 230
            IY = 1
            X1 = ((K8 - R) + R*F*F/(1.0 + T*G2))/(RT2*S9)
  230    IF (IZ3 .NE. 0) GO TO 250
         SA = H3 + Z1
         IF (SA .GT. A3) GO TO 245
         IF (IY .EQ. 0) GO TO 240
         IF (X1 .GT. RT2) GO TO 235
            X5 = ERF(SA) - ERF(X1)
            GO TO 255
  235    X5 = ERFC(X1) - ERFC(SA)
         GO TO 255
  240    X5 = AERF(H3,Z1)
         GO TO 255
  245    IZ3 = 1
  250    X5 = ERFC(X1)
  255    G3 = G3 + X5*T4*T*W(J)
  260 CONTINUE
      P = Q1*G3
      IF (P .GT. YY) P = YY
      IF (P .GT. (1.0 - AMIN1(1.E6*EPS,1.E-5))) P = 1.0
      IF (P .LT. 0.0) P = 0.0
      RETURN
      END
      SUBROUTINE PLCOPY (A,KA,M,B,KB,N)
C     ------------------------------------------------------------------
C     COPYING REAL POLYNOMIALS
C     ------------------------------------------------------------------
      REAL A(*), B(*)
C
      LA = 1
      LB = 1
      JMAX = MIN0(M, N)
      DO 10 J = 1,JMAX
         B(LB) = A(LA)
         LA = LA + KA
         LB = LB + KB
   10 CONTINUE
      IF (JMAX .EQ. N) RETURN
C
      MP1 = M + 1
      DO 20 J = MP1,N
         B(LB) = 0.0
         LB = LB + KB
   20 CONTINUE
      RETURN
      END
      SUBROUTINE DPCOPY (A,KA,M,B,KB,N)
C     ------------------------------------------------------------------
C     COPYING DOUBLE PRECISION POLYNOMIALS
C     ------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*)
C
      LA = 1
      LB = 1
      JMAX = MIN0(M, N)
      DO 10 J = 1,JMAX
         B(LB) = A(LA)
         LA = LA + KA
         LB = LB + KB
   10 CONTINUE
      IF (JMAX .EQ. N) RETURN
C
      MP1 = M + 1
      DO 20 J = MP1,N
         B(LB) = 0.D0
         LB = LB + KB
   20 CONTINUE
      RETURN
      END
      SUBROUTINE PADD (A,KA,L,B,KB,M,C,KC,N)
C     ------------------------------------------------------------------
C     ADDITION OF REAL POLYNOMIALS
C     ------------------------------------------------------------------
      REAL A(*), B(*), C(*)
C
      LA = 1
      LB = 1
      LC = 1
      DO 10 I = 1,N
         C(LC) = 0.0
         IF (I .LE. L) C(LC) = A(LA)
         IF (I .LE. M) C(LC) = C(LC) + B(LB)
         LA = LA + KA
         LB = LB + KB
         LC = LC + KC
   10 CONTINUE
      RETURN
      END
      SUBROUTINE DPADD (A,KA,L,B,KB,M,C,KC,N)
C     ------------------------------------------------------------------
C     ADDITION OF DOUBLE PRECISION POLYNOMIALS
C     ------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*), C(*)
C
      LA = 1
      LB = 1
      LC = 1
      DO 10 I = 1,N
         C(LC) = 0.D0
         IF (I .LE. L) C(LC) = A(LA)
         IF (I .LE. M) C(LC) = C(LC) + B(LB)
         LA = LA + KA
         LB = LB + KB
         LC = LC + KC
   10 CONTINUE
      RETURN
      END
      SUBROUTINE PSUBT (A,KA,L,B,KB,M,C,KC,N)
C     ------------------------------------------------------------------
C     SUBTRACTION OF REAL POLYNOMIALS
C     ------------------------------------------------------------------
      REAL A(*), B(*), C(*)
C
      LA = 1
      LB = 1
      LC = 1
      DO 10 I = 1,N
         C(LC) = 0.0
         IF (I .LE. L) C(LC) = A(LA)
         IF (I .LE. M) C(LC) = C(LC) - B(LB)
         LA = LA + KA
         LB = LB + KB
         LC = LC + KC
   10 CONTINUE
      RETURN
      END
      SUBROUTINE DPSUBT (A,KA,L,B,KB,M,C,KC,N)
C     ------------------------------------------------------------------
C     SUBTRACTION OF DOUBLE PRECISION POLYNOMIALS
C     ------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*), C(*)
C
      LA = 1
      LB = 1
      LC = 1
      DO 10 I = 1,N
         C(LC) = 0.D0
         IF (I .LE. L) C(LC) = A(LA)
         IF (I .LE. M) C(LC) = C(LC) - B(LB)
         LA = LA + KA
         LB = LB + KB
         LC = LC + KC
   10 CONTINUE
      RETURN
      END
      SUBROUTINE PMULT (A,KA,L,B,KB,M,C,KC,N)
C     ------------------------------------------------------------------
C     MULTIPLICATION OF REAL POLYNOMIALS
C     ------------------------------------------------------------------
      REAL A(*), B(*), C(*)
      DOUBLE PRECISION DSUM
C
      LC = 1
      JMAX = MIN0(L + M - 1, N)
      DO 40 J = 1,JMAX
         IF (J .LE. L) GO TO 10
            IMIN = 1 + (J - L)
            LA = 1 + (L - 1)*KA
            LB = 1 + (IMIN - 1)*KB
            GO TO 20
   10    IMIN = 1
         LA = 1 + (J - 1)*KA
         LB = 1
C
   20    IMAX = MIN0(J, M)
         DSUM = 0.D0
         DO 30 I = IMIN,IMAX
            DSUM = DSUM + DBLE(A(LA))*DBLE(B(LB))
            LA = LA - KA
            LB = LB + KB
   30    CONTINUE
         C(LC) = DSUM
   40 LC = LC + KC
      IF (JMAX .EQ. N) RETURN
C
      JMIN = JMAX + 1
      DO 60 J = JMIN,N
         C(LC) = 0.0
   60 LC = LC + KC
      RETURN
      END
      SUBROUTINE DPMULT (A,KA,L,B,KB,M,C,KC,N)
C     ------------------------------------------------------------------
C     MULTIPLICATION OF DOUBLE PRECISION POLYNOMIALS
C     ------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*), C(*)
      DOUBLE PRECISION SUM
C
      LC = 1
      JMAX = MIN0(L + M - 1, N)
      DO 40 J = 1,JMAX
         IF (J .LE. L) GO TO 10
            IMIN = 1 + (J - L)
            LA = 1 + (L - 1)*KA
            LB = 1 + (IMIN - 1)*KB
            GO TO 20
   10    IMIN = 1
         LA = 1 + (J - 1)*KA
         LB = 1
C
   20    IMAX = MIN0(J, M)
         SUM = 0.D0
         DO 30 I = IMIN,IMAX
            SUM = SUM + A(LA)*B(LB)
            LA = LA - KA
            LB = LB + KB
   30    CONTINUE
         C(LC) = SUM
   40 LC = LC + KC
      IF (JMAX .EQ. N) RETURN
C
      JMIN = JMAX + 1
      DO 60 J = JMIN,N
         C(LC) = 0.D0
   60 LC = LC + KC
      RETURN
      END
      SUBROUTINE PDIV (A,KA,L,B,KB,M,C,KC,N,IERR)
C     ------------------------------------------------------------------
C     DIVISION OF REAL POLYNOMIALS
C     ------------------------------------------------------------------
      REAL A(*), B(*), C(*)
      DOUBLE PRECISION DSUM
C
      B0 = B(1)
      IF (B0 .EQ. 0.0) GO TO 100
      IERR = 0
      C(1) = A(1)/B0
      IF (N .EQ. 1) RETURN
C
C               CASE WHEN M = 1
C
      IF (M .GT. 1) GO TO 20
      LA = 1
      LC = 1
      DO 10 J = 2,N
         LA = LA + KA
         LC = LC + KC
         C(LC) = 0.0
         IF (J .LE. L) C(LC) = A(LA)/B0
   10 CONTINUE
      RETURN
C
C              CASE WHEN M .GT. 1
C
   20 LA = 1
      LC = 1
      DO 40 J = 2,N
         LA = LA + KA
         LC = LC + KC
         IB = 1
         IC = LC
         DSUM = 0.D0
         IF (J .LE. L) DSUM = A(LA)
         IMAX = MIN0(J, M)
         DO 30 I = 2,IMAX
            IB = IB + KB
            IC = IC - KC
            DSUM = DSUM - DBLE(B(IB))*DBLE(C(IC))
   30    CONTINUE
         C(LC) = SNGL(DSUM)/B0
   40 CONTINUE
      RETURN
C
C                ERROR RETURN
C
  100 IERR = 1
      RETURN
      END
      SUBROUTINE DPDIV (A,KA,L,B,KB,M,C,KC,N,IERR)
C     ------------------------------------------------------------------
C     DIVISION OF DOUBLE PRECISION POLYNOMIALS
C     ------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*), C(*)
      DOUBLE PRECISION B0, SUM
C
      B0 = B(1)
      IF (B0 .EQ. 0.D0) GO TO 100
      IERR = 0
      C(1) = A(1)/B0
      IF (N .EQ. 1) RETURN
C
C               CASE WHEN M = 1
C
      IF (M .GT. 1) GO TO 20
      LA = 1
      LC = 1
      DO 10 J = 2,N
         LA = LA + KA
         LC = LC + KC
         C(LC) = 0.D0
         IF (J .LE. L) C(LC) = A(LA)/B0
   10 CONTINUE
      RETURN
C
C              CASE WHEN M .GT. 1
C
   20 LA = 1
      LC = 1
      DO 40 J = 2,N
         LA = LA + KA
         LC = LC + KC
         IB = 1
         IC = LC
         SUM = 0.D0
         IF (J .LE. L) SUM = A(LA)
         IMAX = MIN0(J, M)
         DO 30 I = 2,IMAX
            IB = IB + KB
            IC = IC - KC
            SUM = SUM - B(IB)*C(IC)
   30    CONTINUE
         C(LC) = SUM/B0
   40 CONTINUE
      RETURN
C
C                ERROR RETURN
C
  100 IERR = 1
      RETURN
      END
      SUBROUTINE PLPWR(R,A,KA,M,B,KB,N,IERR)
C     ------------------------------------------------------------------
C     SET B = A**R WHERE A IS A REAL POLYNOMIAL
C     ------------------------------------------------------------------
      REAL A(*), B(*)
      REAL JM1
      DOUBLE PRECISION COEFF, DSUM, RP1
C
      A0 = A(1)
      IF (A0 .LE. 0.0) GO TO 100
      IERR = 0
      B(1) = A0**R
      IF (N .EQ. 1) RETURN
C
C            CASE WHEN M = 1 OR R = 0
C
      IF (M .GT. 1 .AND. R .NE. 0.0) GO TO 20
      LB = 1
      DO 10 J = 2,N
         LB = LB + KB
         B(LB) = 0.0
   10 CONTINUE
      RETURN
C
C                  GENERAL CASE
C
   20 RP1 = DBLE(R) + 1.D0
      LB = 1
      DO 40 J = 2,N
         LB = LB + KB
         JM1 = J - 1
         IA = 1
         IB = LB
         COEFF = -JM1
         DSUM = 0.D0
         IMAX = MIN0(J, M)
         DO 30 I = 2,IMAX
            IA = IA + KA
            IB = IB - KB
            COEFF = COEFF + RP1
            DSUM = DSUM + COEFF*DBLE(A(IA))*DBLE(B(IB))
   30    CONTINUE
         B(LB) = SNGL(DSUM)/(JM1*A0)
   40 CONTINUE
      RETURN
C
C                ERROR RETURN
C
  100 IERR = 1
      RETURN
      END
      SUBROUTINE DPLPWR(R,A,KA,M,B,KB,N,IERR)
C     ------------------------------------------------------------------
C     SET B = A**R WHERE A IS A DOUBLE PRECISION POLYNOMIAL
C     ------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*), R
      DOUBLE PRECISION A0, COEFF, JM1, RP1, SUM
C
      A0 = A(1)
      IF (A0 .LE. 0.D0) GO TO 100
      IERR = 0
      B(1) = A0**R
      IF (N .EQ. 1) RETURN
C
C            CASE WHEN M = 1 OR R = 0
C
      IF (M .GT. 1 .AND. R .NE. 0.D0) GO TO 20
      LB = 1
      DO 10 J = 2,N
         LB = LB + KB
         B(LB) = 0.D0
   10 CONTINUE
      RETURN
C
C                  GENERAL CASE
C
   20 RP1 = R + 1.D0
      LB = 1
      DO 40 J = 2,N
         LB = LB + KB
         JM1 = J - 1
         IA = 1
         IB = LB
         COEFF = -JM1
         SUM = 0.D0
         IMAX = MIN0(J, M)
         DO 30 I = 2,IMAX
            IA = IA + KA
            IB = IB - KB
            COEFF = COEFF + RP1
            SUM = SUM + COEFF*A(IA)*B(IB)
   30    CONTINUE
         B(LB) = SUM/(JM1*A0)
   40 CONTINUE
      RETURN
C
C                ERROR RETURN
C
  100 IERR = 1
      RETURN
      END
      SUBROUTINE PINV (A, D, N, Q)
C-----------------------------------------------------------------------
C          COMPUTATION OF THE INVERSE OF THE POWER SERIES
C                  SUM (A(I)*X**I, I = 1,2,...)
C-----------------------------------------------------------------------
      REAL A(N), D(N), Q(*)
C----------------------------
C     NUM = (N*(N + 1))/2
C     REAL Q(NUM)
C----------------------------
C
C                 COMPUTE THE COEFFICIENT MATRIX Q
C
      Q(1) = 1.0
      K = 2
      DO 10 I = 2,N
         Q(K) = 0.0
   10 K = K + I
C
      JJ = 1
      DO 22 J = 2,N
         L0 = JJ
         JJ = (J*(J + 1))/2
         K = JJ
         DO 21 I = J,N
            SUM = 0.0
            M = I - J + 2
            LL = L0
            DO 20 L = J,I
               SUM = SUM + A(M)*Q(LL)
               M = M - 1
               LL = LL + (L - 1)
   20       CONTINUE
            Q(K) = SUM
            K = K + I
   21    CONTINUE
   22 CONTINUE
C
C              COMPUTE THE COEFFICIENTS OF THE INVERSE
C
      K = 1
      DO 31 J = 1,N
         U = 1.0/(J*A(1)**J)
         SUM = 0.0
         DO 30 L = 1,J
            SUM = SUM + U*Q(K)
            S = L + J - 1
            T = L
            U = -(S*U)/(T*A(1))
            K = K + 1
   30    CONTINUE
         D(J) = SUM
   31 CONTINUE
      RETURN
      END
      SUBROUTINE DPINV (A, D, N, Q)
C-----------------------------------------------------------------------
C          COMPUTATION OF THE INVERSE OF THE POWER SERIES
C                  SUM (A(I)*X**I, I = 1,2,...)
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(N), D(N), Q(*)
      DOUBLE PRECISION S, SUM, T, U
C----------------------------
C     NUM = (N*(N + 1))/2
C     REAL Q(NUM)
C----------------------------
C
C                 COMPUTE THE COEFFICIENT MATRIX Q
C
      Q(1) = 1.D0
      K = 2
      DO 10 I = 2,N
         Q(K) = 0.D0
   10 K = K + I
C
      JJ = 1
      DO 22 J = 2,N
         L0 = JJ
         JJ = (J*(J + 1))/2
         K = JJ
         DO 21 I = J,N
            SUM = 0.D0
            M = I - J + 2
            LL = L0
            DO 20 L = J,I
               SUM = SUM + A(M)*Q(LL)
               M = M - 1
               LL = LL + (L - 1)
   20       CONTINUE
            Q(K) = SUM
            K = K + I
   21    CONTINUE
   22 CONTINUE
C
C              COMPUTE THE COEFFICIENTS OF THE INVERSE
C
      K = 1
      DO 31 J = 1,N
         U = 1.D0/(J*A(1)**J)
         SUM = 0.D0
         DO 30 L = 1,J
            SUM = SUM + U*Q(K)
            S = L + J - 1
            T = L
            U = -(S*U)/(T*A(1))
            K = K + 1
   30    CONTINUE
         D(J) = SUM
   31 CONTINUE
      RETURN
      END
      SUBROUTINE MPLNMV (MO, AU, NC, AC, FV)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR MULTIPLEX POLYNOMIAL EVALUATION
C     ******************************************************************
C     MO = MODE OF OPERATION
C     AU = ARGUMENT U
C     NC = NUMBER OF COEFFICIENTS
C     AC = ARRAY OF COEFFICIENTS
C     FV = FUNCTION V
C
C     MO = -1 FOR INTEGRAL
C     MO =  0 FOR FUNCTION
C     MO = +1 FOR FIRST DERIVATIVE
C     MO = +2 FOR SECOND DERIVATIVE
C
      DIMENSION AC(*)
  001 FV=0.0
      L=NC
      IF(MO.LT.0)GO TO 002
      IF(MO.EQ.0)GO TO 004
      IF(MO.EQ.1)GO TO 006
      IF(MO.GE.2)GO TO 008
  002 QL=NC
      DO 003 K=1,NC
      FV=AC(L)/QL+AU*FV
      L=L-1
      QL=QL-1.0
  003 CONTINUE
      FV=AU*FV
      RETURN
  004 DO 005 K=1,NC
      FV=AC(L)+AU*FV
      L=L-1
  005 CONTINUE
      RETURN
  006 IF(NC.LE.1)RETURN
      QL=NC
      DO 007 K=2,NC
      QL=QL-1.0
      FV=QL*AC(L)+AU*FV
      L=L-1
  007 CONTINUE
      RETURN
  008 IF(NC.LE.2)RETURN
      QL=NC
      DO 009 K=3,NC
      QL=QL-1.0
      FV=QL*(QL-1.0)*AC(L)+AU*FV
      L=L-1
  009 CONTINUE
      RETURN
      END
      REAL FUNCTION CSEVL (X, A, N)
C-----------------------------------------------------------------------
C          EVALUATE THE N TERM CHEBYSHEV SERIES A AT X.
C          ONLY HALF OF THE FIRST COEFFICIENT IS USED.
C-----------------------------------------------------------------------
      REAL A(N)
C
      IF (N .GT. 1) GO TO 10
         CSEVL = 0.5 * A(1)
         RETURN
C
   10 X2 = X + X
      S0 = A(N)
      S1 = 0.0
      DO 20 I = 2,N
         S2 = S1
         S1 = S0
         K = N - I + 1
         S0 = X2*S1 - S2 + A(K)
   20 CONTINUE
      CSEVL = 0.5 * (S0 - S2)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DCSEVL (X, A, N)
C-----------------------------------------------------------------------
C          EVALUATE THE N TERM CHEBYSHEV SERIES A AT X.
C          ONLY HALF OF THE FIRST COEFFICIENT IS USED.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(N),X,X2,S0,S1,S2
C
      IF (N .GT. 1) GO TO 10
         DCSEVL = 0.5D0 * A(1)
         RETURN
C
   10 X2 = X + X
      S0 = A(N)
      S1 = 0.D0
      DO 20 I = 2,N
         S2 = S1
         S1 = S0
         K = N - I + 1
         S0 = X2*S1 - S2 + A(K)
   20 CONTINUE
      DCSEVL = 0.5D0 * (S0 - S2)
      RETURN
      END
      SUBROUTINE LGRNGN (AU, NA, AN)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR LAGRANGIAN NORMALIZATION FACTORS
C     ******************************************************************
C     AU = COORDINATE ARGUMENTS  (N-ARRAY)
C     NA = NUMBER OF ARGUMENTS   (N)
C     AN = NORMALIZATION FACTORS (N-ARRAY)
C
      DIMENSION AU(*), AN(*)
  001 DO 003 K=1,NA
      TM=1.0
      DO 002 M=1,NA
      IF(M.EQ.K)GO TO 002
      DM=AU(K)-AU(M)
      TM=DM*TM
  002 CONTINUE
      AN(K)=TM
  003 CONTINUE
      RETURN
      END
      SUBROUTINE LGRNGV (MO, NA, QU, AU, AN, FF, DF, SF)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR LAGRANGIAN FUNCTION EVALUATION
C     ******************************************************************
C     MO = MODE OF OPERATION
C     NA = NUMBER OF STATIONS
C     QU = ARGUMENT OF FUNCTIONS
C     AU = STATION COORDINATES                    (N-ARRAY)
C     AN = NORMALIZATION FACTORS                  (N-ARRAY)
C     FF = LAGRANGIAN FUNCTIONS                   (N-ARRAY)
C     DF = FIRST DERIVATIVES                      (N-ARRAY)
C     SF = SECOND DERIVATIVES                     (N-ARRAY)
C
C     CALL LGRNGV (0, NA, QU, AU, AN, FF)         FOR FUNCTIONS
C     CALL LGRNGV (1, NA, QU, AU, AN, FF, DF)     FOR FIRST DERIVATIVES
C     CALL LGRNGV (2, NA, QU, AU, AN, FF, DF, SF) FOR SECOND DERIVATIVES
C
      DIMENSION AU(*), AN(*), FF(*), DF(*), SF(*)
      LOGICAL LN
  001 LN=.TRUE.
      TM=1.0
      DO 003 K=1,NA
      IF(QU.NE.AU(K))GO TO 002
      LN=.FALSE.
      GO TO 003
  002 DM=QU-AU(K)
      TM=DM*TM
  003 CONTINUE
      DO 007 K=1,NA
      IF(LN)GO TO 005
      IF(QU.NE.AU(K))GO TO 005
      FF(K)=TM
      GO TO 006
  005 DM=QU-AU(K)
      FF(K)=TM/DM
  006 FF(K)=FF(K)/AN(K)
  007 CONTINUE
      IF(MO.LE.0)GO TO 050
      SM=0.0
      DO 013 K=1,NA
      DF(K)=SM
      IF(LN)GO TO 012
      IF(QU.EQ.AU(K))GO TO 013
  012 DM=QU-AU(K)
      SM=SM+1.0/DM
  013 CONTINUE
      RM=SM
      IF(MO.EQ.1)GO TO 040
      SM=0.0
      DO 023 K=1,NA
      SF(K)=SM
      IF(LN)GO TO 022
      IF(QU.EQ.AU(K))GO TO 023
  022 DM=QU-AU(K)
      SM=SM+2.0*DF(K)/DM
  023 CONTINUE
      SM=0.0
      TM=0.0
      L=NA
      IF(LN)GO TO 034
      DO 033 K=1,NA
      SF(L)=TM+SF(L)+2.0*SM*DF(L)
      IF(QU.EQ.AU(L))GO TO 032
      SF(L)=2.0*(SM+DF(L))
      DM=QU-AU(L)
      TM=TM+2.0*SM/DM
      SM=SM+1.0/DM
  032 L=L-1
  033 CONTINUE
      GO TO 036
  034 DO 035 K=1,NA
      SF(L)=TM+SF(L)+2.0*SM*DF(L)
      DM=QU-AU(L)
      TM=TM+2.0*SM/DM
      SM=SM+1.0/DM
      L=L-1
  035 CONTINUE
  036 DO 037 K=1,NA
      SF(K)=FF(K)*SF(K)
  037 CONTINUE
  040 IF (LN) GO TO 043
      DO 042 K=1,NA
      IF (QU.NE.AU(K)) GO TO 041
      DF(K)=RM
      FF(K)=1.0
      GO TO 042
  041 DF(K)=FF(K)
      FF(K)=0.0
  042 CONTINUE
      RETURN
  043 SM=0.0
      L=NA
      DO 044 K=1,NA
      DF(L)=FF(L)*(SM+DF(L))
      SM=SM+1.0/(QU-AU(L))
      L=L-1
  044 CONTINUE
      RETURN
  050 IF(LN)GO TO 053
      DO 052 K=1,NA
      FF(K)=0.0
      IF(QU.NE.AU(K))GO TO 052
      FF(K)=1.0
  052 CONTINUE
  053 RETURN
      END
      SUBROUTINE LGRNGX (AU, NA, AC)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR LAGRANGIAN POLYNOMIAL EXPANSION
C     ******************************************************************
C     AU = COORDINATE ARGUMENTS    (N-ARRAY)
C     NA = NUMBER OF ARGUMENTS     (N)
C     AC = POLYNOMIAL COEFFICIENTS (NX(N+1) ARRAY)
C
      DIMENSION AU(*), AC(*)
  001 DO 003 I=1,NA
      K=(I-1)*NA
      L=K+I
      AC(L)=1.0
      SM=0.0
      DO 002 J=1,I
      K=K+1
      L=K+NA
      AC(L)=SM-AU(I)*AC(K)
      SM=AC(K)
  002 CONTINUE
  003 CONTINUE
      DO 005 I=1,NA
      K=NA+NA*NA
      L=I*NA
      AC(L)=1.0
      DO 004 J=2,NA
      SM=AU(I)*AC(L)
      L=L-1
      AC(L)=SM+AC(K)
      K=K-1
  004 CONTINUE
  005 CONTINUE
      DO 008 I=1,NA
      TM=1.0
      DO 006 J=1,NA
      IF(J.EQ.I)GO TO 006
      TD=AU(I)-AU(J)
      TM=TM*TD
  006 CONTINUE
      K=(I-1)*NA
      DO 007 J=1,NA
      K=K+1
      AC(K)=AC(K)/TM
  007 CONTINUE
  008 CONTINUE
      RETURN
      END
      SUBROUTINE ORTHOS (AU, MA, AA, NA, AR)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR ORTHONORMAL POLYNOMIAL SYNTHESIS
C     ******************************************************************
C     AU = COORDINATE ARGUMENTS    (N ARRAY)
C     MA = NUMBER OF COLUMNS       (M)
C     AA = MATRIX OF POLYNOMIALS   (NXM ARRAY)
C     NA = NUMBER OF ROWS          (N)
C     AR = RECURRENCE COEFFICIENTS (2*M-2 ARRAY)
C
      DIMENSION AU(*), AA(*), AR(*)
  001 SN=NA
      RN=SQRT(SN)
      DO 002 I=1,NA
      AA(I)=1.0/RN
  002 CONTINUE
      IF(MA.EQ.1)RETURN
  003 SM=0.0
      DO 004 I=1,NA
      SM=SM+AU(I)
  004 CONTINUE
      AR(2)=SM/SN
      SM=0.0
      L=NA
      DO 005 I=1,NA
      L=L+1
      AA(L)=AU(I)-AR(2)
      SM=SM+AA(L)*AA(L)
  005 CONTINUE
      RM=SQRT(SM)
      L=NA
      DO 006 I=1,NA
      L=L+1
      AA(L)=AA(L)/RM
  006 CONTINUE
      SM=0.0
      L=NA
      DO 007 I=1,NA
      L=L+1
      SM=SM+AU(I)*AA(L)
  007 CONTINUE
      AR(1)=SM/RN
      IF(MA.EQ.2)RETURN
  008 DO 013 M=3,MA
      SM=0.0
      K=(M-2)*NA
      DO 009 I=1,NA
      K=K+1
      SM=SM+AU(I)*AA(K)*AA(K)
  009 CONTINUE
      AR(2*M-2)=SM
      SM=0.0
      J=(M-3)*NA
      DO 010 I=1,NA
      J=J+1
      K=J+NA
      L=K+NA
      AA(L)=AU(I)*AA(K)-AR(2*M-2)*AA(K)-AR(2*M-5)*AA(J)
      SM=SM+AA(L)*AA(L)
  010 CONTINUE
      RM=SQRT(SM)
      L=(M-1)*NA
      DO 011 I=1,NA
      L=L+1
      AA(L)=AA(L)/RM
  011 CONTINUE
      SM=0.0
      K=(M-2)*NA
      DO 012 I=1,NA
      K=K+1
      L=K+NA
      SM=SM+AU(I)*AA(K)*AA(L)
  012 CONTINUE
      AR(2*M-3)=SM
  013 CONTINUE
      RETURN
      END
      SUBROUTINE ORTHOV (MO, NA, AU, AR, NF, FF, DF, SF)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR ORTHONORMAL POLYNOMIAL EVALUATION
C     ******************************************************************
C     MO = MODE OF OPERATION
C     NA = NUMBER OF COORDINATES
C     AU = ARGUMENT OF FUNCTIONS
C     AR = RECURRENCE COEFFICIENTS                (2*M-2 ARRAY)
C     NF = NUMBER OF FUNCTIONS                    (M)
C     FF = ORTHONORMAL FUNCTIONS                  (M-ARRAY)
C     DF = FIRST DERIVATIVES                      (M-ARRAY)
C     SF = SECOND DERIVATIVES                     (M-ARRAY)
C
C     CALL ORTHOV (0, NA, AU, AR, NF, FF)         FOR FUNCTIONS
C     CALL ORTHOV (1, NA, AU, AR, NF, FF, DF)     FOR FIRST DERIVATIVES
C     CALL ORTHOV (2, NA, AU, AR, NF, FF, DF, SF) FOR SECOND DERIVATIVES
C
      DIMENSION AR(*), FF(*), DF(*), SF(*)
  001 SN=NA
      RN=SQRT(SN)
      FF(1)=1.0/RN
      IF(NF.LE.1)GO TO 003
      FF(2)=(AU-AR(2))*FF(1)/AR(1)
      IF(NF.EQ.2)GO TO 003
      L=2
      DO 002 K=3,NF
      L=L+2
      FF(K)=((AU-AR(L))*FF(K-1)-AR(L-3)*FF(K-2))/AR(L-1)
  002 CONTINUE
  003 IF(MO.LE.0)RETURN
      DF(1)=0.0
      IF(NF.LE.1)GO TO 005
      DF(2)=FF(1)/AR(1)
      IF(NF.EQ.2)GO TO 005
      L=2
      DO 004 K=3,NF
      L=L+2
      DF(K)=(FF(K-1)+(AU-AR(L))*DF(K-1)-AR(L-3)*DF(K-2))/AR(L-1)
  004 CONTINUE
  005 IF(MO.EQ.1)RETURN
      SF(1)=0.0
      IF(NF.LE.1)GO TO 007
      SF(2)=0.0
      IF(NF.EQ.2)GO TO 007
      L=2
      DO 006 K=3,NF
      L=L+2
      SF(K)=(2.0*DF(K-1)+(AU-AR(L))*SF(K-1)-AR(L-3)*SF(K-2))/AR(L-1)
  006 CONTINUE
  007 RETURN
      END
      SUBROUTINE ORTHOX (NA, AR, NC, AC)
C     ******************************************************************
C     FORTRAN SUBROUTINE FOR ORTHONORMAL POLYNOMIAL EXPANSION
C     ******************************************************************
C     NA = NUMBER OF ARGUMENTS     (N)
C     AR = RECURRENCE COEFFICIENTS (2*M-2 ARRAY)
C     NC = NUMBER OF COEFFICIENTS  (M)
C     AC = POLYNOMIAL COEFFICIENTS (M*M ARRAY)
C
      DIMENSION AR(*), AC(*)
  001 DO 002 N=1,NC
      AC(N)=0.0
  002 CONTINUE
      SN=NA
      RN=SQRT(SN)
      AC(1)=1.0/RN
      IF(NC.EQ.1)RETURN
  003 TM=0.0
      L=NC
      DO 004 N=1,NC
      L=L+1
      AC(L)=(TM-AR(2)*AC(N))/AR(1)
      TM=AC(N)
  004 CONTINUE
      IF(NC.EQ.2)RETURN
  005 DO 007 M=3,NC
      TM=0.0
      J=(M-3)*NC
      DO 006 N=1,NC
      J=J+1
      K=J+NC
      L=K+NC
      AC(L)=(TM-AR(2*M-2)*AC(K)-AR(2*M-5)*AC(J))/AR(2*M-3)
      TM=AC(K)
  006 CONTINUE
  007 CONTINUE
      RETURN
      END
      REAL FUNCTION ZEROIN (F, AX, BX, AERR, RERR)
C-----------------------------------------------------------------------
C
C         FINDING A ZERO OF THE FUNCTION F(X) IN THE INTERVAL (AX,BX)
C
C                       ------------------------
C
C  INPUT...
C
C  F      FUNCTION SUBPROGRAM WHICH EVALUATES F(X) FOR ANY X IN THE
C         CLOSED INTERVAL (AX,BX). IT IS ASSUMED THAT F IS CONTINUOUS,
C         AND THAT F(AX) AND F(BX) HAVE DIFFERENT SIGNS.
C  AX     LEFT ENDPOINT OF THE INTERVAL
C  BX     RIGHT ENDPOINT OF THE INTERVAL
C  AERR   THE ABSOLUTE ERROR TOLERANCE TO BE SATISFIED
C  RERR   THE RELATIVE ERROR TOLERANCE TO BE SATISFIED
C
C  OUTPUT...
C
C         ABCISSA APPROXIMATING A ZERO OF F IN THE INTERVAL (AX,BX)
C
C-----------------------------------------------------------------------
C  ZEROIN IS A SLIGHTLY MODIFIED TRANSLATION OF THE ALGOL PROCEDURE
C  ZERO GIVEN BY RICHARD BRENT IN ALGORITHMS FOR MINIMIZATION WITHOUT
C  DERIVATIVES, PRENTICE-HALL, INC. (1973).
C-----------------------------------------------------------------------
      REAL F, AX, BX, AERR, RERR
      EXTERNAL F
      REAL A,B,C,D,E,EPS,FA,FB,FC,TOL,XM,P,Q,R,S,ATOL,RTOL
      REAL SPMPAR
C
C  COMPUTE EPS, THE RELATIVE MACHINE PRECISION
C
      EPS = SPMPAR(1)
C
C INITIALIZATION
C
      A = AX
      B = BX
      FA = F(A)
      FB = F(B)
      ATOL = 0.5*AERR
      RTOL = AMAX1(0.5*RERR,2.0*EPS)
C
C BEGIN STEP
C
   10 C = A
      FC = FA
      D = B - A
      E = D
   20 IF (ABS(FC) .GE. ABS(FB)) GO TO 40
      A = B
      B = C
      C = A
      FA = FB
      FB = FC
      FC = FA
C
C CONVERGENCE TEST
C
   40 TOL = RTOL*AMAX1(ABS(B),ABS(C)) + ATOL
      XM = 0.5*(C - B)
      IF (ABS(XM) .LE. TOL) GO TO 90
      IF (FB .EQ. 0.0) GO TO 90
C
C IS BISECTION NECESSARY
C
      IF (ABS(E) .LT. TOL) GO TO 70
      IF (ABS(FA) .LE. ABS(FB)) GO TO 70
C
C IS QUADRATIC INTERPOLATION POSSIBLE
C
      IF (A .NE. C) GO TO 50
C
C LINEAR INTERPOLATION
C
      S = FB/FC
      P = (C - B)*S
      Q = 1.0 - S
      GO TO 60
C
C INVERSE QUADRATIC INTERPOLATION
C
   50 Q = FA/FC
      R = FB/FC
      S = FB/FA
      P = S*((C - B)*Q*(Q - R) - (B - A)*(R - 1.0))
      Q = (Q - 1.0)*(R - 1.0)*(S - 1.0)
C
C ADJUST SIGNS
C
   60 IF (P .GT. 0.0) Q = -Q
      P = ABS(P)
C
C IS INTERPOLATION ACCEPTABLE
C
      IF (2.0*P .GE. (3.0*XM*Q - ABS(TOL*Q))) GO TO 70
      IF (P .GE. ABS(0.5*E*Q)) GO TO 70
      E = D
      D = P/Q
      GO TO 80
C
C BISECTION
C
   70 D = XM
      E = D
C
C COMPLETE STEP
C
   80 A = B
      FA = FB
      IF (ABS(D) .GT. TOL) B = B + D
      IF (ABS(D) .LE. TOL) B = B + SIGN(TOL,XM)
      FB = F(B)
      IF ((FB*(FC/ABS(FC))) .GT. 0.0) GO TO 10
      GO TO 20
C
C DONE
C
   90 ZEROIN = B
      RETURN
      END
      DOUBLE PRECISION FUNCTION DZERO (F, AX, BX, AERR, RERR)
C-----------------------------------------------------------------------
C
C         FINDING A ZERO OF THE FUNCTION F(X) IN THE INTERVAL (AX,BX)
C
C                       ------------------------
C
C  INPUT...
C
C  F      FUNCTION SUBPROGRAM WHICH EVALUATES F(X) FOR ANY X IN THE
C         CLOSED INTERVAL (AX,BX). IT IS ASSUMED THAT F IS CONTINUOUS,
C         AND THAT F(AX) AND F(BX) HAVE DIFFERENT SIGNS.
C  AX     LEFT ENDPOINT OF THE INTERVAL
C  BX     RIGHT ENDPOINT OF THE INTERVAL
C  AERR   THE ABSOLUTE ERROR TOLERANCE TO BE SATISFIED
C  RERR   THE RELATIVE ERROR TOLERANCE TO BE SATISFIED
C
C  OUTPUT...
C
C         ABCISSA APPROXIMATING A ZERO OF F IN THE INTERVAL (AX,BX)
C
C-----------------------------------------------------------------------
C  DZERO IS A SLIGHTLY MODIFIED TRANSLATION OF THE ALGOL PROCEDURE
C  ZERO GIVEN BY RICHARD BRENT IN ALGORITHMS FOR MINIMIZATION WITHOUT
C  DERIVATIVES, PRENTICE-HALL, INC. (1973).
C-----------------------------------------------------------------------
      DOUBLE PRECISION F, AX, BX, AERR, RERR
      EXTERNAL F
      DOUBLE PRECISION A,B,C,D,E,EPS,FA,FB,FC,TOL,XM,P,Q,R,S,ATOL,RTOL
      DOUBLE PRECISION DPMPAR
C
C  COMPUTE EPS, THE RELATIVE MACHINE PRECISION
C
      EPS = DPMPAR(1)
C
C INITIALIZATION
C
      A = AX
      B = BX
      FA = F(A)
      FB = F(B)
      ATOL = 0.5D0*AERR
      RTOL = DMAX1(0.5D0*RERR,2.D0*EPS)
C
C BEGIN STEP
C
   10 C = A
      FC = FA
      D = B - A
      E = D
   20 IF (DABS(FC) .GE. DABS(FB)) GO TO 40
      A = B
      B = C
      C = A
      FA = FB
      FB = FC
      FC = FA
C
C CONVERGENCE TEST
C
   40 TOL = RTOL*DMAX1(DABS(B),DABS(C)) + ATOL
      XM = 0.5D0*(C - B)
      IF (DABS(XM) .LE. TOL) GO TO 90
      IF (FB .EQ. 0.D0) GO TO 90
C
C IS BISECTION NECESSARY
C
      IF (DABS(E) .LT. TOL) GO TO 70
      IF (DABS(FA) .LE. DABS(FB)) GO TO 70
C
C IS QUADRATIC INTERPOLATION POSSIBLE
C
      IF (A .NE. C) GO TO 50
C
C LINEAR INTERPOLATION
C
      S = FB/FC
      P = (C - B)*S
      Q = 1.D0 - S
      GO TO 60
C
C INVERSE QUADRATIC INTERPOLATION
C
   50 Q = FA/FC
      R = FB/FC
      S = FB/FA
      P = S*((C - B)*Q*(Q - R) - (B - A)*(R - 1.D0))
      Q = (Q - 1.D0)*(R - 1.D0)*(S - 1.D0)
C
C ADJUST SIGNS
C
   60 IF (P .GT. 0.D0) Q = -Q
      P = DABS(P)
C
C IS INTERPOLATION ACCEPTABLE
C
      IF (2.D0*P .GE. (3.D0*XM*Q - DABS(TOL*Q))) GO TO 70
      IF (P .GE. DABS(0.5D0*E*Q)) GO TO 70
      E = D
      D = P/Q
      GO TO 80
C
C BISECTION
C
   70 D = XM
      E = D
C
C COMPLETE STEP
C
   80 A = B
      FA = FB
      IF (DABS(D) .GT. TOL) B = B + D
      IF (DABS(D) .LE. TOL) B = B + DSIGN(TOL,XM)
      FB = F(B)
      IF ((FB*(FC/DABS(FC))) .GT. 0.D0) GO TO 10
      GO TO 20
C
C DONE
C
   90 DZERO = B
      RETURN
      END
      SUBROUTINE HBRD(FCN,N,X,FVEC,EPSFCN,TOL,INFO,WA,LWA)
      INTEGER N,INFO,LWA
      REAL EPSFCN,TOL
      REAL X(N),FVEC(N),WA(LWA)
      EXTERNAL FCN
C     **********
C
C     SUBROUTINE HBRD
C
C       THE PURPOSE OF HBRD IS TO FIND A ZERO OF A SYSTEM OF
C     N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION
C     OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE
C     MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD. THE USER
C     MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS.
C     THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE
C     APPROXIMATION.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE HBRD(FCN,N,X,FVEC,EPSFCN,TOL,INFO,WA,LWA)
C
C     WHERE
C
C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
C         CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
C         IN AN EXTERNAL STATEMENT IN THE USER CALLING
C         PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
C
C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
C         INTEGER N,IFLAG
C         REAL X(N),FVEC(N)
C         ----------
C         CALCULATE THE FUNCTIONS AT X AND
C         RETURN THIS VECTOR IN FVEC.
C         ---------
C         RETURN
C         END
C
C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
C         THE USER WANTS TO TERMINATE THE EXECUTION OF HBRD.
C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF FUNCTIONS AND VARIABLES.
C
C       X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
C         AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
C         CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
C
C       FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
C         THE FUNCTIONS EVALUATED AT THE OUTPUT X.
C
C       EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
C         STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
C         APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
C         FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
C         THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
C         ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
C         PRECISION.
C
C       TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
C         WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
C         BETWEEN X AND THE SOLUTION IS AT MOST TOL.
C
C       INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
C         TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
C         VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
C         INFO IS SET AS FOLLOWS.
C
C         INFO = 0   IMPROPER INPUT PARAMETERS.
C
C         INFO = 1   ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
C                    BETWEEN X AND THE SOLUTION IS AT MOST TOL.
C
C         INFO = 2   NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED
C                    200*(N+1).
C
C         INFO = 3   TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
C                    THE APPROXIMATE SOLUTION X IS POSSIBLE.
C
C         INFO = 4   ITERATION IS NOT MAKING GOOD PROGRESS.
C
C       WA IS A WORK ARRAY OF LENGTH LWA.
C
C       LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
C         (N*(3*N+13))/2.
C
C     SUBPROGRAMS CALLED
C
C       USER-SUPPLIED ...... FCN
C
C       MINPACK-SUPPLIED ... HYBRD
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NPRINT
      REAL FACTOR,ONE,XTOL,ZERO
      DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/
      INFO = 0
C
C     CHECK THE INPUT PARAMETERS FOR ERRORS.
C
      IF (N .LE. 0 .OR. EPSFCN .LT. ZERO .OR. TOL .LT. ZERO .OR.
     *   LWA .LT. (N*(3*N + 13))/2) GO TO 20
C
C     CALL HYBRD.
C
      MAXFEV = 200*(N + 1)
      XTOL = TOL
      ML = N - 1
      MU = N - 1
      MODE = 2
      DO 10 J = 1, N
         WA(J) = ONE
   10    CONTINUE
      NPRINT = 0
      LR = (N*(N + 1))/2
      INDEX = 6*N + LR
      CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,WA(1),MODE,
     *           FACTOR,NPRINT,INFO,NFEV,WA(INDEX+1),N,WA(6*N+1),LR,
     *           WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
      IF (INFO .EQ. 5) INFO = 4
   20 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE HBRD.
C
      END
      SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG,
     *                 MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,R,LR,
     *                 QTF,WA1,WA2,WA3,WA4)
      INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR
      REAL XTOL,EPSFCN,FACTOR
      REAL X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N),WA1(N),
     *     WA2(N),WA3(N),WA4(N)
      EXTERNAL FCN
C     **********
C
C     SUBROUTINE HYBRD
C
C     THE PURPOSE OF HYBRD IS TO FIND A ZERO OF A SYSTEM OF
C     N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION
C     OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A
C     SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS
C     THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,
C                        DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,
C                        LDFJAC,R,LR,QTF,WA1,WA2,WA3,WA4)
C
C     WHERE
C
C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
C         CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
C         IN AN EXTERNAL STATEMENT IN THE USER CALLING
C         PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
C
C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
C         INTEGER N,IFLAG
C         REAL X(N),FVEC(N)
C         ----------
C         CALCULATE THE FUNCTIONS AT X AND
C         RETURN THIS VECTOR IN FVEC.
C         ---------
C         RETURN
C         END
C
C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
C         THE USER WANTS TO TERMINATE EXECUTION OF HYBRD.
C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF FUNCTIONS AND VARIABLES.
C
C       X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
C         AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
C         CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
C
C       FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
C         THE FUNCTIONS EVALUATED AT THE OUTPUT X.
C
C       XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
C         OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
C         ITERATES IS AT MOST XTOL.
C
C       MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION
C         OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV
C         BY THE END OF AN ITERATION.
C
C       ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
C         THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE
C         JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
C         ML TO AT LEAST N - 1.
C
C       MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
C         THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE
C         JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
C         MU TO AT LEAST N - 1.
C
C       EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
C         STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
C         APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
C         FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
C         THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
C         ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
C         PRECISION.
C
C       DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
C         BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
C         MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
C         MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
C
C       MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
C         VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
C         THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
C         VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
C
C       FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
C         INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
C         FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
C         TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
C         INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
C
C       NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
C         PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
C         FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST
C         ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND
C         IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE
C         FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS
C         OF FCN WITH IFLAG = 0 ARE MADE.
C
C       INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
C         TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
C         VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
C         INFO IS SET AS FOLLOWS.
C
C         INFO = 0   IMPROPER INPUT PARAMETERS.
C
C         INFO = 1   RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
C                    IS AT MOST XTOL.
C
C         INFO = 2   NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED
C                    MAXFEV.
C
C         INFO = 3   XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
C                    THE APPROXIMATE SOLUTION X IS POSSIBLE.
C
C         INFO = 4   ITERATION IS NOT MAKING GOOD PROGRESS, AS
C                    MEASURED BY THE IMPROVEMENT FROM THE LAST
C                    FIVE JACOBIAN EVALUATIONS.
C
C         INFO = 5   ITERATION IS NOT MAKING GOOD PROGRESS, AS
C                    MEASURED BY THE IMPROVEMENT FROM THE LAST
C                    TEN ITERATIONS.
C
C       NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
C         CALLS TO FCN.
C
C       FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
C         ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION
C         OF THE FINAL APPROXIMATE JACOBIAN.
C
C       LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
C
C       R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE
C         UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION
C         OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE.
C
C       LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
C         (N*(N+1))/2.
C
C       QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
C         THE VECTOR (Q TRANSPOSE)*FVEC.
C
C       WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N.
C
C     SUBPROGRAMS CALLED
C
C       USER-SUPPLIED ...... FCN
C
C       MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM,FDJAC1,
C                            QFORM,QRFAC,R1MPYQ,R1UPDT
C
C       FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,MIN0,MOD
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,IFLAG,ITER,J,JM1,L,MSUM,NCFAIL,NCSUC,NSLOW1,NSLOW2
      INTEGER IWA(1)
      LOGICAL JEVAL,SING
      REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5,
     *     P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO
      REAL SPMPAR,ENORM
      DATA ONE,P1,P5,P001,P0001,ZERO
     *     /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/
C
C     EPSMCH IS THE MACHINE PRECISION.
C
      EPSMCH = SPMPAR(1)
C
      INFO = 0
      IFLAG = 0
      NFEV = 0
C
C     CHECK THE INPUT PARAMETERS FOR ERRORS.
C
      IF (N .LE. 0 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0
     *    .OR. ML .LT. 0 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO
     *    .OR. LDFJAC .LT. N .OR. LR .LT. (N*(N + 1))/2) GO TO 300
      IF (MODE .NE. 2) GO TO 20
      DO 10 J = 1, N
         IF (DIAG(J) .LE. ZERO) GO TO 300
   10    CONTINUE
   20 CONTINUE
C
C     EVALUATE THE FUNCTION AT THE STARTING POINT
C     AND CALCULATE ITS NORM.
C
      IFLAG = 1
      CALL FCN(N,X,FVEC,IFLAG)
      NFEV = 1
      IF (IFLAG .LT. 0) GO TO 300
      FNORM = ENORM(N,FVEC)
C
C     DETERMINE THE NUMBER OF CALLS TO FCN NEEDED TO COMPUTE
C     THE JACOBIAN MATRIX.
C
      MSUM = MIN0(ML+MU+1,N)
C
C     INITIALIZE ITERATION COUNTER AND MONITORS.
C
      ITER = 1
      NCSUC = 0
      NCFAIL = 0
      NSLOW1 = 0
      NSLOW2 = 0
C
C     BEGINNING OF THE OUTER LOOP.
C
   30 CONTINUE
         JEVAL = .TRUE.
C
C        CALCULATE THE JACOBIAN MATRIX.
C
         IFLAG = 2
         CALL FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1,
     *               WA2)
         NFEV = NFEV + MSUM
         IF (IFLAG .LT. 0) GO TO 300
C
C        COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
C
         CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3)
C
C        ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
C        TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
C
         IF (ITER .NE. 1) GO TO 70
         IF (MODE .EQ. 2) GO TO 50
         DO 40 J = 1, N
            DIAG(J) = WA2(J)
            IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE
   40       CONTINUE
   50    CONTINUE
C
C        ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
C        AND INITIALIZE THE STEP BOUND DELTA.
C
         DO 60 J = 1, N
            WA3(J) = DIAG(J)*X(J)
   60       CONTINUE
         XNORM = ENORM(N,WA3)
         DELTA = FACTOR*XNORM
         IF (DELTA .EQ. ZERO) DELTA = FACTOR
   70    CONTINUE
C
C        FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF.
C
         DO 80 I = 1, N
            QTF(I) = FVEC(I)
   80       CONTINUE
         DO 120 J = 1, N
            IF (FJAC(J,J) .EQ. ZERO) GO TO 110
            SUM = ZERO
            DO 90 I = J, N
               SUM = SUM + FJAC(I,J)*QTF(I)
   90          CONTINUE
            TEMP = -SUM/FJAC(J,J)
            DO 100 I = J, N
               QTF(I) = QTF(I) + FJAC(I,J)*TEMP
  100          CONTINUE
  110       CONTINUE
  120       CONTINUE
C
C        COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R.
C
         SING = .FALSE.
         DO 150 J = 1, N
            L = J
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 140
            DO 130 I = 1, JM1
               R(L) = FJAC(I,J)
               L = L + N - I
  130          CONTINUE
  140       CONTINUE
            R(L) = WA1(J)
            IF (WA1(J) .EQ. ZERO) SING = .TRUE.
  150       CONTINUE
C
C        ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC.
C
         CALL QFORM(N,N,FJAC,LDFJAC,WA1)
C
C        RESCALE IF NECESSARY.
C
         IF (MODE .EQ. 2) GO TO 170
         DO 160 J = 1, N
            DIAG(J) = AMAX1(DIAG(J),WA2(J))
  160       CONTINUE
  170    CONTINUE
C
C        BEGINNING OF THE INNER LOOP.
C
  180    CONTINUE
C
C           IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
C
            IF (NPRINT .LE. 0) GO TO 190
            IFLAG = 0
            IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG)
            IF (IFLAG .LT. 0) GO TO 300
  190       CONTINUE
C
C           DETERMINE THE DIRECTION P.
C
            CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3)
C
C           STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
C
            DO 200 J = 1, N
               WA1(J) = -WA1(J)
               WA2(J) = X(J) + WA1(J)
               WA3(J) = DIAG(J)*WA1(J)
  200          CONTINUE
            PNORM = ENORM(N,WA3)
C
C           ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
C
            IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM)
C
C           EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
C
            IFLAG = 1
            CALL FCN(N,WA2,WA4,IFLAG)
            NFEV = NFEV + 1
            IF (IFLAG .LT. 0) GO TO 300
            FNORM1 = ENORM(N,WA4)
C
C           COMPUTE THE SCALED ACTUAL REDUCTION.
C
            ACTRED = -ONE
            IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2
C
C           COMPUTE THE SCALED PREDICTED REDUCTION.
C
            L = 1
            DO 220 I = 1, N
               SUM = ZERO
               DO 210 J = I, N
                  SUM = SUM + R(L)*WA1(J)
                  L = L + 1
  210             CONTINUE
               WA3(I) = QTF(I) + SUM
  220          CONTINUE
            TEMP = ENORM(N,WA3)
            PRERED = ZERO
            IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2
C
C           COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
C           REDUCTION.
C
            RATIO = ZERO
            IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED
C
C           UPDATE THE STEP BOUND.
C
            IF (RATIO .GE. P1) GO TO 230
               NCSUC = 0
               NCFAIL = NCFAIL + 1
               DELTA = P5*DELTA
               GO TO 240
  230       CONTINUE
               NCFAIL = 0
               NCSUC = NCSUC + 1
               IF (RATIO .GE. P5 .OR. NCSUC .GT. 1)
     *            DELTA = AMAX1(DELTA,PNORM/P5)
               IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5
  240       CONTINUE
C
C           TEST FOR SUCCESSFUL ITERATION.
C
            IF (RATIO .LT. P0001) GO TO 260
C
C           SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
C
            DO 250 J = 1, N
               X(J) = WA2(J)
               WA2(J) = DIAG(J)*X(J)
               FVEC(J) = WA4(J)
  250          CONTINUE
            XNORM = ENORM(N,WA2)
            FNORM = FNORM1
            ITER = ITER + 1
  260       CONTINUE
C
C           DETERMINE THE PROGRESS OF THE ITERATION.
C
            NSLOW1 = NSLOW1 + 1
            IF (ACTRED .GE. P001) NSLOW1 = 0
            IF (JEVAL) NSLOW2 = NSLOW2 + 1
            IF (ACTRED .GE. P1) NSLOW2 = 0
C
C           TEST FOR CONVERGENCE.
C
            IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1
            IF (INFO .NE. 0) GO TO 300
C
C           TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
C
            IF (NFEV .GE. MAXFEV) INFO = 2
            IF (P1*AMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3
            IF (NSLOW2 .EQ. 5) INFO = 4
            IF (NSLOW1 .EQ. 10) INFO = 5
            IF (INFO .NE. 0) GO TO 300
C
C           CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION
C           BY FORWARD DIFFERENCES.
C
            IF (NCFAIL .EQ. 2) GO TO 290
C
C           CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN
C           AND UPDATE QTF IF NECESSARY.
C
            DO 280 J = 1, N
               SUM = ZERO
               DO 270 I = 1, N
                  SUM = SUM + FJAC(I,J)*WA4(I)
  270             CONTINUE
               WA2(J) = (SUM - WA3(J))/PNORM
               WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM)
               IF (RATIO .GE. P0001) QTF(J) = SUM
  280          CONTINUE
C
C           COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN.
C
            CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING)
            CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3)
            CALL R1MPYQ(1,N,QTF,1,WA2,WA3)
C
C           END OF THE INNER LOOP.
C
            JEVAL = .FALSE.
            GO TO 180
  290    CONTINUE
C
C        END OF THE OUTER LOOP.
C
         GO TO 30
  300 CONTINUE
C
C     TERMINATION, EITHER NORMAL OR USER IMPOSED.
C
      IF (IFLAG .LT. 0) INFO = IFLAG
      IFLAG = 0
      IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG)
      RETURN
C
C     LAST CARD OF SUBROUTINE HYBRD.
C
      END
      SUBROUTINE QDCRT (A, Z)
C-----------------------------------------------------------------------
C
C        QDCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL
C              A(1) + A(2)*Z + A(3)*Z**2
C     AND STORES THE RESULTS IN Z. IT IS ASSUMED THAT A(3)
C     IS NONZERO.
C
C-----------------------------------------------------------------------
      REAL A(3)
      COMPLEX Z(2)
C-----------------------------------------------------------------------
C
C     ***** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C           SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0.
C
               EPS = SPMPAR(1)
C
C-------------------
      IF (A(1) .EQ. 0.0) GO TO 40
      D = A(2)*A(2) - 4.0*A(1)*A(3)
      IF (ABS(D) .LE. 2.0*EPS*A(2)*A(2)) GO TO 20
      R = SQRT(ABS(D))
      IF (D .LT. 0.0) GO TO 30
C
C                 DISTINCT REAL ROOTS
C
      IF (A(2) .NE. 0.0) GO TO 10
         X = ABS(0.5*R/A(3))
         Z(1) = CMPLX(X, 0.0)
         Z(2) = CMPLX(-X, 0.0)
         RETURN
   10 W = -(A(2) + SIGN(R,A(2)))
      Z(1) = CMPLX(2.0*A(1)/W, 0.0)
      Z(2) = CMPLX(0.5*W/A(3), 0.0)
      RETURN
C
C                  EQUAL REAL ROOTS
C
   20 Z(1) = CMPLX(-0.5*A(2)/A(3), 0.0)
      Z(2) = Z(1)
      RETURN
C
C                   COMPLEX ROOTS
C
   30 X = -0.5*A(2)/A(3)
      Y = ABS(0.5*R/A(3))
      Z(1) = CMPLX(X, Y)
      Z(2) = CMPLX(X,-Y)
      RETURN
C
C                 CASE WHEN A(1) = 0
C
   40 Z(1) = (0.0, 0.0)
      Z(2) = CMPLX(-A(2)/A(3), 0.0)
      RETURN
      END
      SUBROUTINE DQDCRT (A, ZR, ZI)
C-----------------------------------------------------------------------
C
C        DQDCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL
C                A(1) + A(2)*Z + A(3)*Z**2
C     AND STORES THE RESULTS IN ZR AND ZI. IT IS ASSUMED THAT
C     A(3) IS NONZERO.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(3), ZR(3), ZI(3)
      DOUBLE PRECISION D, EPS, R, W
      DOUBLE PRECISION DPMPAR
C-----------------------------------------------------------------------
C
C     ***** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C           SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0.
C
               EPS = DPMPAR(1)
C
C-------------------
      IF (A(1) .EQ. 0.D0) GO TO 40
      D = A(2)*A(2) - 4.D0*A(1)*A(3)
      IF (DABS(D) .LE. 2.D0*EPS*A(2)*A(2)) GO TO 20
      R = DSQRT(DABS(D))
      IF (D .LT. 0.D0) GO TO 30
C
C                 DISTINCT REAL ROOTS
C
      ZI(1) = 0.D0
      ZI(2) = 0.D0
      IF (A(2) .NE. 0.D0) GO TO 10
         ZR(1) = DABS(0.5D0*R/A(3))
         ZR(2) = -ZR(1)
         RETURN
   10 W = -(A(2) + DSIGN(R,A(2)))
      ZR(1) = 2.D0*A(1)/W
      ZR(2) = 0.5D0*W/A(3)
      RETURN
C
C                  EQUAL REAL ROOTS
C
   20 ZR(1) = -0.5D0*A(2)/A(3)
      ZR(2) = ZR(1)
      ZI(1) = 0.D0
      ZI(2) = 0.D0
      RETURN
C
C                   COMPLEX ROOTS
C
   30 ZR(1) = -0.5D0*A(2)/A(3)
      ZR(2) = ZR(1)
      ZI(1) = DABS(0.5D0*R/A(3))
      ZI(2) = -ZI(1)
      RETURN
C
C                 CASE WHEN A(1) = 0
C
   40 ZR(1) = 0.D0
      ZR(2) = -A(2)/A(3)
      ZI(1) = 0.D0
      ZI(2) = 0.D0
      RETURN
      END
      SUBROUTINE CBCRT (A, Z)
C-----------------------------------------------------------------------
C
C        CBCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL
C              A(1) + A(2)*Z + A(3)*Z**2 + A(4)*Z**3
C     AND STORES THE RESULTS IN Z. IT IS ASSUMED THAT A(4)
C     IS NONZERO.
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
      REAL A(4), AQ(3)
      COMPLEX Z(3)
C-------------------
      DATA RT3/1.7320508075689/
C-----------------------------------------------------------------------
C
C     ***** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C           SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0.
C
               EPS = SPMPAR(1)
C
C-------------------
      IF (A(1) .EQ. 0.0) GO TO 100
      P = A(3)/(3.0*A(4))
      Q = A(2)/A(4)
      R = A(1)/A(4)
      TOL = 4.0*EPS
C
      C = 0.0
      T = A(2) - P*A(3)
      IF (ABS(T) .GT. TOL*ABS(A(2))) C = T/A(4)
C
      T = 2.0*P*P - Q
      IF (ABS(T) .LE. TOL*ABS(Q)) T = 0.0
      D = R + P*T
      IF (ABS(D) .LE. TOL*ABS(R)) GO TO 110
C
C           SET  SQ = (A(4)/S)**2 * (C**3/27 + D**2/4)
C
      S = AMAX1(ABS(A(1)),ABS(A(2)),ABS(A(3)))
      P1 = A(3)/(3.0*S)
      Q1 = A(2)/S
      R1 = A(1)/S
C
      T1 = Q - 2.25*P*P
      IF (ABS(T1) .LE. TOL*ABS(Q)) T1 = 0.0
      W = 0.25*R1*R1
      W1 = 0.5*P1*R1*T
      W2 = Q1*Q1*T1/27.0
      IF (W1 .LT. 0.0) GO TO 10
         W = W + W1
         SQ = W + W2
         GO TO 12
   10 IF (W2 .LT. 0.0) GO TO 11
         W = W + W2
         SQ = W + W1
         GO TO 12
   11 SQ = W + (W1 + W2)
   12 IF (ABS(SQ) .LE. TOL*W) SQ = 0.0
      RQ = ABS(S/A(4))*SQRT(ABS(SQ))
      IF (SQ .GE. 0.0) GO TO 40
C
C                   ALL ROOTS ARE REAL
C
      ARG = ATAN2(RQ, -0.5*D)
      CF = COS(ARG/3.0)
      SF = SIN(ARG/3.0)
      RT = SQRT(-C/3.0)
      Y1 = 2.0*RT*CF
      Y2 = -RT*(CF + RT3*SF)
      Y3 = -(D/Y1)/Y2
C
      X1 = Y1 - P
      X2 = Y2 - P
      X3 = Y3 - P
      IF (ABS(X1) .LE. ABS(X2)) GO TO 20
         T = X1
         X1 = X2
         X2 = T
   20 IF (ABS(X2) .LE. ABS(X3)) GO TO 30
         T = X2
         X2 = X3
         X3 = T
      IF (ABS(X1) .LE. ABS(X2)) GO TO 30
         T = X1
         X1 = X2
         X2 = T
C
   30 W = X3
      IF (ABS(X2) .LT. 0.1*ABS(X3)) GO TO 70
      IF (ABS(X1) .LT. 0.1*ABS(X2)) X1 = - (R/X3)/X2
      Z(1) = CMPLX(X1, 0.0)
      Z(2) = CMPLX(X2, 0.0)
      Z(3) = CMPLX(X3, 0.0)
      RETURN
C
C                  REAL AND COMPLEX ROOTS
C
   40 RA = CBRT(-0.5*D - SIGN(RQ,D))
      RB = -C/(3.0*RA)
      T = RA + RB
      W = -P
      X = -P
      IF (ABS(T) .LE. TOL*ABS(RA)) GO TO 41
         W = T - P
         X = -0.5*T - P
         IF (ABS(X) .LE. TOL*ABS(P)) X = 0.0
   41 T = ABS(RA - RB)
      Y = 0.5*RT3*T
C
      IF (T .LE. TOL*ABS(RA)) GO TO 60
      IF (ABS(X) .LT. ABS(Y)) GO TO 50
         S = ABS(X)
         T = Y/X
         GO TO 51
   50 S = ABS(Y)
      T = X/Y
   51 IF (S .LT. 0.1*ABS(W)) GO TO 70
      W1 = W/S
      SUM = 1.0 + T*T
      IF (W1*W1 .LT. 0.01*SUM) W = - ((R/SUM)/S)/S
      Z(1) = CMPLX(W,0.0)
      Z(2) = CMPLX(X, Y)
      Z(3) = CMPLX(X,-Y)
      RETURN
C
C               AT LEAST TWO ROOTS ARE EQUAL
C
   60 IF (ABS(X) .LT. ABS(W)) GO TO 61
         IF (ABS(W) .LT. 0.1*ABS(X)) W = - (R/X)/X
         Z(1) = CMPLX(W, 0.0)
         Z(2) = CMPLX(X, 0.0)
         Z(3) = Z(2)
         RETURN
   61 IF (ABS(X) .LT. 0.1*ABS(W)) GO TO 70
      Z(1) = CMPLX(X, 0.0)
      Z(2) = Z(1)
      Z(3) = CMPLX(W, 0.0)
      RETURN
C
C     HERE W IS MUCH LARGER IN MAGNITUDE THAN THE OTHER ROOTS.
C     AS A RESULT, THE OTHER ROOTS MAY BE EXCEEDINGLY INACCURATE
C     BECAUSE OF ROUNDOFF ERROR. TO DEAL WITH THIS, A QUADRATIC
C     IS FORMED WHOSE ROOTS ARE THE SAME AS THE SMALLER ROOTS OF
C     THE CUBIC. THIS QUADRATIC IS THEN SOLVED.
C
C     THIS CODE WAS WRITTEN BY WILLIAM L. DAVIS (NSWC).
C
   70    AQ(1) = A(1)
         AQ(2) = A(2) + A(1)/W
         AQ(3) = -A(4)*W
         CALL QDCRT(AQ, Z)
         Z(3) = CMPLX(W, 0.0)
C
      IF (AIMAG(Z(1)) .EQ. 0.0) RETURN
      Z(3) = Z(2)
      Z(2) = Z(1)
      Z(1) = CMPLX(W, 0.0)
      RETURN
C-----------------------------------------------------------------------
C
C                  CASE WHEN A(1) = 0
C
  100 Z(1) = (0.0, 0.0)
      CALL QDCRT(A(2), Z(2))
      RETURN
C
C                   CASE WHEN D = 0
C
  110 Z(1) = CMPLX(-P, 0.0)
      W = SQRT(ABS(C))
      IF (C .LT. 0.0) GO TO 120
         Z(2) = CMPLX(-P, W)
         Z(3) = CMPLX(-P,-W)
         RETURN
C
  120 IF (P .NE. 0.0) GO TO 130
         Z(2) = CMPLX(W, 0.0)
         Z(3) = CMPLX(-W, 0.0)
         RETURN
C
  130 X = -(P + SIGN(W,P))
      Z(3) = CMPLX(X, 0.0)
      T = 3.0*A(1)/(A(3)*X)
      IF (ABS(P) .GT. ABS(T)) GO TO 131
         Z(2) = CMPLX(T, 0.0)
         RETURN
  131 Z(2) = Z(1)
      Z(1) = CMPLX(T, 0.0)
      RETURN
      END
      SUBROUTINE DCBCRT (A, ZR, ZI)
C-----------------------------------------------------------------------
C
C        DCBCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL
C              A(1) + A(2)*Z + A(3)*Z**2 + A(4)*Z**3
C     AND STORES THE RESULTS IN ZR AND ZI. IT IS ASSUMED THAT
C     A(4) IS NONZERO.
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(4), ZR(3), ZI(3)
      DOUBLE PRECISION AQ(3), ARG, C, CF, D, EPS, P, P1, Q, Q1,
     *                 R, RA, RB, RQ, RT, RT3, R1, S, SF, SQ, SUM,
     *                 T, TOL, T1, W, W1, W2, X, X1, X2, X3, Y,
     *                 Y1, Y2, Y3
      DOUBLE PRECISION DPMPAR, DCBRT
C-------------------
      DATA RT3 /1.732050807568877293527446341505872366943D0/
C-----------------------------------------------------------------------
C
C     ***** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C           SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0.
C
               EPS = DPMPAR(1)
C
C-------------------
      IF (A(1) .EQ. 0.D0) GO TO 100
      P = A(3)/(3.D0*A(4))
      Q = A(2)/A(4)
      R = A(1)/A(4)
      TOL = 4.D0*EPS
C
      C = 0.D0
      T = A(2) - P*A(3)
      IF (DABS(T) .GT. TOL*DABS(A(2))) C = T/A(4)
C
      T = 2.D0*P*P - Q
      IF (DABS(T) .LE. TOL*DABS(Q)) T = 0.D0
      D = R + P*T
      IF (DABS(D) .LE. TOL*DABS(R)) GO TO 110
C
C           SET  SQ = (A(4)/S)**2 * (C**3/27 + D**2/4)
C
      S = DMAX1(DABS(A(1)),DABS(A(2)),DABS(A(3)))
      P1 = A(3)/(3.D0*S)
      Q1 = A(2)/S
      R1 = A(1)/S
C
      T1 = Q - 2.25D0*P*P
      IF (DABS(T1) .LE. TOL*DABS(Q)) T1 = 0.D0
      W = 0.25D0*R1*R1
      W1 = 0.5D0*P1*R1*T
      W2 = Q1*Q1*T1/27.D0
      IF (W1 .LT. 0.D0) GO TO 10
         W = W + W1
         SQ = W + W2
         GO TO 12
   10 IF (W2 .LT. 0.D0) GO TO 11
         W = W + W2
         SQ = W + W1
         GO TO 12
   11 SQ = W + (W1 + W2)
   12 IF (DABS(SQ) .LE. TOL*W) SQ = 0.D0
      RQ = DABS(S/A(4))*DSQRT(DABS(SQ))
      IF (SQ .GE. 0.D0) GO TO 40
C
C                   ALL ROOTS ARE REAL
C
      ARG = DATAN2(RQ, -0.5D0*D)
      CF = DCOS(ARG/3.D0)
      SF = DSIN(ARG/3.D0)
      RT = DSQRT(-C/3.D0)
      Y1 = 2.D0*RT*CF
      Y2 = -RT*(CF + RT3*SF)
      Y3 = -(D/Y1)/Y2
C
      X1 = Y1 - P
      X2 = Y2 - P
      X3 = Y3 - P
      IF (DABS(X1) .LE. DABS(X2)) GO TO 20
         T = X1
         X1 = X2
         X2 = T
   20 IF (DABS(X2) .LE. DABS(X3)) GO TO 30
         T = X2
         X2 = X3
         X3 = T
      IF (DABS(X1) .LE. DABS(X2)) GO TO 30
         T = X1
         X1 = X2
         X2 = T
C
   30 W = X3
      IF (DABS(X2) .LT. 0.1D0*DABS(X3)) GO TO 70
      IF (DABS(X1) .LT. 0.1D0*DABS(X2)) X1 = - (R/X3)/X2
      ZR(1) = X1
      ZR(2) = X2
      ZR(3) = X3
      ZI(1) = 0.D0
      ZI(2) = 0.D0
      ZI(3) = 0.D0
      RETURN
C
C                  REAL AND COMPLEX ROOTS
C
   40 RA = DCBRT(-0.5D0*D - DSIGN(RQ,D))
      RB = -C/(3.D0*RA)
      T = RA + RB
      W = -P
      X = -P
      IF (DABS(T) .LE. TOL*DABS(RA)) GO TO 41
         W = T - P
         X = -0.5D0*T - P
         IF (DABS(X) .LE. TOL*DABS(P)) X = 0.D0
   41 T = DABS(RA - RB)
      Y = 0.5D0*RT3*T
C
      IF (T .LE. TOL*DABS(RA)) GO TO 60
      IF (DABS(X) .LT. DABS(Y)) GO TO 50
         S = DABS(X)
         T = Y/X
         GO TO 51
   50 S = DABS(Y)
      T = X/Y
   51 IF (S .LT. 0.1D0*DABS(W)) GO TO 70
      W1 = W/S
      SUM = 1.D0 + T*T
      IF (W1*W1 .LT. 1.D-2*SUM) W = - ((R/SUM)/S)/S
      ZR(1) = W
      ZR(2) = X
      ZR(3) = X
      ZI(1) = 0.D0
      ZI(2) = Y
      ZI(3) = -Y
      RETURN
C
C               AT LEAST TWO ROOTS ARE EQUAL
C
   60 ZI(1) = 0.D0
      ZI(2) = 0.D0
      ZI(3) = 0.D0
      IF (DABS(X) .LT. DABS(W)) GO TO 61
         IF (DABS(W) .LT. 0.1D0*DABS(X)) W = - (R/X)/X
         ZR(1) = W
         ZR(2) = X
         ZR(3) = X
         RETURN
   61 IF (DABS(X) .LT. 0.1D0*DABS(W)) GO TO 70
      ZR(1) = X
      ZR(2) = X
      ZR(3) = W
      RETURN
C
C     HERE W IS MUCH LARGER IN MAGNITUDE THAN THE OTHER ROOTS.
C     AS A RESULT, THE OTHER ROOTS MAY BE EXCEEDINGLY INACCURATE
C     BECAUSE OF ROUNDOFF ERROR. TO DEAL WITH THIS, A QUADRATIC
C     IS FORMED WHOSE ROOTS ARE THE SAME AS THE SMALLER ROOTS OF
C     THE CUBIC. THIS QUADRATIC IS THEN SOLVED.
C
C     THIS CODE WAS WRITTEN BY WILLIAM L. DAVIS (NSWC).
C
   70    AQ(1) = A(1)
         AQ(2) = A(2) + A(1)/W
         AQ(3) = -A(4)*W
         CALL DQDCRT (AQ, ZR, ZI)
         ZR(3) = W
         ZI(3) = 0.D0
C
      IF (ZI(1) .EQ. 0.D0) RETURN
      ZR(3) = ZR(2)
      ZI(3) = ZI(2)
      ZR(2) = ZR(1)
      ZI(2) = ZI(1)
      ZR(1) = W
      ZI(1) = 0.D0
      RETURN
C-----------------------------------------------------------------------
C
C                  CASE WHEN A(1) = 0
C
  100 ZR(1) = 0.D0
      ZI(1) = 0.D0
      CALL DQDCRT(A(2), ZR(2), ZI(2))
      RETURN
C
C                   CASE WHEN D = 0
C
  110 ZR(1) = -P
      ZI(1) = 0.D0
      W = DSQRT(DABS(C))
      IF (C .LT. 0.D0) GO TO 120
         ZR(2) = -P
         ZR(3) = ZR(2)
         ZI(2) =  W
         ZI(3) = -W
         RETURN
C
  120 IF (P .NE. 0.D0) GO TO 130
         ZR(2) =  W
         ZR(3) = -W
         ZI(2) = 0.D0
         ZI(3) = 0.D0
         RETURN
C
  130 X = -(P + DSIGN(W,P))
      ZR(3) =  X
      ZI(2) = 0.D0
      ZI(3) = 0.D0
      T = 3.D0*A(1)/(A(3)*X)
      IF (DABS(P) .GT. DABS(T)) GO TO 131
         ZR(2) = T
         RETURN
  131 ZR(2) = ZR(1)
      ZR(1) = T
      RETURN
      END
      SUBROUTINE QTCRT (A, Z)
C-----------------------------------------------------------------------
C
C         QTCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL
C               A(1) + A(2)*Z + ... + A(5)*Z**4
C         AND STORES THE RESULTS IN Z. IT IS ASSUMED THAT A(5)
C         IS NONZERO.
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
      REAL A(5), TEMP(4)
      COMPLEX Z(4), W
C
      IF (A(1) .EQ. 0.0) GO TO 100
      B = A(4)/(4.0*A(5))
      C = A(3)/A(5)
      D = A(2)/A(5)
      E = A(1)/A(5)
      B2 = B*B
C
      P = 0.5*(C - 6.0*B2)
      Q = D - 2.0*B*(C - 4.0*B2)
      R = B2*(C - 3.0*B2) - B*D + E
C
C          SOLVE THE RESOLVENT CUBIC EQUATION. THE CUBIC HAS
C          AT LEAST ONE NONNEGATIVE REAL ROOT. IF W1, W2, W3
C          ARE THE ROOTS OF THE CUBIC THEN THE ROOTS OF THE
C          ORIGINIAL EQUATION ARE
C
C             Z = -B + CSQRT(W1) + CSQRT(W2) + CSQRT(W3)
C
C          WHERE THE SIGNS OF THE SQUARE ROOTS ARE CHOSEN SO
C          THAT CSQRT(W1) * CSQRT(W2) * CSQRT(W3) = -Q/8.
C
      TEMP(1) = -Q*Q/64.0
      TEMP(2) = 0.25*(P*P - R)
      TEMP(3) =  P
      TEMP(4) = 1.0
      CALL CBCRT(TEMP,Z)
      IF (AIMAG(Z(2)) .NE. 0.0) GO TO 60
C
C               THE RESOLVENT CUBIC HAS ONLY REAL ROOTS
C                REORDER THE ROOTS IN INCREASING ORDER
C
      X1 = REAL(Z(1))
      X2 = REAL(Z(2))
      X3 = REAL(Z(3))
      IF (X1 .LE. X2) GO TO 10
         T = X1
         X1 = X2
         X2 = T
   10 IF (X2 .LE. X3) GO TO 20
         T = X2
         X2 = X3
         X3 = T
      IF (X1 .LE. X2) GO TO 20
         T = X1
         X1 = X2
         X2 = T
C
   20 U = 0.0
      IF (X3 .GT. 0.0) U = SQRT(X3)
      IF (X2 .LE. 0.0) GO TO 41
      IF (X1 .GE. 0.0) GO TO 30
      IF (ABS(X1) .GT. X2) GO TO 40
      X1 = 0.0
C
   30 X1 = SQRT(X1)
      X2 = SQRT(X2)
      IF (Q .GT. 0.0) X1 = -X1
      TEMP(1) = (( X1 + X2) + U) - B
      TEMP(2) = ((-X1 - X2) + U) - B
      TEMP(3) = (( X1 - X2) - U) - B
      TEMP(4) = ((-X1 + X2) - U) - B
      CALL AORD (TEMP,4)
      IF (ABS(TEMP(1)) .GE. 0.1*ABS(TEMP(4))) GO TO 31
         T = TEMP(2)*TEMP(3)*TEMP(4)
         IF (T .NE. 0.0) TEMP(1) = E/T
   31 Z(1) = CMPLX(TEMP(1), 0.0)
      Z(2) = CMPLX(TEMP(2), 0.0)
      Z(3) = CMPLX(TEMP(3), 0.0)
      Z(4) = CMPLX(TEMP(4), 0.0)
      RETURN
C
   40 V1 = SQRT(ABS(X1))
      V2 = 0.0
      GO TO 50
   41 V1 = SQRT(ABS(X1))
      V2 = SQRT(ABS(X2))
      IF (Q .LT. 0.0) U = -U
C
   50 X = -U - B
      Y = V1 - V2
      Z(1) = CMPLX(X, Y)
      Z(2) = CMPLX(X,-Y)
      X =  U - B
      Y = V1 + V2
      Z(3) = CMPLX(X, Y)
      Z(4) = CMPLX(X,-Y)
      RETURN
C
C                THE RESOLVENT CUBIC HAS COMPLEX ROOTS
C
   60 T = REAL(Z(1))
      X = 0.0
      IF (T) 61,70,62
   61 H = ABS(REAL(Z(2))) + ABS(AIMAG(Z(2)))
      IF (ABS(T) .LE. H) GO TO 70
      GO TO 80
   62 X = SQRT(T)
      IF (Q .GT. 0.0) X = -X
C
   70 W = CSQRT(Z(2))
      U = 2.0*REAL(W)
      V = 2.0*ABS(AIMAG(W))
      T =  X - B
      X1 = T + U
      X2 = T - U
      IF (ABS(X1) .LE. ABS(X2)) GO TO 71
         T = X1
         X1 = X2
         X2 = T
   71 U = -X - B
      H = U*U + V*V
      IF (X1*X1 .LT. 0.01*AMIN1(X2*X2,H)) X1 = E/(X2*H)
      Z(1) = CMPLX(X1, 0.0)
      Z(2) = CMPLX(X2, 0.0)
      Z(3) = CMPLX(U, V)
      Z(4) = CMPLX(U,-V)
      RETURN
C
   80 V = SQRT(ABS(T))
      Z(1) = CMPLX(-B, V)
      Z(2) = CMPLX(-B,-V)
      Z(3) = Z(1)
      Z(4) = Z(2)
      RETURN
C
C                         CASE WHEN A(1) = 0
C
  100 Z(1) = (0.0, 0.0)
      CALL CBCRT(A(2), Z(2))
      RETURN
      END
      SUBROUTINE DQTCRT (A, ZR, ZI)
C-----------------------------------------------------------------------
C
C         DQTCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL
C               A(1) + A(2)*Z + ... + A(5)*Z**4
C         AND STORES THE RESULTS IN ZR AND ZI. IT IS ASSUMED
C         THAT A(5) IS NONZERO.
C
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(5), ZR(4), ZI(4)
      DOUBLE PRECISION B, B2, C, D, E, H, P, Q, R, T, TEMP(4),
     *                 U, V, V1, V2, W(2), X, X1, X2, X3
C
      IF (A(1) .EQ. 0.D0) GO TO 100
      B = A(4)/(4.D0*A(5))
      C = A(3)/A(5)
      D = A(2)/A(5)
      E = A(1)/A(5)
      B2 = B*B
C
      P = 0.5D0*(C - 6.D0*B2)
      Q = D - 2.D0*B*(C - 4.D0*B2)
      R = B2*(C - 3.D0*B2) - B*D + E
C
C          SOLVE THE RESOLVENT CUBIC EQUATION. THE CUBIC HAS
C          AT LEAST ONE NONNEGATIVE REAL ROOT. IF W1, W2, W3
C          ARE THE ROOTS OF THE CUBIC THEN THE ROOTS OF THE
C          ORIGINIAL EQUATION ARE
C
C             Z = -B + CSQRT(W1) + CSQRT(W2) + CSQRT(W3)
C
C          WHERE THE SIGNS OF THE SQUARE ROOTS ARE CHOSEN SO
C          THAT CSQRT(W1) * CSQRT(W2) * CSQRT(W3) = -Q/8.
C
      TEMP(1) = -Q*Q/64.D0
      TEMP(2) = 0.25D0*(P*P - R)
      TEMP(3) =  P
      TEMP(4) = 1.D0
      CALL DCBCRT (TEMP, ZR, ZI)
      IF (ZI(2) .NE. 0.D0) GO TO 60
C
C               THE RESOLVENT CUBIC HAS ONLY REAL ROOTS
C                REORDER THE ROOTS IN INCREASING ORDER
C
      X1 = ZR(1)
      X2 = ZR(2)
      X3 = ZR(3)
      IF (X1 .LE. X2) GO TO 10
         T = X1
         X1 = X2
         X2 = T
   10 IF (X2 .LE. X3) GO TO 20
         T = X2
         X2 = X3
         X3 = T
      IF (X1 .LE. X2) GO TO 20
         T = X1
         X1 = X2
         X2 = T
C
   20 U = 0.D0
      IF (X3 .GT. 0.D0) U = DSQRT(X3)
      IF (X2 .LE. 0.D0) GO TO 41
      IF (X1 .GE. 0.D0) GO TO 30
      IF (DABS(X1) .GT. X2) GO TO 40
      X1 = 0.D0
C
   30 X1 = DSQRT(X1)
      X2 = DSQRT(X2)
      IF (Q .GT. 0.D0) X1 = -X1
      ZR(1) = (( X1 + X2) + U) - B
      ZR(2) = ((-X1 - X2) + U) - B
      ZR(3) = (( X1 - X2) - U) - B
      ZR(4) = ((-X1 + X2) - U) - B
      CALL DAORD (ZR, 4)
      IF (DABS(ZR(1)) .GE. 0.1D0*DABS(ZR(4))) GO TO 31
         T = ZR(2)*ZR(3)*ZR(4)
         IF (T .NE. 0.D0) ZR(1) = E/T
   31 ZI(1) = 0.D0
      ZI(2) = 0.D0
      ZI(3) = 0.D0
      ZI(4) = 0.D0
      RETURN
C
   40 V1 = DSQRT(DABS(X1))
      V2 = 0.D0
      GO TO 50
   41 V1 = DSQRT(DABS(X1))
      V2 = DSQRT(DABS(X2))
      IF (Q .LT. 0.D0) U = -U
C
   50 ZR(1) = -U - B
      ZI(1) = V1 - V2
      ZR(2) =  ZR(1)
      ZI(2) = -ZI(1)
      ZR(3) =  U - B
      ZI(3) = V1 + V2
      ZR(4) =  ZR(3)
      ZI(4) = -ZI(3)
      RETURN
C
C                THE RESOLVENT CUBIC HAS COMPLEX ROOTS
C
   60 T = ZR(1)
      X = 0.D0
      IF (T) 61,70,62
   61 H = DABS(ZR(2)) + DABS(ZI(2))
      IF (DABS(T) .LE. H) GO TO 70
      GO TO 80
   62 X = DSQRT(T)
      IF (Q .GT. 0.D0) X = -X
C
   70 W(1) = ZR(2)
      W(2) = ZI(2)
      CALL DCSQRT (W, W)
      U = 2.D0*W(1)
      V = 2.D0*DABS(W(2))
      T =  X - B
      X1 = T + U
      X2 = T - U
      IF (DABS(X1) .LE. DABS(X2)) GO TO 71
         T = X1
         X1 = X2
         X2 = T
   71 U = -X - B
      H = U*U + V*V
      IF (X1*X1 .LT. 1.D-2*DMIN1(X2*X2,H)) X1 = E/(X2*H)
      ZR(1) = X1
      ZR(2) = X2
      ZI(1) = 0.D0
      ZI(2) = 0.D0
      ZR(3) =  U
      ZR(4) =  U
      ZI(3) =  V
      ZI(4) = -V
      RETURN
C
   80 V = DSQRT(DABS(T))
      ZR(1) = -B
      ZR(2) = -B
      ZR(3) = -B
      ZR(4) = -B
      ZI(1) =  V
      ZI(2) = -V
      ZI(3) =  V
      ZI(4) = -V
      RETURN
C
C                         CASE WHEN A(1) = 0
C
  100 ZR(1) = 0.D0
      ZI(1) = 0.D0
      CALL DCBCRT(A(2), ZR(2), ZI(2))
      RETURN
      END
      SUBROUTINE DRPOLY (OP, IDEG, ZEROR, ZEROI, NUM, WK, DWK)
C
C     THIS SUBROUTINE FINDS THE ZEROS OF A REAL POLYNOMIAL.
C
C     OP          - DOUBLE PRECISION ARRAY OF LENGTH IDEG + 1.
C                   ON INPUT THIS ARRAY CONTAINS THE COEFFICIENTS
C                   IN ORDER OF DECREASING POWERS.
C
C     IDEG        - INTEGER DEGREE OF THE POLYNOMIAL.
C
C     ZEROR,ZEROI - DOUBLE PRECISION ARRAYS IF LENGTH IDEG.
C                   ON OUTPUT THESE ARRAYS CONTAIN THE REAL AND
C                   IMAGINARY PARTS OF THE ZEROS.
C
C     NUM         - VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C                   IF NUM = -1 THEN THE LEADING COEFFICIENT OF THE
C                   POLYNOMIAL IS 0 OR IDEG .LT. 1. OTHERWISE, NUM
C                   IS THE NUMBER OF ZEROS THAT WERE OBTAINED. IF
C                   NUM .GE. 1 THEN THE REAL AND IMAGINARY PARTS OF
C                   THE ZEROS ARE STORED IN ZEROR(J) AND ZEROI(J)
C                   FOR J = 1,...,NUM.
C
C     WK          - REAL ARRAY OF LENGTH IDEG + 1. THE ARRAY IS
C                   A WORK SPACE FOR THE ROUTINE.
C
C     DWK         - DOUBLE PRECISION ARRAY OF LENGTH 6*(IDEG + 1).
C                   THE ARRAY IS A WORK SPACE FOR THE ROUTINE.
C
C     THE SUBROUTINE USES SINGLE PRECISION CALCULATIONS FOR SCALING,
C     BOUNDS, AND ERROR CALCULATIONS. ALL OTHER CALCULATIONS ARE DONE
C     IN DOUBLE PRECISION.
C
      INTEGER IDEG, NUM
      DOUBLE PRECISION OP(*), ZEROR(IDEG), ZEROI(IDEG), DWK(*)
      REAL WK(*)
C
      INTEGER P, QP, K, QK, SVK, TMP
C
      IF (IDEG .LT. 1) GO TO 10
C
C     PARTITION THE WORKSPACE DWK AND OBTAIN THE ZEROS
C
      IDP1 = IDEG + 1
C
      P  = 1
      QP = P  + IDP1
      K  = QP + IDP1
      QK = K  + IDP1
      SVK = QK  + IDP1
      TMP = SVK + IDP1
C
      CALL DRPLY1 (OP,IDEG,IDP1,ZEROR,ZEROI,DWK(P),DWK(QP),DWK(K),
     *             DWK(QK),DWK(SVK),DWK(TMP),WK,NUM)
      RETURN
C
C     ERROR RETURN
C
   10 NUM = -1
      RETURN
      END
      SUBROUTINE DRPLY1 (OP,IDEG,IDP1,ZEROR,ZEROI,P,QP,K,QK,SVK,
     *                   TEMP,PT,NUM)
C-------------------------
      DOUBLE PRECISION OP(IDP1), ZEROR(IDEG), ZEROI(IDEG),
     *                 P(IDP1), QP(IDP1), K(IDP1), QK(IDP1),
     *                 SVK(IDP1), TEMP(IDP1)
      REAL PT(IDP1)
C
      DOUBLE PRECISION  AA, BB, CC, FACTOR, T
      REAL LO, MAX, MIN, XX, YY, COSR, SINR, X, XXX, SC,
     *     BND, XM, FF, DF, DX, BASE, SMALNO, INFIN
      INTEGER CNT
      LOGICAL ZEROK
C
      REAL SPMPAR
      INTEGER IPMPAR
      DOUBLE PRECISION DPMPAR
C-------------------------
      REAL ETA, ARE, MRE
      DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI
      COMMON /GLOBAL/  SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE
C-------------------------
C     THE FOLLOWING STATEMENTS SET THE MACHINE CONSTANTS USED
C     IN THE CODE. THE MEANING OF THE CONSTANTS ARE ...
C
C     ETA     THE SMALLEST POSITIVE NUMBER SUCH THAT
C             1.D0 + ETA IS GREATER THAN 1.D0
C     SMALNO  THE SMALLEST POSITIVE FLOATING POINT NUMBER.
C             IF THE EXPONENT RANGE DIFFERS IN SINGLE AND
C             DOUBLE PRECISION THEN SMALNO AND INFIN
C             SHOULD INDICATE THE SMALLER RANGE.
C     INFIN   THE LARGEST POSITIVE FLOATING POINT NUMBER.
C     BASE    THE BASE OF THE FLOATING POINT ARITHMETICS
C             BEING USED.
C
                       ETA = DPMPAR(1)
                       SMALNO = SPMPAR(2)
                       INFIN = SPMPAR(3)
                       BASE = IPMPAR(4)
C-------------------------
C
C     ARE AND MRE REFER TO THE UNIT ERROR IN + AND *
C     RESPECTIVELY. THEY ARE ASSUMED TO BE THE SAME AS ETA.
C
      ARE = ETA
      MRE = ETA
      LO = SMALNO/ETA
C
C     INITIALIZATION OF CONSTANTS FOR SHIFT ROTATION
C
      XX = .70710678
      YY = -XX
      COSR = -.069756474
      SINR = .99756405
      N = IDEG
      NN = IDP1
      NUM = 0
C
C     ALGORITHM FAILS IF THE LEADING COEFFICIENT IS ZERO.
C
      IF (OP(1) .NE. 0.D0) GO TO 10
         NUM = -1
         RETURN
C
C     REMOVE THE ZEROS AT THE ORIGIN IF ANY
C
   10 IF (OP(NN) .NE. 0.0D0) GO TO 20
         NUM = NUM + 1
         ZEROR(NUM) = 0.D0
         ZEROI(NUM) = 0.D0
         NN = NN - 1
         N = N - 1
         GO TO 10
C
C     MAKE A COPY OF THE COEFFICIENTS
C
   20 DO 30 I = 1,NN
         P(I) = OP(I)
   30 CONTINUE
C
C     START THE ALGORITHM FOR OBTAINING A ZERO
C
   40 IF (N .GT. 2) GO TO 60
      IF (N .LT. 1) RETURN
C
C     CALCULATE THE FINAL ZERO OR PAIR OF ZEROS
C
      NUM = IDEG
      IF (N .EQ. 2) GO TO 50
         ZEROR(IDEG) = -P(2)/P(1)
         ZEROI(IDEG) = 0.0D0
         RETURN
   50 CALL QUADPL(P(1), P(2), P(3), ZEROR(IDEG - 1), ZEROI(IDEG - 1),
     *                  ZEROR(IDEG), ZEROI(IDEG))
      RETURN
C
C     FIND LARGEST AND SMALLEST MODULI OF COEFFICIENTS.
C
   60 MAX = 0.0
      MIN = INFIN
      DO 70 I = 1,NN
         X = ABS(SNGL(P(I)))
         IF (X .GT. MAX) MAX = X
         IF (X .NE. 0.0 .AND. X .LT. MIN) MIN = X
   70 CONTINUE
C
C     SCALE IF THERE ARE LARGE OR VERY SMALL COEFFICIENTS.
C     COMPUTES A SCALE FACTOR TO MULTIPLY THE
C     COEFFICIENTS OF THE POLYNOMIAL. THE SCALING IS DONE
C     TO AVOID OVERFLOW AND TO AVOID UNDETECTED UNDERFLOW
C     INTERFERING WITH THE CONVERGENCE CRITERION.
C     THE FACTOR IS A POWER OF THE BASE.
C
      SC = LO/MIN
      IF (SC .GT. 1.0) GO TO 80
      IF (MAX .LT. 10.0) GO TO 110
      IF (SC .EQ. 0.0) SC = SMALNO
      GO TO 90
   80 IF (INFIN/SC .LT. MAX) GO TO 110
   90 L = ALOG(SC)/ALOG(BASE) + 0.5
      FACTOR = DBLE(BASE)**L
      IF (FACTOR .EQ. 1.D0) GO TO 110
      DO 100 I = 1,NN
         P(I) = FACTOR*P(I)
  100 CONTINUE
C
C     COMPUTE LOWER BOUND ON MODULI OF ZEROS.
C
  110 DO 120 I=1,NN
         PT(I) = ABS(SNGL(P(I)))
  120 CONTINUE
      PT(NN) = -PT(NN)
C
C     COMPUTE UPPER ESTIMATE OF BOUND
C
      X = EXP((ALOG(-PT(NN)) - ALOG(PT(1)))/FLOAT(N))
      IF (PT(N) .EQ. 0.0) GO TO 130
C
C     IF THE NEWTON STEP AT THE ORIGIN IS BETTER THEN USE IT.
C
      XM = -PT(NN)/PT(N)
      IF (XM .LT. X) X = XM
C
C     CHOP THE INTERVAL (0,X) UNTIL FF .LE. 0.
C
  130 XM = X*.1
      FF = PT(1)
      DO 140 I = 2,NN
         FF = FF*XM + PT(I)
  140 CONTINUE
      IF (FF .LE. 0.0) GO TO 150
      X = XM
      GO TO 130
  150 DX = X
C
C     DO NEWTON ITERATION UNTIL X CONVERGES TO TWO DECIMAL PLACES.
C
  160 IF (ABS(DX/X) .LE. 0.005) GO TO 180
      FF = PT(1)
      DF = FF
      DO 170 I = 2,N
         FF = FF*X + PT(I)
         DF = DF*X + FF
  170 CONTINUE
      FF = FF*X + PT(NN)
      DX = FF/DF
      X = X - DX
      GO TO 160
  180 BND = X
C
C     COMPUTE THE DERIVATIVE AS THE INTIAL K POLYNOMIAL
C     AND DO 5 STEPS WITH NO SHIFT.
C
      NM1 = N - 1
      DO 190 I = 2,N
         K(I) = FLOAT(NN - I)*P(I)/FLOAT(N)
  190 CONTINUE
      K(1) = P(1)
      AA = P(NN)
      BB = P(N)
      ZEROK = K(N) .EQ. 0.D0
      DO 230 JJ = 1,5
         CC = K(N)
         IF (ZEROK) GO TO 210
C
C     USE SCALED FORM OF RECURRENCE IF VALUE OF K AT 0 IS NONZERO.
C
         T = -AA/CC
         DO 200 I = 1,NM1
            J = NN - I
            K(J) = T*K(J - 1) + P(J)
  200    CONTINUE
         K(1) = P(1)
         ZEROK = DABS(K(N)) .LE. DABS(BB)*ETA*10.
         GO TO 230
C
C     USE UNSCALED FORM OF RECURRENCE
C
  210    DO 220 I = 1,NM1
            J = NN - I
            K(J) = K(J - 1)
  220    CONTINUE
         K(1) = 0.D0
         ZEROK = K(N).EQ.0.D0
  230 CONTINUE
C
C     SAVE K FOR RESTARTS WITH NEW SHIFTS
C
      DO 240 I = 1,N
         TEMP(I) = K(I)
  240 CONTINUE
C
C     LOOP TO SELECT THE QUADRATIC  CORRESPONDING TO EACH
C     NEW SHIFT
C
      DO 260 CNT = 1,20
C
C     QUADRATIC CORRESPONDS TO A DOUBLE SHIFT TO A
C     NON-REAL POINT AND ITS COMPLEX CONJUGATE. THE POINT
C     HAS MODULUS BND AND AMPLITUDE ROTATED BY 94 DEGREES
C     FROM THE PREVIOUS SHIFT.
C
         XXX = COSR*XX - SINR*YY
         YY = SINR*XX + COSR*YY
         XX = XXX
         SR = BND*XX
         SI = BND*YY
         U = -2.0D0*SR
         V = BND
C
C     SECOND STAGE CALCULATION, FIXED QUADRATIC. THE SECOND STAGE
C     JUMPS DIRECTLY TO ONE OF THE THIRD STAGE ITERATIONS.
C
         CALL FXSHFR(20*CNT, NZ, NN, P, QP, K, QK, SVK)
         IF (NZ .NE. 0) GO TO 300
C
C     IF THE ITERATION IS UNSUCCESSFUL ANOTHER QUADRATIC
C     IS CHOSEN AFTER RESTORING K.
C
         DO 250 I = 1,N
            K(I) = TEMP(I)
  250    CONTINUE
  260 CONTINUE
C
C     CONVERGENCE WAS NOT ACHIEVED AFTER 20 SHIFTS.
C
      RETURN
C
C     STORE THE ZEROS OBTAINED AND DEFLATE THE POLYNOMIAL.
C
  300 NUM = NUM + 1
      ZEROR(NUM) = SZR
      ZEROI(NUM) = SZI
      NN = NN - NZ
      N = NN - 1
      DO 310 I = 1,NN
         P(I) = QP(I)
  310 CONTINUE
      IF (NZ .EQ. 1) GO TO 40
      NUM = NUM + 1
      ZEROR(NUM) = LZR
      ZEROI(NUM) = LZI
      GO TO 40
      END
      SUBROUTINE FXSHFR(L2, NZ, NN, P, QP, K, QK, SVK)
C
C     COMPUTES UP TO  L2  FIXED SHIFT K-POLYNOMIALS,
C     TESTING FOR CONVERGENCE IN THE LINEAR OR QUADRATIC
C     CASE. INITIATES ONE OF THE VARIABLE SHIFT
C     ITERATIONS AND RETURNS WITH THE NUMBER OF ZEROS
C     FOUND.
C
C     L2 - LIMIT OF FIXED SHIFT STEPS
C     NZ - NUMBER OF ZEROS FOUND
C
      DOUBLE PRECISION P(NN), QP(NN), K(NN), QK(NN), SVK(NN)
      DOUBLE PRECISION SVU, SVV, UI, VI, S
      REAL BETAS, BETAV, OSS, OVV, SS, VV, TS, TV, OTS, OTV,
     *     TVV, TSS
      INTEGER L2, NZ, TYPE, I, J, IFLAG
      LOGICAL VPASS, SPASS, VTRY, STRY
C
      REAL ETA, ARE, MRE
      DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI
      COMMON /GLOBAL/  SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE
C
      N = NN - 1
      NZ = 0
      BETAV = .25
      BETAS = .25
      OSS = SR
      OVV = V
C
C     EVALUATE POLYNOMIAL BY SYNTHETIC DIVISION
C
      CALL QUADSD(NN, U, V, P, QP, A, B)
      CALL CALCSC(TYPE, N, K, QK)
      DO 80 J = 1,L2
C
C     CALCULATE NEXT K POLYNOMIAL AND ESTIMATE V
C
         CALL NEXTK(TYPE, N, QP, K, QK)
         CALL CALCSC(TYPE, N, K, QK)
         CALL NEWEST(TYPE, UI, VI, NN, P, K)
         VV = VI
C
C     ESTIMATE S
C
         SS = 0.0
         IF (K(N) .NE. 0.D0) SS = -P(NN)/K(N)
         TV = 1.0
         TS = 1.0
         IF (J .EQ. 1 .OR. TYPE .EQ. 3) GO TO 70
C
C     COMPUTE RELATIVE MEASURES OF CONVERGENCE OF S AND V
C     SEQUENCES
C
         IF (VV .NE. 0.0) TV = ABS((VV - OVV)/VV)
         IF (SS .NE. 0.0) TS = ABS((SS - OSS)/SS)
C
C     IF DECREASING, MULTIPLY TWO MOST RECENT
C     CONVERGENCE MEASURES
C
         TVV = 1.0
         IF (TV .LT. OTV) TVV = TV*OTV
         TSS = 1.0
         IF (TS .LT. OTS) TSS = TS*OTS
C
C     COMPARE WITH CONVERGENCE CRITERIA
C
         VPASS = TVV.LT.BETAV
         SPASS = TSS.LT.BETAS
         IF (.NOT.(SPASS .OR. VPASS)) GO TO 70
C
C     AT LEAST ONE SEQUENCE HAS PASSED THE CONVERGENCE
C     TEST. STORE VARIABLES BEFORE ITERATING
C
         SVU = U
         SVV = V
         DO 10 I = 1,N
            SVK(I) = K(I)
   10    CONTINUE
         S = SS
C
C     CHOOSE ITERATION ACCORDING TO THE FASTEST
C     CONVERGING SEQUENCE
C
         VTRY = .FALSE.
         STRY = .FALSE.
         IF (SPASS .AND. ((.NOT.VPASS) .OR.
     *                      TSS .LT. TVV)) GO TO 40
   20    CALL QUADIT(UI, VI, NZ, NN, P, QP, K, QK)
         IF (NZ .GT. 0) RETURN
C
C     QUADRATIC ITERATION HAS FAILED. FLAG THAT IT HAS
C     BEEN TRIED AND DECREASE THE CONVERGENCE CRITERION.
C
         VTRY = .TRUE.
         BETAV = BETAV*0.25
C
C     TRY LINEAR ITERATION IF IT HAS NOT BEEN TRIED AND
C     THE S SEQUENCE IS CONVERGING
C
         IF (STRY .OR. (.NOT.SPASS)) GO TO 50
         DO 30 I = 1,N
            K(I) = SVK(I)
   30    CONTINUE
   40    CALL REALIT(S, NZ, IFLAG, NN, P, QP, K, QK)
         IF (NZ .GT. 0) RETURN
C
C     LINEAR ITERATION HAS FAILED. FLAG THAT IT HAS BEEN
C     TRIED AND DECREASE THE CONVERGENCE CRITERION
C
         STRY = .TRUE.
         BETAS = BETAS*0.25
         IF (IFLAG .EQ. 0) GO TO 50
C
C     IF LINEAR ITERATION SIGNALS AN ALMOST DOUBLE REAL
C     ZERO ATTEMPT QUADRATIC INTERATION
C
         UI = -(S + S)
         VI = S*S
         GO TO 20
C
C     RESTORE VARIABLES
C
   50    U = SVU
         V = SVV
         DO 60 I=1,N
            K(I) = SVK(I)
   60    CONTINUE
C
C     TRY QUADRATIC ITERATION IF IT HAS NOT BEEN TRIED
C     AND THE V SEQUENCE IS CONVERGING
C
         IF (VPASS .AND. (.NOT.VTRY)) GO TO 20
C
C     RECOMPUTE QP AND SCALAR VALUES TO CONTINUE THE
C     SECOND STAGE
C
         CALL QUADSD(NN, U, V, P, QP, A, B)
         CALL CALCSC(TYPE, N, K, QK)
   70    OVV = VV
         OSS = SS
         OTV = TV
         OTS = TS
   80 CONTINUE
      RETURN
      END
      SUBROUTINE QUADIT(UU, VV, NZ, NN, P, QP, K, QK)
C
C     VARIABLE-SHIFT K-POLYNOMIAL ITERATION FOR A
C     QUADRATIC FACTOR CONVERGES ONLY IF THE ZEROS ARE
C     EQUIMODULAR OR NEARLY SO.
C
C     UU,VV - COEFFICIENTS OF STARTING QUADRATIC
C     NZ - NUMBER OF ZERO FOUND
C
      DOUBLE PRECISION UU, VV, P(NN), QP(NN), K(NN), QK(NN)
      DOUBLE PRECISION UI, VI
      REAL MP, OMP, EE, RELSTP, T, ZM
      INTEGER NZ, TYPE, I, J
      LOGICAL TRIED
C
      REAL ETA, ARE, MRE
      DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI
      COMMON /GLOBAL/  SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE
C
      N = NN - 1
      NZ = 0
      TRIED = .FALSE.
      U = UU
      V = VV
      J = 0
C MAIN LOOP
   10 CALL QUADPL(1.D0, U, V, SZR, SZI, LZR, LZI)
C
C     RETURN IF ROOTS OF THE QUADRATIC ARE REAL AND NOT CLOSE
C     TO MULTIPLE OR NEARLY EQUAL AND OF OPPOSITE SIGN
C
      IF (DABS(DABS(SZR) - DABS(LZR)) .GT. 1.D-2*DABS(LZR))
     *            RETURN
C
C     EVALUATE POLYNOMIAL BY QUADRATIC SYNTHETIC DIVISION
C
      CALL QUADSD(NN, U, V, P, QP, A, B)
      MP = DABS(A - SZR*B) + DABS(SZI*B)
C
C     COMPUTE A RIGOROUS BOUND ON THE ROUNDING ERROR IN
C     EVALUTING P
C
      ZM = SQRT(ABS(SNGL(V)))
      EE = 2.0*ABS(SNGL(QP(1)))
      T = -SZR*B
      DO 20 I = 2,N
         EE = EE*ZM + ABS(SNGL(QP(I)))
   20 CONTINUE
      EE = EE*ZM + ABS(SNGL(A) + T)
      EE = (5.0*MRE + 4.0*ARE)*EE - (5.0*MRE + 2.0*ARE)*
     *     (ABS(SNGL(A) + T) + ABS(SNGL(B))*ZM) +
     *     2.0*ARE*ABS(T)
C
C     ITERATION HAS CONVERGED SUFFICIENTLY IF THE
C     POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND
C
      IF (MP .GT. 20.0*EE) GO TO 30
      NZ = 2
      RETURN
   30 J = J + 1
C
C     STOP ITERATION AFTER 20 STEPS
C
      IF (J .GT. 20) RETURN
      IF (J .LT. 2) GO TO 50
      IF (RELSTP .GT. 0.01 .OR. MP .LT. OMP .OR. TRIED) GO TO 50
C
C     A CLUSTER APPEARS TO BE STALLING THE CONVERGENCE.
C     FIVE FIXED SHIFT STEPS ARE TAKEN WITH A U,V CLOSE
C     TO THE CLUSTER
C
      IF (RELSTP .LT. ETA) RELSTP = ETA
      RELSTP = SQRT(RELSTP)
      U = U - U*RELSTP
      V = V + V*RELSTP
      CALL QUADSD(NN, U, V, P, QP, A, B)
      DO 40 I = 1,5
         CALL CALCSC(TYPE, N, K, QK)
         CALL NEXTK(TYPE, N, QP, K, QK)
   40 CONTINUE
      TRIED = .TRUE.
      J = 0
   50 OMP = MP
C
C     CALCULATE NEXT K POLYNOMIAL AND NEW U AND V
C
      CALL CALCSC(TYPE, N, K, QK)
      CALL NEXTK(TYPE, N, QP, K, QK)
      CALL CALCSC(TYPE, N, K, QK)
      CALL NEWEST(TYPE, UI, VI, NN, P, K)
C
C     IF VI IS ZERO THE ITERATION IS NOT CONVERGING
C
      IF (VI .EQ. 0.D0) RETURN
      RELSTP = DABS((VI - V)/VI)
      U = UI
      V = VI
      GO TO 10
      END
      SUBROUTINE REALIT(SSS, NZ, IFLAG, NN, P, QP, K, QK)
C
C     VARIABLE-SHIFT H POLYNOMIAL ITERATION FOR A REAL ZERO.
C
C     SSS   - STARTING ITERATE
C     NZ    - NUMBER OF ZERO FOUND
C     IFLAG - FLAG TO INDICATE A PAIR OF ZEROS NEAR THE REAL
C             AXIS.
C
      DOUBLE PRECISION SSS, P(NN), QP(NN), K(NN), QK(NN)
      DOUBLE PRECISION PV, KV, T, S
      REAL MS, MP, OMP, EE
C
      REAL ETA, ARE, MRE
      DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI
      COMMON /GLOBAL/  SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE
C
      N = NN - 1
      NZ = 0
      S = SSS
      IFLAG = 0
      J = 0
C
C     EVALUATE P AT S
C
   10 PV = P(1)
      QP(1) = PV
      DO 20 I = 2,NN
         PV = PV*S + P(I)
         QP(I) = PV
   20 CONTINUE
      MP = DABS(PV)
C
C     COMPUTE A RIGOROUS BOUND ON THE ERROR IN EVALUATING P
C
      MS = DABS(S)
      EE = (MRE/(ARE+MRE))*ABS(SNGL(QP(1)))
      DO 30 I = 2,NN
         EE = EE*MS + ABS(SNGL(QP(I)))
   30 CONTINUE
C
C     ITERATION HAS CONVERGED SUFFICIENTLY IF THE
C     POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND
C
      IF (MP .GT. 20.0*((ARE + MRE)*EE - MRE*MP)) GO TO 40
      NZ = 1
      SZR = S
      SZI = 0.D0
      RETURN
   40 J = J + 1
C
C     STOP ITERATION AFTER 10 STEPS
C
      IF (J .GT. 10) RETURN
      IF (J .LT. 2) GO TO 50
      IF (DABS(T) .GT. 1.D-3*DABS(S-T) .OR. MP .LE. OMP)
     *      GO TO 50
C
C     A CLUSTER OF ZEROS NEAR THE REAL AXIS HAS BEEN
C     ENCOUNTERED RETURN WITH IFLAG SET TO INITIATE A
C     QUADRATIC ITERATION
C
      IFLAG = 1
      SSS = S
      RETURN
C
C     RETURN IF THE POLYNOMIAL VALUE HAS INCREASED
C     SIGNIFICANTLY
C
   50 OMP = MP
C
C     COMPUTE T, THE NEXT POLYNOMIAL, AND THE NEW ITERATE
C
      KV = K(1)
      QK(1) = KV
      DO 60 I = 2,N
         KV = KV*S + K(I)
         QK(I) = KV
   60 CONTINUE
      IF (DABS(KV) .LE. DABS(K(N))*10.*ETA) GO TO 80
C
C     USE THE SCALED FORM OF THE RECURRENCE IF THE VALUE
C     OF K AT S IS NONZERO
C
      T = -PV/KV
      K(1) = QP(1)
      DO 70 I = 2,N
         K(I) = T*QK(I-1) + QP(I)
   70 CONTINUE
      GO TO 100
C
C     USE UNSCALED FORM
C
   80 K(1) = 0.0D0
      DO 90 I = 2,N
         K(I) = QK(I-1)
   90 CONTINUE
  100 KV = K(1)
      DO 110 I = 2,N
         KV = KV*S + K(I)
  110 CONTINUE
      T = 0.D0
      IF (DABS(KV) .GT. DABS(K(N))*10.*ETA) T = -PV/KV
      S = S + T
      GO TO 10
      END
      SUBROUTINE CALCSC(TYPE, N, K, QK)
C
C     THIS ROUTINE CALCULATES SCALAR QUANTITIES USED TO
C     COMPUTE THE NEXT K POLYNOMIAL AND NEW ESTIMATES OF
C     THE QUADRATIC COEFFICIENTS.
C
C     TYPE - INTEGER VARIABLE SET HERE INDICATING HOW THE
C            CALCULATIONS ARE NORMALIZED TO AVOID OVERFLOW
C
      INTEGER TYPE
      DOUBLE PRECISION K(N), QK(N)
      DOUBLE PRECISION TOL
C
      REAL ETA, ARE, MRE
      DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI
      COMMON /GLOBAL/  SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE
C
C     SYNTHETIC DIVISION OF K BY THE QUADRATIC 1,U,V
C
      CALL QUADSD(N, U, V, K, QK, C, D)
      TOL = 100.0*ETA
      IF (DABS(C) .GT. TOL*DABS(K(N))) GO TO 10
      IF (DABS(D) .GT. TOL*DABS(K(N - 1))) GO TO 10
      TYPE = 3
C
C     TYPE=3 INDICATES THE QUADRATIC IS ALMOST A FACTOR OF K
C
      RETURN
   10 IF (DABS(D) .LT. DABS(C)) GO TO 20
      TYPE = 2
C
C     TYPE=2 INDICATES THAT ALL FORMULAS ARE DIVIDED BY D
C
      E = A/D
      F = C/D
      G = U*B
      H = V*B
      A3 = (A + G)*E + H*(B/D)
      A1 = B*F - A
      A7 = (F + U)*A + H
      RETURN
   20 TYPE = 1
C
C     TYPE=1 INDICATES THAT ALL FORMULAS ARE DIVIDED BY C
C
      E = A/C
      F = D/C
      G = U*E
      H = V*B
      A3 = A*E + (H/C + G)*B
      A1 = B - A*(D/C)
      A7 = A + G*D + H*F
      RETURN
      END
      SUBROUTINE NEXTK(TYPE, N, QP, K, QK)
C
C     COMPUTES THE NEXT K POLYNOMIALS USING THE SCALARS
C     COMPUTED IN CALCSC.
C
      INTEGER TYPE
      DOUBLE PRECISION QP(N), K(N), QK(N)
      DOUBLE PRECISION TEMP
      REAL ETA, ARE, MRE
      DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI
      COMMON /GLOBAL/  SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE
C
      IF (TYPE .EQ. 3) GO TO 40
      TEMP = A
      IF (TYPE .EQ. 1) TEMP = B
      IF (DABS(A1) .GT. DABS(TEMP)*ETA*10.) GO TO 20
C
C     IF A1 IS NEARLY ZERO THEN USE A SPECIAL FORM OF THE
C     RECURRENCE
C
      K(1) = 0.D0
      K(2) = -A7*QP(1)
      DO 10 I = 3,N
         K(I) = A3*QK(I-2) - A7*QP(I-1)
   10 CONTINUE
      RETURN
C
C     USE SCALED FORM OF THE RECURRENCE
C
   20 A7 = A7/A1
      A3 = A3/A1
      K(1) = QP(1)
      K(2) = QP(2) - A7*QP(1)
      DO 30 I = 3,N
         K(I) = A3*QK(I-2) - A7*QP(I-1) + QP(I)
   30 CONTINUE
      RETURN
C
C     USE UNSCALED FORM OF THE RECURRENCE IF TYPE IS 3
C
   40 K(1) = 0.D0
      K(2) = 0.D0
      DO 50 I = 3,N
         K(I) = QK(I - 2)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE NEWEST (TYPE, UU, VV, NN, P, K)
C
C     COMPUTE NEW ESTIMATES OF THE QUADRATIC COEFFICIENTS
C     USING THE SCALARS COMPUTED IN CALCSC.
C
      INTEGER TYPE
      DOUBLE PRECISION UU, VV, P(NN), K(NN)
      DOUBLE PRECISION A4, A5, B1, B2, C1, C2, C3, C4, TEMP
C
      REAL ETA, ARE, MRE
      DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI
      COMMON /GLOBAL/  SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7,
     *                 E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE
C
C     USE FORMULAS APPROPRIATE TO SETTING OF TYPE.
C
      N = NN - 1
      IF (TYPE .EQ. 3) GO TO 30
      IF (TYPE .EQ. 2) GO TO 10
         A4 = A + U*B + H*F
         A5 = C + (U + V*F)*D
         GO TO 20
   10 A4 = (A + G)*F + H
      A5 = (F + U)*C + V*D
C
C     EVALUATE NEW QUADRATIC COEFFICIENTS.
C
   20 B1 = -K(N)/P(NN)
      B2 = -(K(N - 1) + B1*P(N))/P(NN)
      C1 = V*B2*A1
      C2 = B1*A7
      C3 = B1*B1*A3
      C4 = C1 - C2 - C3
      TEMP = A5 + B1*A4 - C4
      IF (TEMP .EQ. 0.D0) GO TO 30
      UU = U - (U*(C3 + C2) + V*(B1*A1 + B2*A7))/TEMP
      VV = V*(1.D0 + C4/TEMP)
      RETURN
C
C     IF TYPE=3 THE QUADRATIC IS ZEROED
C
   30 UU = 0.D0
      VV = 0.D0
      RETURN
      END
      SUBROUTINE QUADSD (NN, U, V, P, Q, A, B)
C
C     DIVIDES P BY THE QUADRATIC  1,U,V  PLACING THE
C     QUOTIENT IN Q AND THE REMAINDER IN A,B.
C
      DOUBLE PRECISION P(NN), Q(NN), U, V, A, B, C
C
      B = P(1)
      Q(1) = B
      A = P(2) - U*B
      Q(2) = A
      DO 10 I = 3,NN
         C = P(I) - U*A - V*B
         Q(I) = C
         B = A
         A = C
   10 CONTINUE
      RETURN
      END
      SUBROUTINE QUADPL(A, B1, C, SR, SI, LR, LI)
C
C     CALCULATE THE ZEROS OF THE QUADRATIC A*Z**2+B1*Z+C.
C     THE QUADRATIC FORMULA, MODIFIED TO AVOID OVERFLOW,
C     IS USED TO FIND THE LARGER ZERO IF THE ZEROS ARE
C     REAL, AND BOTH ZEROS IF THE ZEROS ARE COMPLEX.
C     THE SMALLER REAL ZERO IS FOUND DIRECTLY FROM THE
C     PRODUCT OF THE ZEROS C/A.
C
      DOUBLE PRECISION A, B1, C, SR, SI, LR, LI, B, D, E
C
      IF (A .NE. 0.D0) GO TO 20
         SR = 0.D0
         IF (B1 .NE. 0.D0) SR = -C/B1
         LR = 0.D0
   10    SI = 0.D0
         LI = 0.D0
         RETURN
C
   20 IF (C .NE. 0.D0) GO TO 30
         SR = 0.D0
         LR = -B1/A
         GO TO 10
C
C     COMPUTE DISCRIMINANT AVOIDING OVERFLOW
C
   30 B = B1/2.D0
      IF (DABS(B) .LT. DABS(C)) GO TO 40
         E = 1.D0 - (A/B)*(C/B)
         D = DSQRT(DABS(E))*DABS(B)
         GO TO 50
   40 E = A
      IF (C .LT. 0.D0) E = -A
      E = B*(B/DABS(C)) - E
      D = DSQRT(DABS(E))*DSQRT(DABS(C))
   50 IF (E .LT. 0.D0) GO TO 60
C
C     REAL ZEROS
C
      IF (B .GE. 0.D0) D = -D
      LR = (-B + D)/A
      SR = 0.D0
      IF (LR .NE. 0.D0) SR = (C/LR)/A
      GO TO 10
C
C     COMPLEX CONJUGATE ZEROS
C
   60 SR = -B/A
      LR = SR
      SI = DABS(D/A)
      LI = -SI
      RETURN
      END
      SUBROUTINE DCPOLY (OPR,OPI,IDEG,ZEROR,ZEROI,NUM,WK)
C
C     THIS SUBROUTINE FINDS THE ZEROS OF A COMPLEX POLYNOMIAL.
C
C     OPR,OPI     - DOUBLE PRECISION ARRAYS OF LENGTH IDEG + 1.
C                   ON INPUT THESE ARRAYS CONTAIN THE REAL AND IMAGINARY
C                   PARTS OF THE COEFFICIENTS IN ORDER OF DECREASING
C                   POWERS.
C
C     IDEG        - INTEGER DEGREE OF THE POLYNOMIAL.
C
C     ZEROR,ZEROI - DOUBLE PRECISION ARRAYS OF LENGTH IDEG.
C                   ON OUTPUT THESE ARRAYS CONTAIN THE REAL AND
C                   IMAGINARY PARTS OF THE ZEROS.
C
C     NUM         - VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C                   IF NUM = -1 THEN THE LEADING COEFFICIENT OF THE
C                   POLYNOMIAL IS 0 OR IDEG .LT. 1. OTHERWISE, NUM
C                   IS THE NUMBER OF ZEROS THAT WERE OBTAINED. IF
C                   NUM .GE. 1 THEN THE REAL AND IMAGINARY PARTS OF
C                   THE ZEROS ARE STORED IN ZEROR(J) AND ZEROI(J)
C                   FOR J = 1,...,NUM.
C
C     WK          - DOUBLE PRECISION ARRAY OF LENGTH 10*(IDEG + 1).
C                   THE ARRAY IS A WORK SPACE FOR THE ROUTINE.
C
C     THE CODE HAS BEEN WRITTEN TO REDUCE THE CHANCE OF OVERFLOW
C     OCCURRING. IF IT DOES OCCUR, THERE IS STILL A POSSIBILITY THAT
C     THE ZEROFINDER WILL WORK PROVIDED THE OVERFLOWED QUANTITY IS
C     REPLACED BY A LARGE NUMBER.
C
      INTEGER IDEG
      DOUBLE PRECISION OPR(*),OPI(*),ZEROR(IDEG),ZEROI(IDEG),WK(*)
C
      INTEGER PR,PI,QPR,QPI,HR,HI,QHR,QHI,SHR,SHI
C
      IF (IDEG .LT. 1) GO TO 10
C
C     PARTITION THE WORKSPACE AND OBTAIN THE ZEROS
C
      IDP1 = IDEG + 1
C
      PR  = 1
      PI  = PR +  IDP1
      QPR = PI +  IDP1
      QPI = QPR + IDP1
      HR  = QPI + IDP1
      HI  = HR  + IDP1
      QHR = HI  + IDP1
      QHI = QHR + IDP1
      SHR = QHI + IDP1
      SHI = SHR + IDP1
C
      CALL DCPLY1 (OPR,OPI,IDEG,IDP1,ZEROR,ZEROI,WK(PR),WK(PI),
     *             WK(QPR),WK(QPI),WK(HR),WK(HI),WK(QHR),WK(QHI),
     *             WK(SHR),WK(SHI),NUM)
      RETURN
C
C     ERROR RETURN
C
   10 NUM = -1
      RETURN
      END
      SUBROUTINE DCPLY1 (OPR,OPI,IDEG,IDP1,ZEROR,ZEROI,PR,PI,QPR,QPI,
     *                   HR,HI,QHR,QHI,SHR,SHI,NUM)
C-------------------------
      DOUBLE PRECISION OPR(IDP1),OPI(IDP1),ZEROR(IDEG),ZEROI(IDEG),
     *                 PR(IDP1),PI(IDP1),QPR(IDP1),QPI(IDP1),
     *                 HR(IDP1),HI(IDP1),QHR(IDP1),QHI(IDP1),
     *                 SHR(IDP1),SHI(IDP1)
      DOUBLE PRECISION SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN
      DOUBLE PRECISION XX,YY,COSR,SINR,SMALNO,BASE,XXX,ZR,ZI,BND,
     *                 DCPABS,DPMPAR,SCALCP
      LOGICAL CONV
      INTEGER CNT1,CNT2
C-------------------------
C     THE FOLLOWING STATEMENTS SET THE MACHINE CONSTANTS USED
C     IN THE CODE. THE MEANING OF THE CONSTANTS ARE ...
C
C     ETA     THE SMALLEST POSITIVE NUMBER SUCH THAT
C             1.D0 + ETA IS GREATER THAN 1.D0
C     SMALNO  THE SMALLEST POSITIVE FLOATING POINT NUMBER.
C     INFIN   THE LARGEST POSITIVE FLOATING POINT NUMBER.
C     BASE    THE BASE OF THE FLOATING POINT ARITHMETIC
C             BEING USED.
C
                       ETA = DPMPAR(1)
                       SMALNO = DPMPAR(2)
                       INFIN = DPMPAR(3)
                       BASE = IPMPAR(4)
C-------------------------
C
C     INITIALIZATION
C
         ARE = ETA
         MRE = 2.D0*DSQRT(2.D0)*ETA
         XX = .70710678
         YY = -XX
         COSR = -.069756474
         SINR = .99756405
         NUM = 0
         NN = IDP1
C
C     THE ALGORITHM FAILS IF THE LEADING COEFFICIENT IS ZERO
C
         IF (OPR(1) .NE. 0.D0 .OR. OPI(1) .NE. 0.D0) GO TO 10
            NUM = -1
            RETURN
C
C     REMOVE THE ZEROS AT THE ORIGIN IF ANY.
C
   10    IF (OPR(NN) .NE. 0.D0 .OR. OPI(NN) .NE. 0.D0) GO TO 20
            NUM = NUM + 1
            ZEROR(NUM) = 0.D0
            ZEROI(NUM) = 0.D0
            NN = NN - 1
            GO TO 10
C
C     MAKE A COPY OF THE COEFFICIENTS.
C
   20    IF (NN .LT. 2) RETURN
         DO 30 I = 1,NN
            PR(I) = OPR(I)
            PI(I) = OPI(I)
            SHR(I) = DCPABS(PR(I),PI(I))
   30    CONTINUE
C
C     SCALE THE POLYNOMIAL.
C
         BND = SCALCP (NN,SHR,ETA,INFIN,SMALNO,BASE)
         IF (BND .EQ. 1.D0) GO TO 40
         DO 35 I = 1,NN
            PR(I) = BND*PR(I)
            PI(I) = BND*PI(I)
   35    CONTINUE
C
C     START THE ALGORITHM FOR OBTAINING A ZERO.
C
   40    IF (NN .GT. 2) GO TO 50
C
            NUM = IDEG
            CALL CDIVID(-PR(2),-PI(2),PR(1),PI(1),ZEROR(IDEG),
     *                   ZEROI(IDEG))
            RETURN
C
C     CALCULATE BND, A LOWER BOUND ON THE MODULUS OF THE ZEROS.
C
   50    DO 60 I = 1,NN
            SHR(I) = DCPABS(PR(I),PI(I))
   60    CONTINUE
         CALL CAUCHY(NN,BND,SHR,SHI)
C
C     OUTER LOOP TO CONTROL TWO MAJOR PASSES WITH DIFFERENT
C     SEQUENCES OF SHIFTS.
C
         DO 80 CNT1 = 1,2
C
C     FIRST STAGE CALCULATION. NO SHIFT.
C
            CALL NOSHFT(5,NN,TR,TI,ETA,PR,PI,HR,HI)
C
C     INNER LOOP TO SELECT A SHIFT.
C
            DO 70 CNT2 = 1,9
C
C     THE SHIFT IS CHOSEN WITH MODULUS BND AND AMPLITUDE ROTATED
C     BY 94 DEGREES FROM THE PREVIOUS SHIFT.
C
               XXX = COSR*XX - SINR*YY
               YY = SINR*XX + COSR*YY
               XX = XXX
               SR = BND*XX
               SI = BND*YY
C
C     SECOND STAGE CALCULATION, FIXED SHIFT. THE SECOND STAGE JUMPS
C     DIRECTLY TO THE THIRD STAGE ITERATION.
C
               CALL FXSHFT(10*CNT2,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI,
     *                     QHR,QHI,SHR,SHI,SR,SI,TR,TI,PVR,PVI,
     *                     ARE,MRE,ETA,INFIN)
               IF (CONV) GO TO 100
C
C     IF THE ITERATION IS UNSUCCESSFUL ANOTHER SHIFT IS CHOSEN.
C
   70       CONTINUE
C
C     IF 9 SHIFTS FAIL, THE OUTER LOOP IS REPEATED WITH ANOTHER
C     SEQUENCE OF SHIFTS.
C
   80    CONTINUE
         RETURN
C
C     A ZERO HAS BEEN OBTAINED. STORE THE ZERO AND DEFLATE
C     THE POLYNOMIAL.
C
  100    NUM = NUM + 1
         ZEROR(NUM) = ZR
         ZEROI(NUM) = ZI
         NN = NN - 1
         DO 110 I = 1,NN
            PR(I) = QPR(I)
            PI(I) = QPI(I)
  110    CONTINUE
         GO TO 40
         END
      DOUBLE PRECISION FUNCTION SCALCP(NN,PT,ETA,INFIN,SMALNO,BASE)
C
C     RETURNS A SCALE FACTOR TO MULTIPLY THE COEFFICIENTS OF THE
C     POLYNOMIAL. THE SCALING IS DONE TO AVOID OVERFLOW AND TO AVOID
C     UNDETECTED UNDERFLOW INTERFERING WITH THE CONVERGENCE CRITERION.
C     THE FACTOR IS A POWER OF THE BASE.
C
C     PT - MODULUS OF THE COEFFICIENTS OF P
C     ETA,INFIN,SMALNO,BASE - CONSTANTS DESCRIBING THE
C            FLOATING POINT ARITHMETIC.
C
      DOUBLE PRECISION PT(NN),ETA,INFIN,SMALNO,BASE,HI,LO,
     *                 MAX,MIN,X,SC
C
C     FIND THE LARGEST AND SMALLEST MODULI OF COEFFICIENTS.
C
      HI = DSQRT(INFIN)
      LO = SMALNO/ETA
      MAX = 0.D0
      MIN = INFIN
      DO 10 I = 1,NN
         X = PT(I)
         IF (X .GT. MAX) MAX = X
         IF (X .NE. 0.D0 .AND. X .LT. MIN) MIN = X
   10 CONTINUE
C
C     SCALE ONLY IF THERE ARE VERY LARGE OR VERY SMALL COEFFICIENTS.
C
      SCALCP = 1.D0
      SC = LO/MIN
      IF (SC .GT. 1.D0) GO TO 20
      IF (MAX .LE. HI) RETURN
      SC = 1.D0/(DSQRT(MAX)*DSQRT(MIN))
      GO TO 30
   20 IF (INFIN/SC .LT. MAX) RETURN
   30 L = DLOG(SC)/DLOG(BASE) + 0.5D0
      SCALCP = BASE**L
      RETURN
      END
      SUBROUTINE CAUCHY(NN,BND,PT,Q)
C
C     CAUCHY COMPUTES A LOWER BOUND BND ON THE MODULI OF THE ZEROS
C     OF A POLYNOMIAL. PT IS THE MODULUS OF THE COEFFICIENTS.
C
      DOUBLE PRECISION Q(NN),PT(NN),X,XM,F,DX,DF,BND
C
      PT(NN) = -PT(NN)
C
C     COMPUTE UPPER ESTIMATE OF BOUND.
C
      N = NN - 1
      X = DEXP((DLOG(-PT(NN)) - DLOG(PT(1)))/DBLE(FLOAT(N)))
      IF (PT(N) .EQ. 0.D0) GO TO 20
C
C     IF THE NEWTON STEP AT THE ORIGIN IS BETTER THEN USE IT.
C
         XM = -PT(NN)/PT(N)
         IF (XM .LT. X) X = XM
C
C     CHOP THE INTERVAL (0,X) UNTIL F .LE. 0.
C
   20 XM = 0.1D0*X
      F = PT(1)
      DO 30 I = 2,NN
         F = F*XM + PT(I)
   30 CONTINUE
      IF (F .LE. 0.D0) GO TO 40
         X = XM
         GO TO 20
   40 DX = X
C
C     DO NEWTON ITERATION UNTIL X CONVERGES TO TWO DECIMAL PLACES.
C
   50 IF (DABS(DX/X) .LE. 0.005D0) GO TO 70
         Q(1) = PT(1)
         DO 60 I = 2,NN
            Q(I) = Q(I - 1)*X + PT(I)
   60    CONTINUE
         F = Q(NN)
         DF = Q(1)
         DO 65 I = 2,N
            DF = DF*X + Q(I)
   65    CONTINUE
         DX = F/DF
         X = X - DX
         GO TO 50
C
   70 BND = X
      RETURN
      END
      SUBROUTINE NOSHFT(L1,NN,TR,TI,ETA,PR,PI,HR,HI)
C
C     COMPUTES THE DERIVATIVE POLYNOMIAL AS THE INITIAL H
C     POLYNOMIAL AND COMPUTES L1 NO-SHIFT H POLYNOMIALS.
C
      DOUBLE PRECISION TR,TI,ETA,PR(NN),PI(NN),HR(NN),HI(NN)
      DOUBLE PRECISION DN,T1,T2,XNI,DCPABS
C
      N = NN - 1
      NM1 = N - 1
      DN = N
      DO 10 I = 1,N
         XNI = NN - I
         HR(I) = XNI*PR(I)/DN
         HI(I) = XNI*PI(I)/DN
   10 CONTINUE
C
      DO 50 JJ = 1,L1
         IF (DCPABS(HR(N),HI(N)) .LE. 10.D0*ETA*DCPABS(PR(N),PI(N)))
     *      GO TO 30
         CALL CDIVID(-PR(NN),-PI(NN),HR(N),HI(N),TR,TI)
         DO 20 I = 1,NM1
            J = NN - I
            T1 = HR(J - 1)
            T2 = HI(J - 1)
            HR(J) = TR*T1 - TI*T2 + PR(J)
            HI(J) = TR*T2 + TI*T1 + PI(J)
   20    CONTINUE
         HR(1) = PR(1)
         HI(1) = PI(1)
         GO TO 50
C
C     IF THE CONSTANT TERM IS ESSENTIALLY ZERO, SHIFT H COEFFICIENTS.
C
   30    DO 40 I = 1,NM1
            J = NN - I
            HR(J) = HR(J - 1)
            HI(J) = HI(J - 1)
   40    CONTINUE
         HR(1) = 0.D0
         HI(1) = 0.D0
   50 CONTINUE
      RETURN
      END
      SUBROUTINE FXSHFT(L2,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI,
     *                  QHR,QHI,SHR,SHI,SR,SI,TR,TI,PVR,PVI,
     *                  ARE,MRE,ETA,INFIN)
C
C     COMPUTES L2 FIXED-SHIFT H POLYNOMIALS AND TESTS FOR CONVERGENCE.
C     INITIATES A VARIABLE-SHIFT ITERATION AND RETURNS WITH THE
C     APPROXIMATE ZERO IF SUCCESSFUL.
C
C     L2 - LIMIT OF FIXED-SHIFT STEPS
C     ZR,ZI - APPROXIMATE ZERO IF CONV IS .TRUE.
C     CONV - LOGICAL VARIABLE INDICATING CONVERGENCE OF STAGE 3
C            ITERATION
C
      DOUBLE PRECISION SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN,
     *             PR(NN),PI(NN),QPR(NN),QPI(NN),HR(NN),HI(NN),
     *             QHR(NN),QHI(NN),SHR(NN),SHI(NN)
      DOUBLE PRECISION ZR,ZI,OTR,OTI,SVSR,SVSI,DCPABS
      LOGICAL CONV,TEST,PASD,BOOL
C
         N = NN - 1
C
C     EVALUATE P AT S
C
         CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI)
         TEST = .TRUE.
         PASD = .FALSE.
C
C     CALCULATE T = -P(S)/H(S)
C
         CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI)
C
C     MAIN LOOP FOR ONE SECOND STAGE STEP.
C
         DO 50 J = 1,L2
            OTR = TR
            OTI = TI
C
C     COMPUTE NEXT H POLYNOMIAL AND NEW T.
C
            CALL NEXTH(BOOL,N,TR,TI,HR,HI,QPR,QPI,QHR,QHI)
            CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI)
            ZR = SR + TR
            ZI = SI + TI
C
C     TEST FOR CONVERGENCE UNLESS STAGE 3 HAS FAILED ONCE OR THIS
C     IS THE LAST H POLYNOMIAL.
C
            IF (BOOL .OR. (.NOT. TEST) .OR. J .EQ. L2) GO TO 50
            IF (DCPABS(TR - OTR,TI - OTI) .GE. 0.5D0*DCPABS(ZR,ZI))
     *         GO TO 40
            IF (.NOT. PASD) GO TO 30
C
C     THE WEAK CONVERGENCE TEST HAS BEEN PASSED TWICE. START THE
C     THIRD SHIFT ITERATION AFTER SAVING THE CURRENT H POLYNOMIAL
C     AND SHIFT.
C
               DO 10 I = 1,N
                  SHR(I) = HR(I)
                  SHI(I) = HI(I)
   10          CONTINUE
               SVSR = SR
               SVSI = SI
               CALL VRSHFT(10,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI,QHR,
     *                     QHI,SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN)
               IF (CONV) RETURN
C
C     THE ITERATION FAILED TO CONVERGE. TURN OFF TESTING AND RESTORE
C     H,S,PV AND T.
C
               TEST = .FALSE.
               DO 20 I = 1,N
                  HR(I) = SHR(I)
                  HI(I) = SHI(I)
   20          CONTINUE
               SR = SVSR
               SI = SVSI
               CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI)
               CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI)
               GO TO 50
C
   30       PASD = .TRUE.
            GO TO 50
C
   40       PASD = .FALSE.
   50    CONTINUE
C
C     ATTEMPT AN ITERATION WITH FINAL H POLYNOMIAL FROM SECOND STAGE.
C
      CALL VRSHFT(10,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI,QHR,QHI,
     *                  SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN)
      RETURN
      END
      SUBROUTINE VRSHFT(L3,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI,QHR,QHI,
     *                  SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN)
C
C     CARRIES OUT THE THIRD STAGE ITERATION.
C
C     L3 - LIMIT OF STEPS IN STAGE 3.
C     ZR,ZI - ON ENTRY CONTAIN THE INITIAL ITERATE. IF THE
C             ITERATION CONVERGES ZR,ZI CONTAIN THE FINAL
C             ITERATE ON EXIT.
C     CONV  - THE VALUE IS .TRUE. IF THE ITERATION CONVERGES.
C
      DOUBLE PRECISION SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN,
     *             PR(NN),PI(NN),QPR(NN),QPI(NN),HR(NN),HI(NN),
     *             QHR(NN),QHI(NN)
      DOUBLE PRECISION ZR,ZI,MP,MS,OMP,RELSTP,R1,R2,TP,ERREV,DCPABS
      LOGICAL CONV,B,BOOL
C
      CONV = .FALSE.
      B = .FALSE.
      SR = ZR
      SI = ZI
      N = NN - 1
C
C     MAIN LOOP FOR STAGE 3.
C
      DO 60 I = 1,L3
C
C     EVALUATE P AT S AND TEST FOR CONVERGENCE.
C
         CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI)
         MP = DCPABS(PVR,PVI)
         MS = DCPABS(SR,SI)
         IF (MP .GT. 20.D0*ERREV(NN,QPR,QPI,MS,MP,ARE,MRE))
     *      GO TO 10
C
C     POLYNOMIAL VALUE IS SMALLER THAN A BOUND ON THE ERROR
C     IN EVALUATING P. TERMINATE THE ITERATION.
C
            CONV = .TRUE.
            ZR = SR
            ZI = SI
            RETURN
C
   10    IF (I .EQ. 1) GO TO 40
         IF (B .OR. MP .LT. OMP .OR. RELSTP .GE. 0.05D0)
     *      GO TO 30
C
C     ITERATION HAS STALLED. PROBABLY A CLUSTER OF ZEROS. DO 5 FIXED
C     SHIFT STEPS INTO THE CLUSTER TO FORCE ONE ZERO TO DOMINATE.
C
         TP = RELSTP
         B = .TRUE.
         IF (RELSTP .LT. ETA) TP = ETA
         R1 = DSQRT(TP)
         R2 = SR*(1.D0 + R1) - SI*R1
         SI = SR*R1 + SI*(1.D0 + R1)
         SR = R2
         CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI)
         DO 20 J = 1,5
            CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI)
            CALL NEXTH(BOOL,N,TR,TI,HR,HI,QPR,QPI,QHR,QHI)
   20    CONTINUE
         OMP = INFIN
         GO TO 50
C
C     EXIT IF THE POLYNOMIAL VALUE INCREASES SIGNIFICANTLY.
C
   30    IF (0.1D0*MP .GT. OMP) RETURN
C
C     CALCULATE THE NEXT ITERATE.
C
   40    OMP = MP
C
   50    CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI)
         CALL NEXTH(BOOL,N,TR,TI,HR,HI,QPR,QPI,QHR,QHI)
         CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI)
         IF (BOOL) GO TO 60
         RELSTP = DCPABS(TR,TI)/DCPABS(SR,SI)
         SR = SR + TR
         SI = SI + TI
   60 CONTINUE
      RETURN
      END
      SUBROUTINE CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI)
C
C     THIS SUBROUTINE COMPUTES T = -P(S)/H(S)
C
C     BOOL - LOGICAL VARIABLE, WHICH IS SET TO .TRUE. IF H(S) IS
C            ESSENTIALLY ZERO.
C
      LOGICAL BOOL
      DOUBLE PRECISION SR,SI,TR,TI,PVR,PVI,ARE,HR(N),HI(N),
     *                 QHR(N),QHI(N)
      DOUBLE PRECISION HVR,HVI,DCPABS
C
C     EVALUATE H(S)
C
      CALL POLYEV (N,SR,SI,HR,HI,QHR,QHI,HVR,HVI)
      BOOL = DCPABS(HVR,HVI) .LE. 10.D0*ARE*DCPABS(HR(N),HI(N))
      IF (BOOL) GO TO 10
         CALL CDIVID(-PVR,-PVI,HVR,HVI,TR,TI)
         RETURN
   10 TR = 0.D0
      TI = 0.D0
      RETURN
      END
      SUBROUTINE NEXTH(BOOL,N,TR,TI,HR,HI,QPR,QPI,QHR,QHI)
C
C     CALCULATES THE NEXT SHIFTED H POLYNOMIAL.
C
C     BOOL - LOGICAL VARIABLE. IF .TRUE. H(S) IS ESSENTIALLY ZERO.
C
      LOGICAL BOOL
      DOUBLE PRECISION TR,TI,HR(N),HI(N),QPR(N),QPI(N),QHR(N),QHI(N)
      DOUBLE PRECISION T1,T2
C
      IF (BOOL) GO TO 20
         DO 10 J = 2,N
            T1 = QHR(J - 1)
            T2 = QHI(J - 1)
            HR(J) = TR*T1 - TI*T2 + QPR(J)
            HI(J) = TR*T2 + TI*T1 + QPI(J)
   10    CONTINUE
         HR(1) = QPR(1)
         HI(1) = QPI(1)
         RETURN
C
C     IF H(S) IS ZERO THEN REPLACE H WITH QH.
C
   20 DO 30 J = 2,N
         HR(J) = QHR(J - 1)
         HI(J) = QHI(J - 1)
   30 CONTINUE
      HR(1) = 0.D0
      HI(1) = 0.D0
      RETURN
      END
      SUBROUTINE POLYEV(N,SR,SI,PR,PI,QR,QI,PVR,PVI)
C
C     EVALUATES A POLYNOMIAL P AT S BY THE HORNER RECURRENCE ALGO.,
C     PLACING THE PARTIAL SUMS IN Q AND THE COMPUTED VALUE IN PV.
C
      DOUBLE PRECISION PR(N),PI(N),QR(N),QI(N),SR,SI,PVR,PVI,T
C
      QR(1) = PR(1)
      QI(1) = PI(1)
      PVR = QR(1)
      PVI = QI(1)
      DO 10 I = 2,N
         T = PVR*SR - PVI*SI + PR(I)
         PVI = PVR*SI + PVI*SR + PI(I)
         PVR = T
         QR(I) = PVR
         QI(I) = PVI
   10 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION ERREV(NN,QR,QI,MS,MP,ARE,MRE)
C
C     BOUNDS THE ERROR IN EVALUATING THE POLYNOMIAL BY THE HORNER
C     RECURRENCE ALGORITHM.
C
C     QR,QI   - THE PARTIAL SUMS
C     MS      - MODULUS OF THE POINT
C     MP      - MODULUS OF THE POLYNOMIAL VALUE
C     ARE,MRE - ERROR BOUNDS ON COMPLEX ADDITION AND MULTIPLICATION
C
      DOUBLE PRECISION QR(NN),QI(NN),MS,MP,ARE,MRE,E,DCPABS
C
      E = DCPABS(QR(1),QI(1))*MRE/(ARE + MRE)
      DO 10 I = 1,NN
         E = E*MS + DCPABS(QR(I),QI(I))
   10 CONTINUE
      ERREV = E*(ARE + MRE) - MP*MRE
      RETURN
      END
      SUBROUTINE RBND (N, C, W, ABSERR, RELERR, KLUST, KER)
C-----------------------------------------------------------------------
C
C     ABSTRACT
C
C         THIS ROUTINE COMPUTES ERROR BOUNDS AND CLUSTER COUNTS
C         FOR APPROXIMATE ZEROS OF A POLYNOMIAL WITH REAL COEFFICIENTS.
C         THE ZEROS MAY HAVE BEEN COMPUTED BY ANY APPROPRIATE ROUTINE.
C         THE METHOD USED IS BASED ON THE FACT THAT THE VALUE OF A
C         POLYNOMIAL AT ANY POINT IS EQUAL TO THE LEADING COEFFICIENT
C         TIMES THE PRODUCT OF THE DISTANCES FROM THAT POINT TO EACH
C         OF THE ZEROS.  GIVEN THE VALUE OF THE POLYNOMIAL AT AN
C         APPROXIMATE ZERO, RBND COMPUTES FOR EACH APPROXIMATE ZERO
C         THE RADIUS OF A CIRCLE ABOUT THAT APPROXIMATE ZERO WHICH
C         CONTAINS A TRUE ZERO OF THE POLYNOMIAL.  USING THE KNOWN
C         DISTRIBUTION OF APPROXIMATE ZEROS, AN ITERATIVE PROCEDURE
C         IS USED TO SHRINK THE RADII OF THE CIRCLES.
C
C     DESCRIPTION OF ARGUMENTS
C
C         INPUT---
C
C         N      - DEGREE OF THE POLYNOMIAL (NUMBER OF ZEROS).
C         C      - REAL ARRAY OF N+1 COEFFICIENTS OF THE POLYNOMIAL
C                  C(1) + C(2)*Z + ... + C(N+1)*Z**N
C         W      - COMPLEX ARRAY OF N APPROXIMATE ZEROS.
C
C         OUTPUT--
C
C         ABSERR - REAL ARRAY OF N ABSOLUTE ERROR BOUNDS.  ABSERR(I) IS
C                  THE ABSOLUTE ERROR BOUND IN THE ZERO (WR(I),WI(I)).
C         RELERR - REAL ARRAY OF N RELATIVE ERROR BOUNDS.  RELERR(I) IS
C                  THE RELATIVE ERROR BOUND IN THE ZERO (WR(I),WI(I)).
C         KLUST  - INTEGER ARRAY OF CLUSTER COUNTS FOR ZEROS.  THE TRUE
C                  ZERO CORRESPONDING TO I-TH APPROXIMATE ZERO LIES IN
C                  A CIRCLE OF RADIUS ABSERR(I). KLUST(I) IS THE NUMBER
C                  OF CIRCLES INCLUDING THE I-TH CIRCLE WHICH OVERLAP
C                  THE I-TH CIRCLE.  THE CLUSTER COUNT OFTEN INDICATES
C                  THE MULTIPLICITY OF A ZERO.
C         KER    - AN ERROR FLAG
C                --NORMAL CODE
C                  0  MEANS THE BOUNDS AND COUNTS WERE COMPUTED.
C                --ABNORMAL CODES
C                  1  N (DEGREE) MUST BE .GE. 1
C                  2  LEADING COEFFICIENT IS ZERO
C
C-------------------
C     WRITTEN BY CARL B. BAILEY AND MODIFIED BY WILLIAM R. GAVIN
C        SANDIA LABORATORIES
C        ALBUQUERQUE, NEW MEXICO
C        JANUARY 1976
C     MODIFIED BY A.H. MORRIS (NSWC)
C-----------------------------------------------------------------------
      COMPLEX W(N), Z
      INTEGER KLUST(N)
      REAL C(*), ABSERR(N), RELERR(N)
      DOUBLE PRECISION XR, XI, VR, VI, VT
      LOGICAL SHRUNK
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      IF (N .LT. 1) GO TO 200
      NP1 = N + 1
      POWER = 1.0/FLOAT(N)
      P = ABS(C(NP1))
      IF (P .EQ. 0.0) GO TO 210
      RAT = 4.0*EPS*ABS(C(1))/P
C
      DO 20 L = 1,N
         XR = REAL(W(L))
         XI = AIMAG(W(L))
         VR = C(NP1)
         VI = 0.0D0
         DO 10 J = 1,N
            M = NP1 - J
            VT = XR*VR - XI*VI + DBLE(C(M))
            VI = XR*VI + XI*VR
            VR = VT
   10    CONTINUE
         B = AMAX1(RAT,CPABS(SNGL(VR),SNGL(VI))/P)
C
C        SAVE PRODUCT OF DISTANCES TEMPORARILY
C
         RELERR(L) = B
         ABSERR(L) = B ** POWER
   20 CONTINUE
C
   30 SHRUNK = .FALSE.
      DO 50 J = 1,N
         IF (ABSERR(J) .EQ. 0.0) GO TO 50
         P = 1.0
         M = N
         DO 40 K = 1,N
            IF (K .EQ. J) GO TO 40
            Z = W(J) - W(K)
            DIST = CPABS(REAL(Z),AIMAG(Z))
            CERT = DIST - ABSERR(K)
            IF (CERT .LT. ABSERR(J)) GO TO 40
               P = P*CERT
               M = M - 1
   40    CONTINUE
         OLDERR = ABSERR(J)
         ABSERR(J) = RELERR(J)/P
         IF (M .GT. 1) ABSERR(J) = ABSERR(J)**(1.0/FLOAT(M))
         IF (ABSERR(J) .LT. OLDERR*0.99) SHRUNK = .TRUE.
   50 CONTINUE
      IF (SHRUNK) GO TO 30
C
      DO 80 J = 1,N
         KLUST(J) = 1
         WRAD = ABSERR(J)
         WNRM = CPABS(REAL(W(J)),AIMAG(W(J)))
         IF (WRAD .NE. 0.0) GO TO 60
            R = 0.0
            GO TO 80
   60    IF (WNRM .NE. 0.0) GO TO 70
            R = -1.0
            GO TO 80
   70    R = WRAD/WNRM
   80    RELERR(J) = R
C
      NM1 = N - 1
      DO 100 J = 1,NM1
         JP1 = J + 1
         DO 90 K = JP1,N
            Z = W(J) - W(K)
            DIST = CPABS(REAL(Z),AIMAG(Z))
            IF (DIST .GT. (ABSERR(J) + ABSERR(K))) GO TO 90
               KLUST(J) = KLUST(J) + 1
               KLUST(K) = KLUST(K) + 1
   90    CONTINUE
  100 CONTINUE
      KER = 0
      RETURN
C
C             ERROR RETURN
C
  200 KER = 1
      RETURN
  210 KER = 2
      RETURN
      END
      SUBROUTINE CBND (N, C, W, ABSERR, RELERR, KLUST, KER)
C-----------------------------------------------------------------------
C
C     ABSTRACT
C
C         THIS ROUTINE COMPUTES ERROR BOUNDS AND CLUSTER COUNTS FOR
C         APPROXIMATE ZEROS OF A POLYNOMIAL WITH COMPLEX COEFFICIENTS.
C         THE ZEROS MAY HAVE BEEN COMPUTED BY ANY APPROPRIATE ROUTINE.
C         THE METHOD USED IS BASED ON THE FACT THAT THE VALUE OF A
C         POLYNOMIAL AT ANY POINT IS EQUAL TO THE LEADING COEFFICIENT
C         TIMES THE PRODUCT OF THE DISTANCES FROM THAT POINT TO EACH
C         OF THE ZEROS.  GIVEN THE VALUE OF THE POLYNOMIAL AT AN
C         APPROXIMATE ZERO, CBND COMPUTES FOR EACH APPROXIMATE ZERO
C         THE RADIUS OF A CIRCLE ABOUT THAT APPROXIMATE ZERO WHICH
C         CONTAINS A TRUE ZERO OF THE POLYNOMIAL.  USING THE KNOWN
C         DISTRIBUTION OF APPROXIMATE ZEROS, AN ITERATIVE PROCEDURE
C         IS USED TO SHRINK THE RADII OF THE CIRCLES.
C
C     DESCRIPTION OF ARGUMENTS
C
C         INPUT---
C
C         N      - DEGREE OF THE POLYNOMIAL (NUMBER OF ZEROS).
C         C      - COMPLEX ARRAY OF N+1 COEFFICIENTS OF THE POLYNOMIAL
C                  C(1) + C(2)*Z + ... + C(N+1)*Z**N
C         W      - COMPLEX ARRAY OF N APPROXIMATE ZEROS.
C
C         OUTPUT--
C
C         ABSERR - REAL ARRAY OF ABSOLUTE ERROR BOUNDS.  ABSERR(I) IS
C                  THE ABSOLUTE ERROR BOUND IN THE ZERO (WR(I),WI(I)).
C         RELERR - REAL ARRAY OF RELATIVE ERROR BOUNDS.  RELERR(I) IS
C                  THE RELATIVE ERROR BOUND IN THE ZERO (WR(I),WI(I)).
C         KLUST  - INTEGER ARRAY OF CLUSTER COUNTS FOR ZEROS.  THE TRUE
C                  ZERO CORRESPONDING TO I-TH APPROXIMATE ZERO LIES IN
C                  A CIRCLE OF RADIUS ABSERR(I).  KLUST(I) IS THE NUMBER
C                  OF CIRCLES INCLUDING THE I-TH CIRCLE WHICH OVERLAP
C                  THE I-TH CIRCLE.  THE CLUSTER COUNT OFTEN INDICATES
C                  THE MULTIPLICITY OF A ZERO.
C         KER    - AN ERROR CODE
C                --NORMAL CODES
C                  0  MEANS THE BOUNDS AND COUNTS WERE COMPUTED.
C                --ABNORMAL CODES
C                  1  N (DEGREE) MUST BE .GE. 1
C                  2  LEADING COEFFICIENT IS ZERO
C
C-------------------
C     WRITTEN BY CARL B. BAILEY AND MODIFIED BY WILLIAM R. GAVIN
C        SANDIA LABORATORIES
C        ALBUQUERQUE, NEW MEXICO
C        JANUARY 1976
C     MODIFIED BY A.H. MORRIS (NSWC)
C-----------------------------------------------------------------------
      COMPLEX C(*), W(N), Z
      INTEGER KLUST(N)
      REAL ABSERR(N), RELERR(N)
      DOUBLE PRECISION XR, XI, VR, VI, VT
      LOGICAL SHRUNK
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                      EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      IF (N .LT. 1) GO TO 200
      NP1 = N + 1
      POWER = 1.0/FLOAT(N)
      P = CPABS(REAL(C(NP1)),AIMAG(C(NP1)))
      IF (P .EQ. 0.0) GO TO 210
      RAT = 4.0*EPS*CPABS(REAL(C(1)),AIMAG(C(1)))/P
C
      DO 20 L = 1,N
         XR = REAL(W(L))
         XI = AIMAG(W(L))
         VR = REAL(C(NP1))
         VI = AIMAG(C(NP1))
         DO 10 J = 1,N
            M = NP1 - J
            VT = XR*VR - XI*VI + DBLE(REAL(C(M)))
            VI = XR*VI + XI*VR + DBLE(AIMAG(C(M)))
            VR = VT
   10    CONTINUE
         B = AMAX1(RAT,CPABS(SNGL(VR),SNGL(VI))/P)
C
C        SAVE PRODUCT OF DISTANCES TEMPORARILY
C
         RELERR(L) = B
         ABSERR(L) = B ** POWER
   20 CONTINUE
C
   30 SHRUNK = .FALSE.
      DO 50 J = 1,N
         IF (ABSERR(J) .EQ. 0.0) GO TO 50
         P = 1.0
         M = N
         DO 40 K = 1,N
            IF (K .EQ. J) GO TO 40
            Z = W(J) - W(K)
            DIST = CPABS(REAL(Z),AIMAG(Z))
            CERT = DIST - ABSERR(K)
            IF (CERT .LT. ABSERR(J)) GO TO 40
               P = P*CERT
               M = M - 1
   40    CONTINUE
         OLDERR = ABSERR(J)
         ABSERR(J) = RELERR(J)/P
         IF (M .GT. 1) ABSERR(J) = ABSERR(J)**(1.0/FLOAT(M))
         IF (ABSERR(J) .LT. OLDERR*0.99) SHRUNK = .TRUE.
   50 CONTINUE
      IF (SHRUNK) GO TO 30
C
      DO 80 J = 1,N
         KLUST(J) = 1
         WRAD = ABSERR(J)
         WNRM = CPABS(REAL(W(J)),AIMAG(W(J)))
         IF (WRAD .NE. 0.0) GO TO 60
            R = 0.0
            GO TO 80
   60    IF (WNRM .NE. 0.0) GO TO 70
            R = -1.0
            GO TO 80
   70    R = WRAD/WNRM
   80    RELERR(J) = R
C
      NM1 = N - 1
      DO 100 J = 1,NM1
         JP1 = J + 1
         DO 90 K = JP1,N
            Z = W(J) - W(K)
            DIST = CPABS(REAL(Z),AIMAG(Z))
            IF (DIST .GT. (ABSERR(J) + ABSERR(K))) GO TO 90
               KLUST(J) = KLUST(J) + 1
               KLUST(K) = KLUST(K) + 1
   90    CONTINUE
  100 CONTINUE
      KER = 0
      RETURN
C
C             ERROR RETURN
C
  200 KER = 1
      RETURN
  210 KER = 2
      RETURN
      END
      SUBROUTINE  SCOPY(N,SX,INCX,SY,INCY)
C
C     COPIES A VECTOR, X, TO A VECTOR, Y.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO 1.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      REAL SX(*),SY(*)
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        SY(IY) = SX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SY(I) = SX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        SY(I) = SX(I)
        SY(I + 1) = SX(I + 1)
        SY(I + 2) = SX(I + 2)
        SY(I + 3) = SX(I + 3)
        SY(I + 4) = SX(I + 4)
        SY(I + 5) = SX(I + 5)
        SY(I + 6) = SX(I + 6)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  DCOPY(N,DX,INCX,DY,INCY)
C
C     COPIES A VECTOR, X, TO A VECTOR, Y.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(*),DY(*)
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        DY(I) = DX(I)
        DY(I + 1) = DX(I + 1)
        DY(I + 2) = DX(I + 2)
        DY(I + 3) = DX(I + 3)
        DY(I + 4) = DX(I + 4)
        DY(I + 5) = DX(I + 5)
        DY(I + 6) = DX(I + 6)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  CCOPY(N,CX,INCX,CY,INCY)
C
C     COPIES A VECTOR, X, TO A VECTOR, Y.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      COMPLEX CX(*),CY(*)
      INTEGER I,INCX,INCY,IX,IY,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        CY(IY) = CX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
   20 DO 30 I = 1,N
        CY(I) = CX(I)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE ISWAP (N,IX,INCX,IY,INCY)
C
C                EXTENDED B L A S  SUBPROGRAM
C
C    DESCRIPTION OF PARAMETERS
C
C     --INPUT--
C        N  NUMBER OF ELEMENTS IN INPUT VECTOR(S)
C       IX  INTEGER VECTOR WITH N ELEMENTS
C     INCX  STORAGE SPACING BETWEEN ELEMENTS OF IX
C       IY  INTEGER VECTOR WITH N ELEMENTS
C     INCY  STORAGE SPACING BETWEEN ELEMENTS OF IY
C
C     --OUTPUT--
C       IX  INPUT VECTOR IY (UNCHANGED IF N .LE. 0)
C       IY  INPUT VECTOR IX (UNCHANGED IF N .LE. 0)
C
C     INTERCHANGE INTEGER IX AND INTEGER IY.
C     FOR I = 0 TO N-1, INTERCHANGE  IX(LX+I*INCX) AND IY(LY+I*INCY),
C     WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C     DEFINED IN A SIMILAR WAY USING INCY.
C
C***AUTHOR  VANDEVENDER, W. (SNLA), 1985
C
      INTEGER IX(*),IY(*),ITEMP1,ITEMP2,ITEMP3
C
      IF (N .LE. 0) RETURN
      IF (INCX .NE. INCY) GO TO 5
      IF (INCX-1) 5,20,60
    5 CONTINUE
C
C       CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
C
      IIX = 1
      IIY = 1
      IF (INCX .LT. 0) IIX = (1-N)*INCX + 1
      IF (INCY .LT. 0) IIY = (1-N)*INCY + 1
      DO 10 I = 1,N
         ITEMP1 = IX(IIX)
         IX(IIX) = IY(IIY)
         IY(IIY) = ITEMP1
         IIX = IIX + INCX
         IIY = IIY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C       CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3.
C
   20 M = MOD(N,3)
      IF (M .EQ. 0) GO TO 40
      DO 30 I = 1,M
         ITEMP1 = IX(I)
         IX(I) = IY(I)
         IY(I) = ITEMP1
   30 CONTINUE
      IF (N .LT. 3) RETURN
C
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
         ITEMP1 = IX(I)
         ITEMP2 = IX(I+1)
         ITEMP3 = IX(I+2)
         IX(I) = IY(I)
         IX(I+1) = IY(I+1)
         IX(I+2) = IY(I+2)
         IY(I) = ITEMP1
         IY(I+1) = ITEMP2
         IY(I+2) = ITEMP3
   50 CONTINUE
      RETURN
C
C     CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
   60 NS = N*INCX
      DO 70 I = 1,NS,INCX
         ITEMP1 = IX(I)
         IX(I) = IY(I)
         IY(I) = ITEMP1
   70 CONTINUE
      RETURN
      END
      SUBROUTINE  SSWAP (N,SX,INCX,SY,INCY)
C
C     INTERCHANGES TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO 1.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      REAL SX(*),SY(*),STEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        STEMP = SX(IX)
        SX(IX) = SY(IY)
        SY(IY) = STEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C       CLEAN-UP LOOP
C
   20 M = MOD(N,3)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        STEMP = SX(I)
        SX(I) = SY(I)
        SY(I) = STEMP
   30 CONTINUE
      IF( N .LT. 3 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
        STEMP = SX(I)
        SX(I) = SY(I)
        SY(I) = STEMP
        STEMP = SX(I + 1)
        SX(I + 1) = SY(I + 1)
        SY(I + 1) = STEMP
        STEMP = SX(I + 2)
        SX(I + 2) = SY(I + 2)
        SY(I + 2) = STEMP
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  DSWAP (N,DX,INCX,DY,INCY)
C
C     INTERCHANGES TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(*),DY(*),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DX(IX)
        DX(IX) = DY(IY)
        DY(IY) = DTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C       CLEAN-UP LOOP
C
   20 M = MOD(N,3)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
   30 CONTINUE
      IF( N .LT. 3 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
        DTEMP = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP
        DTEMP = DX(I + 1)
        DX(I + 1) = DY(I + 1)
        DY(I + 1) = DTEMP
        DTEMP = DX(I + 2)
        DX(I + 2) = DY(I + 2)
        DY(I + 2) = DTEMP
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  CSWAP (N,CX,INCX,CY,INCY)
C
C     INTERCHANGES TWO VECTORS.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      COMPLEX CX(*),CY(*),CTEMP
      INTEGER I,INCX,INCY,IX,IY,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        CTEMP = CX(IX)
        CX(IX) = CY(IY)
        CY(IY) = CTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
   20 DO 30 I = 1,N
        CTEMP = CX(I)
        CX(I) = CY(I)
        CY(I) = CTEMP
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  SROT (N,SX,INCX,SY,INCY,C,S)
C
C     APPLIES A PLANE ROTATION.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      REAL SX(*),SY(*),STEMP,C,S
      INTEGER I,INCX,INCY,IX,IY,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        STEMP = C*SX(IX) + S*SY(IY)
        SY(IY) = C*SY(IY) - S*SX(IX)
        SX(IX) = STEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
   20 DO 30 I = 1,N
        STEMP = C*SX(I) + S*SY(I)
        SY(I) = C*SY(I) - S*SX(I)
        SX(I) = STEMP
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  DROT (N,DX,INCX,DY,INCY,C,S)
C
C     APPLIES A PLANE ROTATION.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(*),DY(*),DTEMP,C,S
      INTEGER I,INCX,INCY,IX,IY,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = C*DX(IX) + S*DY(IY)
        DY(IY) = C*DY(IY) - S*DX(IX)
        DX(IX) = DTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
   20 DO 30 I = 1,N
        DTEMP = C*DX(I) + S*DY(I)
        DY(I) = C*DY(I) - S*DX(I)
        DX(I) = DTEMP
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  CSROT (N,CX,INCX,CY,INCY,C,S)
C
C     APPLIES A PLANE ROTATION, WHERE THE COS AND SIN (C AND S) ARE REAL
C     AND THE VECTORS CX AND CY ARE COMPLEX.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      COMPLEX CX(*),CY(*),CTEMP
      REAL C,S
      INTEGER I,INCX,INCY,IX,IY,N
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        CTEMP = C*CX(IX) + S*CY(IY)
        CY(IY) = C*CY(IY) - S*CX(IX)
        CX(IX) = CTEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
   20 DO 30 I = 1,N
        CTEMP = C*CX(I) + S*CY(I)
        CY(I) = C*CY(I) - S*CX(I)
        CX(I) = CTEMP
   30 CONTINUE
      RETURN
      END
      SUBROUTINE SROTMG (SD1,SD2,SX1,SY1,SPARAM)
C
C     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
C     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*
C     SY1)**T.
C     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
C
C       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
C     H=(          )    (          )    (          )    (          )
C       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
C
C     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
C     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
C     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
C
C     IT IS ASSUMED THAT GAMSQ = GAM*GAM AND RGAMSQ = ONE/(GAM*GAM).
C     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
C     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
C     OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
C
      DIMENSION SPARAM(5)
C
      DATA ZERO,ONE,TWO /0.E0,1.E0,2.E0/
      DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
C
      IF (SD1 .LT. ZERO) GO TO 60
      SP2 = SD2*SY1
      IF (SP2 .NE. ZERO) GO TO 20
          SFLAG = -TWO
          GO TO 260
C
C     REGULAR-CASE..
C
   20 SP1 = SD1*SX1
      SQ1 = SP1*SX1
      SQ2 = SP2*SY1
C
      IF (ABS(SQ1) .LE. ABS(SQ2)) GO TO 40
          SH21 = -SY1/SX1
          SH12 = SP2/SP1
C
          SU = ONE - SH12*SH21
          IF (SU .LE. ZERO) GO TO 60
C
               SFLAG = ZERO
               SH11 = ONE
               SH22 = ONE
               SD1 = SD1/SU
               SD2 = SD2/SU
               SX1 = SX1*SU
C         GO SCALE-CHECK..
               GO TO 100
C
   40 CONTINUE
          IF (SD2 .LT. ZERO) GO TO 60
               SFLAG = ONE
               SH11 = SP1/SP2
               SH21 = -ONE
               SH12 = ONE
               SH22 = SX1/SY1
C
               SU = ONE + SH11*SH22
               STEMP = SD2/SU
               SD2 = SD1/SU
               SD1 = STEMP
               SX1 = SY1*SU
C         GO SCALE-CHECK
               GO TO 100
C
C     PROCEDURE..ZERO-H-D-AND-SX1..
C
   60 CONTINUE
          SFLAG = -ONE
          SH11 = ZERO
          SH12 = ZERO
          SH21 = ZERO
          SH22 = ZERO
C
          SD1 = ZERO
          SD2 = ZERO
          SX1 = ZERO
          GO TO 250
C
C     PROCEDURE..SCALE-CHECK
C
  100 CONTINUE
  110     CONTINUE
          IF (SD1 .GT. RGAMSQ) GO TO 130
               IF (SD1 .EQ. ZERO) GO TO 160
               SFLAG = -ONE
               SD1 = SD1*(GAM*GAM)
               SX1 = SX1/GAM
               SH11 = SH11/GAM
               SH12 = SH12/GAM
          GO TO 110
C
  130 CONTINUE
  140     CONTINUE
          IF (SD1 .LT. GAMSQ) GO TO 160
               SFLAG = -ONE
               SD1 = SD1/(GAM*GAM)
               SX1 = SX1*GAM
               SH11 = SH11*GAM
               SH12 = SH12*GAM
          GO TO 140
C
  160 CONTINUE
  170     CONTINUE
          IF (ABS(SD2) .GT. RGAMSQ) GO TO 190
               IF (SD2 .EQ. ZERO) GO TO 220
               SFLAG = -ONE
               SD2 = SD2*(GAM*GAM)
               SH21 = SH21/GAM
               SH22 = SH22/GAM
          GO TO 170
C
  190 CONTINUE
  200     CONTINUE
          IF (ABS(SD2) .LT. GAMSQ) GO TO 220
               SFLAG = -ONE
               SD2 = SD2/(GAM*GAM)
               SH21 = SH21*GAM
               SH22 = SH22*GAM
          GO TO 200
C
  220 CONTINUE
          IF(SFLAG)250,230,240
  230     CONTINUE
               SPARAM(3)=SH21
               SPARAM(4)=SH12
               GO TO 260
  240     CONTINUE
               SPARAM(2)=SH11
               SPARAM(5)=SH22
               GO TO 260
  250     CONTINUE
               SPARAM(2)=SH11
               SPARAM(3)=SH21
               SPARAM(4)=SH12
               SPARAM(5)=SH22
  260 CONTINUE
          SPARAM(1)=SFLAG
          RETURN
      END
      SUBROUTINE SROTM (N,SX,INCX,SY,INCY,SPARAM)
C
C     APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
C
C     (SX**T), WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN
C     (SY**T)
C
C     SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
C     LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY.
C
C     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
C
C       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
C     H=(          )    (          )    (          )    (          )
C       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
C
      DIMENSION SX(*), SY(*), SPARAM(5)
C
      DATA ZERO,TWO/0.E0,2.E0/
C
      SFLAG=SPARAM(1)
      IF(N .LE. 0 .OR.(SFLAG+TWO.EQ.ZERO)) GO TO 140
          IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70
C
               NSTEPS=N*INCX
               IF(SFLAG) 50,10,30
   10          CONTINUE
               SH21=SPARAM(3)
               SH12=SPARAM(4)
                    DO 20 I=1,NSTEPS,INCX
                    W=SX(I)
                    Z=SY(I)
                    SX(I)=W+Z*SH12
                    SY(I)=W*SH21+Z
   20               CONTINUE
               GO TO 140
   30          CONTINUE
               SH11=SPARAM(2)
               SH22=SPARAM(5)
                    DO 40 I=1,NSTEPS,INCX
                    W=SX(I)
                    Z=SY(I)
                    SX(I)=W*SH11+Z
                    SY(I)=-W+SH22*Z
   40               CONTINUE
               GO TO 140
   50          CONTINUE
               SH11=SPARAM(2)
               SH21=SPARAM(3)
               SH12=SPARAM(4)
               SH22=SPARAM(5)
                    DO 60 I=1,NSTEPS,INCX
                    W=SX(I)
                    Z=SY(I)
                    SX(I)=W*SH11+Z*SH12
                    SY(I)=W*SH21+Z*SH22
   60               CONTINUE
               GO TO 140
   70     CONTINUE
          KX=1
          KY=1
          IF(INCX .LT. 0) KX=1+(1-N)*INCX
          IF(INCY .LT. 0) KY=1+(1-N)*INCY
C
          IF(SFLAG)120,80,100
   80     CONTINUE
          SH21=SPARAM(3)
          SH12=SPARAM(4)
               DO 90 I=1,N
               W=SX(KX)
               Z=SY(KY)
               SX(KX)=W+Z*SH12
               SY(KY)=W*SH21+Z
               KX=KX+INCX
               KY=KY+INCY
   90          CONTINUE
          GO TO 140
  100     CONTINUE
          SH11=SPARAM(2)
          SH22=SPARAM(5)
               DO 110 I=1,N
               W=SX(KX)
               Z=SY(KY)
               SX(KX)=W*SH11+Z
               SY(KY)=-W+SH22*Z
               KX=KX+INCX
               KY=KY+INCY
  110          CONTINUE
          GO TO 140
  120     CONTINUE
          SH11=SPARAM(2)
          SH21=SPARAM(3)
          SH12=SPARAM(4)
          SH22=SPARAM(5)
               DO 130 I=1,N
               W=SX(KX)
               Z=SY(KY)
               SX(KX)=W*SH11+Z*SH12
               SY(KY)=W*SH21+Z*SH22
               KX=KX+INCX
               KY=KY+INCY
  130          CONTINUE
  140     CONTINUE
          RETURN
          END
      SUBROUTINE DROTMG (DD1,DD2,DX1,DY1,DPARAM)
C
C     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
C     THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)*
C     DY1)**T.
C     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
C
C       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
C     H=(          )    (          )    (          )    (          )
C       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
C
C     LOCATIONS 2-4 OF DPARAM CONTAIN DH11,DH21,DH12, AND DH22
C     RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
C     VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
C
C     IT IS ASSUMED THAT GAMSQ = GAM*GAM AND RGAMSQ = ONE/(GAM*GAM).
C     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
C     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
C     OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
C
      DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2,
     1 DQ2,DU,DY1,ZERO,GAMSQ,DD1,DFLAG,DH12,DH22,DP1,DQ1,
     2 DTEMP,DX1,TWO
      DIMENSION DPARAM(5)
C
      DATA ZERO,ONE,TWO /0.D0,1.D0,2.D0/
      DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
C
      IF (DD1 .LT. ZERO) GO TO 60
      DP2 = DD2*DY1
      IF (DP2 .NE. ZERO) GO TO 20
          DFLAG = -TWO
          GO TO 260
C
C     REGULAR-CASE..
C
   20 DP1 = DD1*DX1
      DQ1 = DP1*DX1
      DQ2 = DP2*DY1
C
      IF (DABS(DQ1) .LE. DABS(DQ2)) GO TO 40
          DH21 = -DY1/DX1
          DH12 = DP2/DP1
C
          DU = ONE - DH12*DH21
          IF (DU .LE. ZERO) GO TO 60
C
               DFLAG = ZERO
               DH11 = ONE
               DH22 = ONE
               DD1 = DD1/DU
               DD2 = DD2/DU
               DX1 = DX1*DU
C         GO SCALE-CHECK..
               GO TO 100
C
   40 CONTINUE
          IF (DD2 .LT. ZERO) GO TO 60
               DFLAG = ONE
               DH11 = DP1/DP2
               DH21 = -ONE
               DH12 = ONE
               DH22 = DX1/DY1
C
               DU = ONE + DH11*DH22
               DTEMP = DD2/DU
               DD2 = DD1/DU
               DD1 = DTEMP
               DX1 = DY1*DU
C         GO SCALE-CHECK
               GO TO 100
C
C     PROCEDURE..ZERO-H-D-AND-DX1..
C
   60 CONTINUE
          DFLAG = -ONE
          DH11 = ZERO
          DH12 = ZERO
          DH21 = ZERO
          DH22 = ZERO
C
          DD1 = ZERO
          DD2 = ZERO
          DX1 = ZERO
          GO TO 250
C
C     PROCEDURE..SCALE-CHECK
C
  100 CONTINUE
  110     CONTINUE
          IF (DD1 .GT. RGAMSQ) GO TO 130
               IF (DD1 .EQ. ZERO) GO TO 160
               DFLAG = -ONE
               DD1 = DD1*(GAM*GAM)
               DX1 = DX1/GAM
               DH11 = DH11/GAM
               DH12 = DH12/GAM
          GO TO 110
C
  130 CONTINUE
  140     CONTINUE
          IF (DD1 .LT. GAMSQ) GO TO 160
               DFLAG = -ONE
               DD1 = DD1/(GAM*GAM)
               DX1 = DX1*GAM
               DH11 = DH11*GAM
               DH12 = DH12*GAM
          GO TO 140
C
  160 CONTINUE
  170     CONTINUE
          IF (DABS(DD2) .GT. RGAMSQ) GO TO 190
               IF (DD2 .EQ. ZERO) GO TO 220
               DFLAG = -ONE
               DD2 = DD2*(GAM*GAM)
               DH21 = DH21/GAM
               DH22 = DH22/GAM
          GO TO 170
C
  190 CONTINUE
  200     CONTINUE
          IF (DABS(DD2) .LT. GAMSQ) GO TO 220
               DFLAG = -ONE
               DD2 = DD2/(GAM*GAM)
               DH21 = DH21*GAM
               DH22 = DH22*GAM
          GO TO 200
C
  220 CONTINUE
          IF(DFLAG)250,230,240
  230     CONTINUE
               DPARAM(3)=DH21
               DPARAM(4)=DH12
               GO TO 260
  240     CONTINUE
               DPARAM(2)=DH11
               DPARAM(5)=DH22
               GO TO 260
  250     CONTINUE
               DPARAM(2)=DH11
               DPARAM(3)=DH21
               DPARAM(4)=DH12
               DPARAM(5)=DH22
  260 CONTINUE
          DPARAM(1)=DFLAG
          RETURN
      END
      SUBROUTINE DROTM (N,DX,INCX,DY,INCY,DPARAM)
C
C     APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
C
C     (DX**T), WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
C     (DY**T)
C
C     DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
C     LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
C
C     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
C
C       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
C     H=(          )    (          )    (          )    (          )
C       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
C
      DOUBLE PRECISION DFLAG,DH12,DH22,DX,TWO,Z,DH11,DH21,
     *                 DPARAM,DY,W,ZERO
      DIMENSION DX(*), DY(*), DPARAM(5)
C
      DATA ZERO,TWO/0.D0,2.D0/
C
      DFLAG=DPARAM(1)
      IF(N .LE. 0 .OR.(DFLAG+TWO.EQ.ZERO)) GO TO 140
          IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70
C
               NSTEPS=N*INCX
               IF(DFLAG) 50,10,30
   10          CONTINUE
               DH21=DPARAM(3)
               DH12=DPARAM(4)
                    DO 20 I=1,NSTEPS,INCX
                    W=DX(I)
                    Z=DY(I)
                    DX(I)=W+Z*DH12
                    DY(I)=W*DH21+Z
   20               CONTINUE
               GO TO 140
   30          CONTINUE
               DH11=DPARAM(2)
               DH22=DPARAM(5)
                    DO 40 I=1,NSTEPS,INCX
                    W=DX(I)
                    Z=DY(I)
                    DX(I)=W*DH11+Z
                    DY(I)=-W+DH22*Z
   40               CONTINUE
               GO TO 140
   50          CONTINUE
               DH11=DPARAM(2)
               DH21=DPARAM(3)
               DH12=DPARAM(4)
               DH22=DPARAM(5)
                    DO 60 I=1,NSTEPS,INCX
                    W=DX(I)
                    Z=DY(I)
                    DX(I)=W*DH11+Z*DH12
                    DY(I)=W*DH21+Z*DH22
   60               CONTINUE
               GO TO 140
   70     CONTINUE
          KX=1
          KY=1
          IF(INCX .LT. 0) KX=1+(1-N)*INCX
          IF(INCY .LT. 0) KY=1+(1-N)*INCY
C
          IF(DFLAG)120,80,100
   80     CONTINUE
          DH21=DPARAM(3)
          DH12=DPARAM(4)
               DO 90 I=1,N
               W=DX(KX)
               Z=DY(KY)
               DX(KX)=W+Z*DH12
               DY(KY)=W*DH21+Z
               KX=KX+INCX
               KY=KY+INCY
   90          CONTINUE
          GO TO 140
  100     CONTINUE
          DH11=DPARAM(2)
          DH22=DPARAM(5)
               DO 110 I=1,N
               W=DX(KX)
               Z=DY(KY)
               DX(KX)=W*DH11+Z
               DY(KY)=-W+DH22*Z
               KX=KX+INCX
               KY=KY+INCY
  110          CONTINUE
          GO TO 140
  120     CONTINUE
          DH11=DPARAM(2)
          DH21=DPARAM(3)
          DH12=DPARAM(4)
          DH22=DPARAM(5)
               DO 130 I=1,N
               W=DX(KX)
               Z=DY(KY)
               DX(KX)=W*DH11+Z*DH12
               DY(KY)=W*DH21+Z*DH22
               KX=KX+INCX
               KY=KY+INCY
  130          CONTINUE
  140     CONTINUE
          RETURN
          END
      REAL FUNCTION SDOT(N,SX,INCX,SY,INCY)
C
C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      REAL SX(*),SY(*),STEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      STEMP = 0.0E0
      SDOT = 0.0E0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        STEMP = STEMP + SX(IX)*SY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      SDOT = STEMP
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        STEMP = STEMP + SX(I)*SY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        STEMP = STEMP + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) +
     *   SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4)
   50 CONTINUE
   60 SDOT = STEMP
      RETURN
      END
      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
C
C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(*),DY(*),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      DDOT = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DTEMP + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      DDOT = DTEMP
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
     *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
   60 DDOT = DTEMP
      RETURN
      END
      COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY)
C
C     FORMS THE DOT PRODUCT OF TWO VECTORS, CONJUGATING THE FIRST
C     VECTOR.
C     JACK DONGARRA, LINPACK,  3/11/78.
C
      COMPLEX CX(*),CY(*),CTEMP
      INTEGER I,INCX,INCY,IX,IY,N
C
      CTEMP = (0.0,0.0)
      CDOTC = (0.0,0.0)
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        CTEMP = CTEMP + CONJG(CX(IX))*CY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      CDOTC = CTEMP
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
   20 DO 30 I = 1,N
        CTEMP = CTEMP + CONJG(CX(I))*CY(I)
   30 CONTINUE
      CDOTC = CTEMP
      RETURN
      END
      COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY)
C
C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      COMPLEX CX(*),CY(*),CTEMP
      INTEGER I,INCX,INCY,IX,IY,N
C
      CTEMP = (0.0,0.0)
      CDOTU = (0.0,0.0)
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        CTEMP = CTEMP + CX(IX)*CY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      CDOTU = CTEMP
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
   20 DO 30 I = 1,N
        CTEMP = CTEMP + CX(I)*CY(I)
   30 CONTINUE
      CDOTU = CTEMP
      RETURN
      END
      SUBROUTINE  SSCAL(N,SA,SX,INCX)
C
C     SCALES A VECTOR BY A CONSTANT.
C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO 1.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      REAL SA,SX(*)
      INTEGER I,INCX,M,MP1,N,NINCX
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        SX(I) = SA*SX(I)
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SX(I) = SA*SX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        SX(I) = SA*SX(I)
        SX(I + 1) = SA*SX(I + 1)
        SX(I + 2) = SA*SX(I + 2)
        SX(I + 3) = SA*SX(I + 3)
        SX(I + 4) = SA*SX(I + 4)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  DSCAL(N,DA,DX,INCX)
C
C     SCALES A VECTOR BY A CONSTANT.
C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DA,DX(*)
      INTEGER I,INCX,M,MP1,N,NINCX
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        DX(I) = DA*DX(I)
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I + 1) = DA*DX(I + 1)
        DX(I + 2) = DA*DX(I + 2)
        DX(I + 3) = DA*DX(I + 3)
        DX(I + 4) = DA*DX(I + 4)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE  CSCAL(N,CA,CX,INCX)
C
C     SCALES A VECTOR BY A CONSTANT.
C     JACK DONGARRA, LINPACK,  3/11/78.
C
      COMPLEX CA,CX(*)
      INTEGER I,INCX,N,NINCX
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        CX(I) = CA*CX(I)
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 DO 30 I = 1,N
        CX(I) = CA*CX(I)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE  CSSCAL(N,SA,CX,INCX)
C
C     SCALES A COMPLEX VECTOR BY A REAL CONSTANT.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      COMPLEX CX(*)
      REAL SA
      INTEGER I,INCX,N,NINCX
C
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I)))
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 DO 30 I = 1,N
        CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I)))
   30 CONTINUE
      RETURN
      END
      SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY)
C
C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
C     USES UNROLLED LOOP FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      REAL SX(*),SY(*),SA
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF (SA .EQ. 0.0) RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        SY(IY) = SY(IY) + SA*SX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        SY(I) = SY(I) + SA*SX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        SY(I) = SY(I) + SA*SX(I)
        SY(I + 1) = SY(I + 1) + SA*SX(I + 1)
        SY(I + 2) = SY(I + 2) + SA*SX(I + 2)
        SY(I + 3) = SY(I + 3) + SA*SX(I + 3)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
C
C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(*),DY(*),DA
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
C
      IF(N.LE.0)RETURN
      IF (DA .EQ. 0.0D0) RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DY(IY) + DA*DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        DY(I) = DY(I) + DA*DX(I)
        DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
        DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
        DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY)
C
C     CONSTANT TIMES A VECTOR PLUS A VECTOR.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      COMPLEX CX(*),CY(*),CA
      INTEGER I,INCX,INCY,IX,IY,N
C
      IF(N.LE.0)RETURN
      IF (ABS(REAL(CA)) + ABS(AIMAG(CA)) .EQ. 0.0 ) RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
C
C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        CY(IY) = CY(IY) + CA*CX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
   20 DO 30 I = 1,N
        CY(I) = CY(I) + CA*CX(I)
   30 CONTINUE
      RETURN
      END
      REAL FUNCTION SASUM(N,SX,INCX)
C
C     TAKES THE SUM OF THE ABSOLUTE VALUES.
C     USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      REAL SX(*),STEMP
      INTEGER I,INCX,M,MP1,N,NINCX
C
      SASUM = 0.0E0
      STEMP = 0.0E0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        STEMP = STEMP + ABS(SX(I))
   10 CONTINUE
      SASUM = STEMP
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,6)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        STEMP = STEMP + ABS(SX(I))
   30 CONTINUE
      IF( N .LT. 6 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,6
        STEMP = STEMP + ABS(SX(I)) + ABS(SX(I + 1)) + ABS(SX(I + 2))
     *  + ABS(SX(I + 3)) + ABS(SX(I + 4)) + ABS(SX(I + 5))
   50 CONTINUE
   60 SASUM = STEMP
      RETURN
      END
      DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
C
C     TAKES THE SUM OF THE ABSOLUTE VALUES.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(*),DTEMP
      INTEGER I,INCX,M,MP1,N,NINCX
C
      DASUM = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        DTEMP = DTEMP + DABS(DX(I))
   10 CONTINUE
      DASUM = DTEMP
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
C
C        CLEAN-UP LOOP
C
   20 M = MOD(N,6)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DABS(DX(I))
   30 CONTINUE
      IF( N .LT. 6 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,6
        DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I + 1)) + DABS(DX(I + 2))
     *  + DABS(DX(I + 3)) + DABS(DX(I + 4)) + DABS(DX(I + 5))
   50 CONTINUE
   60 DASUM = DTEMP
      RETURN
      END
      REAL FUNCTION SCASUM(N,CX,INCX)
C
C     TAKES THE SUM OF THE ABSOLUTE VALUES OF A COMPLEX VECTOR AND
C     RETURNS A SINGLE PRECISION RESULT.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      COMPLEX CX(*)
      REAL STEMP
      INTEGER I,INCX,N,NINCX
C
      SCASUM = 0.0E0
      STEMP = 0.0E0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      NINCX = N*INCX
      DO 10 I = 1,NINCX,INCX
        STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I)))
   10 CONTINUE
      SCASUM = STEMP
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 DO 30 I = 1,N
        STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I)))
   30 CONTINUE
      SCASUM = STEMP
      RETURN
      END
      REAL FUNCTION SNRM2 ( N, SX, INCX)
      INTEGER          NEXT
      REAL   SX(*),  CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE
      DATA   ZERO, ONE /0.0E0, 1.0E0/
C
C     EUCLIDEAN NORM OF THE N-VECTOR STORED IN SX() WITH STORAGE
C     INCREMENT INCX .
C     IF    N .LE. 0 RETURN WITH RESULT = 0.
C     IF N .GE. 1 THEN INCX MUST BE .GE. 1
C
C           C.L.LAWSON, 1978 JAN 08
C
C     FOUR PHASE METHOD     USING TWO BUILT-IN CONSTANTS THAT ARE
C     HOPEFULLY APPLICABLE TO ALL MACHINES.
C         CUTLO = MAXIMUM OF  SQRT(U/EPS)  OVER ALL KNOWN MACHINES.
C         CUTHI = MINIMUM OF  SQRT(V)      OVER ALL KNOWN MACHINES.
C     WHERE
C         EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1.
C         U   = SMALLEST POSITIVE NO.   (UNDERFLOW LIMIT)
C         V   = LARGEST  NO.            (OVERFLOW  LIMIT)
C
C     BRIEF OUTLINE OF ALGORITHM..
C
C     PHASE 1    SCANS ZERO COMPONENTS.
C     MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO
C     MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO
C     MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M
C     WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX.
C
C     VALUES FOR CUTLO AND CUTHI..
C     FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER
C     DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS..
C     CUTLO, S.P.   U/EPS = 2**(-102) FOR  HONEYWELL.  CLOSE SECONDS ARE
C                   UNIVAC AND DEC AT 2**(-103)
C                   THUS CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC.
C                   THUS CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) FOR HONEYWELL AND DEC.
C                   THUS CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   SAME AS S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
      DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
C
      IF(N .GT. 0) GO TO 10
         SNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C                                                 BEGIN MAIN LOOP
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF( SX(I) .EQ. ZERO) GO TO 200
      IF( ABS(SX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / SX(I)) / SX(I)
  105 XMAX = ABS(SX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF( ABS(SX(I)) .GT. CUTLO ) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF( ABS(SX(I)) .LE. XMAX ) GO TO 115
         SUM = ONE + SUM * (XMAX / SX(I))**2
         XMAX = ABS(SX(I))
         GO TO 200
C
  115 SUM = SUM + (SX(I)/XMAX)**2
      GO TO 200
C
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 HITEST = CUTHI/FLOAT( N )
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J =I,NN,INCX
      IF(ABS(SX(J)) .GE. HITEST) GO TO 100
   95    SUM = SUM + SX(J)**2
      SNRM2 = SQRT( SUM )
      GO TO 300
C
  200 CONTINUE
      I = I + INCX
      IF ( I .LE. NN ) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      SNRM2 = XMAX * SQRT(SUM)
  300 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX)
      INTEGER          NEXT
      DOUBLE PRECISION   DX(*), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE
      DATA   ZERO, ONE /0.0D0, 1.0D0/
C
C     EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE
C     INCREMENT INCX .
C     IF    N .LE. 0 RETURN WITH RESULT = 0.
C     IF N .GE. 1 THEN INCX MUST BE .GE. 1
C
C           C.L.LAWSON, 1978 JAN 08
C
C     FOUR PHASE METHOD     USING TWO BUILT-IN CONSTANTS THAT ARE
C     HOPEFULLY APPLICABLE TO ALL MACHINES.
C         CUTLO = MAXIMUM OF  DSQRT(U/EPS)  OVER ALL KNOWN MACHINES.
C         CUTHI = MINIMUM OF  DSQRT(V)      OVER ALL KNOWN MACHINES.
C     WHERE
C         EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1.
C         U   = SMALLEST POSITIVE NO.   (UNDERFLOW LIMIT)
C         V   = LARGEST  NO.            (OVERFLOW  LIMIT)
C
C     BRIEF OUTLINE OF ALGORITHM..
C
C     PHASE 1    SCANS ZERO COMPONENTS.
C     MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO
C     MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO
C     MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M
C     WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX.
C
C     VALUES FOR CUTLO AND CUTHI..
C     FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER
C     DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS..
C     CUTLO, S.P.   U/EPS = 2**(-102) FOR  HONEYWELL.  CLOSE SECONDS ARE
C                   UNIVAC AND DEC AT 2**(-103)
C                   THUS CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC.
C                   THUS CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) FOR HONEYWELL AND DEC.
C                   THUS CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   SAME AS S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
      DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C
      IF(N .GT. 0) GO TO 10
         DNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C                                                 BEGIN MAIN LOOP
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF( DX(I) .EQ. ZERO) GO TO 200
      IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / DX(I)) / DX(I)
  105 XMAX = DABS(DX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115
         SUM = ONE + SUM * (XMAX / DX(I))**2
         XMAX = DABS(DX(I))
         GO TO 200
C
  115 SUM = SUM + (DX(I)/XMAX)**2
      GO TO 200
C
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 HITEST = CUTHI/FLOAT( N )
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J =I,NN,INCX
      IF(DABS(DX(J)) .GE. HITEST) GO TO 100
   95    SUM = SUM + DX(J)**2
      DNRM2 = DSQRT( SUM )
      GO TO 300
C
  200 CONTINUE
      I = I + INCX
      IF ( I .LE. NN ) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      DNRM2 = XMAX * DSQRT(SUM)
  300 CONTINUE
      RETURN
      END
      REAL FUNCTION SCNRM2( N, CX, INCX)
      LOGICAL IMAG, SCALE
      INTEGER          NEXT
      REAL         CUTLO, CUTHI, HITEST, SUM, XMAX, ABSX, ZERO, ONE
      COMPLEX      CX(*)
      DATA         ZERO, ONE /0.0E0, 1.0E0/
C
C     UNITARY NORM OF THE COMPLEX N-VECTOR STORED IN CX() WITH STORAGE
C     INCREMENT INCX .
C     IF    N .LE. 0 RETURN WITH RESULT = 0.
C     IF N .GE. 1 THEN INCX MUST BE .GE. 1
C
C           C.L.LAWSON , 1978 JAN 08
C
C     FOUR PHASE METHOD     USING TWO BUILT-IN CONSTANTS THAT ARE
C     HOPEFULLY APPLICABLE TO ALL MACHINES.
C         CUTLO = MAXIMUM OF  SQRT(U/EPS)  OVER ALL KNOWN MACHINES.
C         CUTHI = MINIMUM OF  SQRT(V)      OVER ALL KNOWN MACHINES.
C     WHERE
C         EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1.
C         U   = SMALLEST POSITIVE NO.   (UNDERFLOW LIMIT)
C         V   = LARGEST  NO.            (OVERFLOW  LIMIT)
C
C     BRIEF OUTLINE OF ALGORITHM..
C
C     PHASE 1    SCANS ZERO COMPONENTS.
C     MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO
C     MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO
C     MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M
C     WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX.
C
C     VALUES FOR CUTLO AND CUTHI..
C     FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER
C     DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS..
C     CUTLO, S.P.   U/EPS = 2**(-102) FOR  HONEYWELL.  CLOSE SECONDS ARE
C                   UNIVAC AND DEC AT 2**(-103)
C                   THUS CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC.
C                   THUS CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) FOR HONEYWELL AND DEC.
C                   THUS CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   SAME AS S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
      DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
C
      IF(N .GT. 0) GO TO 10
         SCNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C                                                 BEGIN MAIN LOOP
      DO 210 I=1,NN,INCX
         ABSX = ABS(REAL(CX(I)))
         IMAG = .FALSE.
         GO TO NEXT,(30, 50, 70, 90, 110)
   30 IF( ABSX .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      SCALE = .FALSE.
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF( ABSX .EQ. ZERO) GO TO 200
      IF( ABSX .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 ASSIGN 110 TO NEXT
      SUM = (SUM / ABSX) / ABSX
  105 SCALE = .TRUE.
      XMAX = ABSX
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF( ABSX .GT. CUTLO ) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF( ABSX .LE. XMAX ) GO TO 115
         SUM = ONE + SUM * (XMAX / ABSX)**2
         XMAX = ABSX
         GO TO 200
C
  115 SUM = SUM + (ABSX/XMAX)**2
      GO TO 200
C
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
   85 ASSIGN 90 TO NEXT
      SCALE = .FALSE.
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
      HITEST = CUTHI/FLOAT( N )
      HITEST = HITEST * 0.5
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
   90 IF(ABSX .GE. HITEST) GO TO 100
         SUM = SUM + ABSX**2
  200 CONTINUE
C                  CONTROL SELECTION OF REAL AND IMAGINARY PARTS.
C
      IF(IMAG) GO TO 210
         ABSX = ABS(AIMAG(CX(I)))
         IMAG = .TRUE.
      GO TO NEXT,(  50, 70, 90, 110 )
C
  210 CONTINUE
C
C              END OF MAIN LOOP.
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      SCNRM2 = SQRT(SUM)
      IF(SCALE) SCNRM2 = SCNRM2 * XMAX
  300 CONTINUE
      RETURN
      END
      INTEGER FUNCTION ISAMAX(N,SX,INCX)
C
C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      REAL SX(*),SMAX
      INTEGER I,INCX,IX,N
C
      ISAMAX = 0
      IF( N .LT. 1 ) RETURN
      ISAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      IX = 1
      SMAX = ABS(SX(1))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(ABS(SX(IX)).LE.SMAX) GO TO 5
         ISAMAX = I
         SMAX = ABS(SX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 SMAX = ABS(SX(1))
      DO 30 I = 2,N
         IF(ABS(SX(I)).LE.SMAX) GO TO 30
         ISAMAX = I
         SMAX = ABS(SX(I))
   30 CONTINUE
      RETURN
      END
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C
C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      DOUBLE PRECISION DX(*),DMAX
      INTEGER I,INCX,IX,N
C
      IDAMAX = 0
      IF( N .LT. 1 ) RETURN
      IDAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      IX = 1
      DMAX = DABS(DX(1))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(DABS(DX(IX)).LE.DMAX) GO TO 5
         IDAMAX = I
         DMAX = DABS(DX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
         IF(DABS(DX(I)).LE.DMAX) GO TO 30
         IDAMAX = I
         DMAX = DABS(DX(I))
   30 CONTINUE
      RETURN
      END
      INTEGER FUNCTION ICAMAX(N,CX,INCX)
C
C     FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      COMPLEX CX(*)
      REAL SMAX
      INTEGER I,INCX,IX,N
      COMPLEX ZDUM
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C
      ICAMAX = 0
      IF( N .LT. 1 ) RETURN
      ICAMAX = 1
      IF(N.EQ.1)RETURN
      IF(INCX.EQ.1)GO TO 20
C
C        CODE FOR INCREMENT NOT EQUAL TO 1
C
      IX = 1
      SMAX = CABS1(CX(1))
      IX = IX + INCX
      DO 10 I = 2,N
         IF(CABS1(CX(IX)).LE.SMAX) GO TO 5
         ICAMAX = I
         SMAX = CABS1(CX(IX))
    5    IX = IX + INCX
   10 CONTINUE
      RETURN
C
C        CODE FOR INCREMENT EQUAL TO 1
C
   20 SMAX = CABS1(CX(1))
      DO 30 I = 2,N
         IF(CABS1(CX(I)).LE.SMAX) GO TO 30
         ICAMAX = I
         SMAX = CABS1(CX(I))
   30 CONTINUE
      RETURN
      END
      SUBROUTINE MCVFS(A,KA,N,B)
      REAL A(KA,N),B(*)
C
      L = 0
      DO 20 J = 1,N
         DO 10 I = 1,J
         L = L + 1
   10    B(L) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE DMCVFS(A,KA,N,B)
      DOUBLE PRECISION A(KA,N),B(*)
C
      L = 0
      DO 20 J = 1,N
         DO 10 I = 1,J
         L = L + 1
   10    B(L) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE MCVSF(A,KA,N,B)
      REAL A(KA,N),B(*)
C
      A(1,1) = B(1)
      IF (N .LT. 2) RETURN
      L = (N*(N + 1))/2
C
      J = N
      DO 11 JJ = 2,N
      I = J
         DO 10 II = 1,J
         A(I,J) = B(L)
         I = I - 1
   10    L = L - 1
   11 J = J - 1
C
      DO 21 I = 2,N
      IM1 = I - 1
         DO 20 J = 1,IM1
   20    A(I,J) = A(J,I)
   21 CONTINUE
      RETURN
      END
      SUBROUTINE DMCVSF(A,KA,N,B)
      DOUBLE PRECISION A(KA,N),B(*)
C
      A(1,1) = B(1)
      IF (N .LT. 2) RETURN
      L = (N*(N + 1))/2
C
      J = N
      DO 11 JJ = 2,N
      I = J
         DO 10 II = 1,J
         A(I,J) = B(L)
         I = I - 1
   10    L = L - 1
   11 J = J - 1
C
      DO 21 I = 2,N
      IM1 = I - 1
         DO 20 J = 1,IM1
   20    A(I,J) = A(J,I)
   21 CONTINUE
      RETURN
      END
      SUBROUTINE MCVRD(M,N,A,KA,B,KB)
      REAL A(KA,N)
      DOUBLE PRECISION B(KB,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(I,J) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE MCVDR(M,N,A,KA,B,KB)
      DOUBLE PRECISION A(KA,N)
      REAL B(KB,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(I,J) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE MCVRC(M,N,A,KA,B,KB)
      REAL A(KA,N)
      COMPLEX B(KB,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(I,J) = CMPLX(A(I,J),0.0)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE CMREAL(M,N,A,KA,B,KB)
      COMPLEX A(KA,N)
      REAL B(KB,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(I,J) = REAL(A(I,J))
   20 CONTINUE
      RETURN
      END
      SUBROUTINE CMIMAG(M,N,A,KA,B,KB)
      COMPLEX A(KA,N)
      REAL B(KB,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(I,J) = AIMAG(A(I,J))
   20 CONTINUE
      RETURN
      END
      SUBROUTINE MCOPY(M,N,A,KA,B,KB)
      REAL A(KA,N),B(KB,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(I,J) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE SMCOPY(N,A,B)
      REAL A(*),B(*)
C
      L = (N*(N + 1))/2
      DO 10 K = 1,L
   10 B(K) = A(K)
      RETURN
      END
      SUBROUTINE DMCOPY(M,N,A,KA,B,KB)
      DOUBLE PRECISION A(KA,N),B(KB,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(I,J) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE CMCOPY(M,N,A,KA,B,KB)
      COMPLEX A(KA,N),B(KB,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(I,J) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE CMCONJ(M,N,A,KA,B,KB)
      COMPLEX A(KA,N),B(KB,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(I,J) = CONJG(A(I,J))
   20 CONTINUE
      RETURN
      END
      SUBROUTINE TPOSE(M,N,A,KA,B,KB)
      REAL A(KA,N),B(KB,M)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(J,I) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE DTPOSE(M,N,A,KA,B,KB)
      DOUBLE PRECISION A(KA,N),B(KB,M)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(J,I) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE CTPOSE(M,N,A,KA,B,KB)
      COMPLEX A(KA,N),B(KB,M)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(J,I) = A(I,J)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE TIP (A, N1, N2, MOVED, NWORK, NDIM)
C ----------------------------------------------------------
C TRANSPOSITION OF A RECTANGULAR MATRIX IN SITU.
C BY NORMAN BRENNER, MIT, 1/72.  CF. ALG. 380, CACM, 5/70.
C TRANSPOSITION OF THE N1 BY N2 MATRIX A AMOUNTS TO
C REPLACING THE ELEMENT AT VECTOR POSITION I (0-ORIGIN)
C WITH THE ELEMENT AT POSITION N1*I (MOD N1*N2-1).
C EACH SUBCYCLE OF THIS PERMUTATION IS COMPLETED IN ORDER.
C ----------------------------------------------------------
      REAL A(*)
      REAL ATEMP, BTEMP
      INTEGER MOVED(NWORK)
      INTEGER IFACT(8), IPOWER(8), NEXP(8), IEXP(8)
      IF (N1.LT.2 .OR. N2.LT.2) GO TO 200
      N12 = N1*N2
      N = N1
      M = N12 - 1
      IF (N1.NE.N2) GO TO 30
C SQUARE MATRICES ARE DONE SEPARATELY FOR SPEED
      I1MIN = 2
      DO 20 I1MAX=N,M,N
        I2 = I1MIN + N - 1
        DO 10 I1=I1MIN,I1MAX
          ATEMP = A(I1)
          A(I1) = A(I2)
          A(I2) = ATEMP
          I2 = I2 + N
   10   CONTINUE
        I1MIN = I1MIN + N + 1
   20 CONTINUE
      RETURN
C MODULUS M IS FACTORED INTO PRIME POWERS.  EIGHT FACTORS
C SUFFICE UP TO M = 2*3*5*7*11*13*17*19 = 9,767,520.
   30 NDIM = 0
      CALL INFCTR(M, IFACT, IPOWER, NEXP, NPOWER)
      DO 40 IP=1,NPOWER
        IEXP(IP) = 0
   40 CONTINUE
C GENERATE EVERY DIVISOR OF M LESS THAN M/2
      IDIV = 1
      MHALF = M/2
   50 IF (IDIV.GE.MHALF) RETURN
C THE NUMBER OF ELEMENTS WHOSE INDEX IS DIVISIBLE BY IDIV
C AND BY NO OTHER DIVISOR OF M IS THE EULER TOTIENT
C FUNCTION, PHI(M/IDIV).
      NCOUNT = M/IDIV
      DO 60 IP=1,NPOWER
        IF (IEXP(IP).EQ.NEXP(IP)) GO TO 60
        NCOUNT = (NCOUNT/IFACT(IP))*(IFACT(IP)-1)
   60 CONTINUE
      IF (NWORK.LE.0) GO TO 75
      DO 70 I=1,NWORK
        MOVED(I) = 0
   70 CONTINUE
   75 ISTART = IDIV
C THE STARTING POINT OF A SUBCYCLE IS DIVISIBLE ONLY BY IDIV
C AND MUST NOT APPEAR IN ANY OTHER SUBCYCLE.
   80 MMIST = M - ISTART
      IF (ISTART.EQ.IDIV) GO TO 120
      NDIM = MAX0(NDIM,ISTART)
      IF (ISTART.GT.NWORK) GO TO 90
      IF (MOVED(ISTART).NE.0) GO TO 160
   90 ISOID = ISTART/IDIV
      DO 100 IP=1,NPOWER
        IF (IEXP(IP).EQ.NEXP(IP)) GO TO 100
        IF (MOD(ISOID,IFACT(IP)).EQ.0) GO TO 160
  100 CONTINUE
      IF (ISTART.LE.NWORK) GO TO 120
      ITEST = ISTART
  110 ITEST = MOD(N*ITEST,M)
      IF (ITEST.LT.ISTART .OR. ITEST.GT.MMIST) GO TO 160
      IF (ITEST.GT.ISTART .AND. ITEST.LT.MMIST) GO TO 110
  120 ATEMP = A(ISTART+1)
      BTEMP = A(MMIST+1)
      IA1 = ISTART
  130 IA2 = MOD(N*IA1,M)
      MMIA1 = M - IA1
      MMIA2 = M - IA2
      IF (IA1.LE.NWORK) MOVED(IA1) = 1
      IF (MMIA1.LE.NWORK) MOVED(MMIA1) = 1
      NCOUNT = NCOUNT - 2
C MOVE TWO ELEMENTS, THE SECOND FROM THE NEGATIVE
C SUBCYCLE.  CHECK FIRST FOR SUBCYCLE CLOSURE.
      IF (IA2.EQ.ISTART) GO TO 140
      IF (MMIA2.EQ.ISTART) GO TO 150
      A(IA1+1) = A(IA2+1)
      A(MMIA1+1) = A(MMIA2+1)
      IA1 = IA2
      GO TO 130
  140 A(IA1+1) = ATEMP
      A(MMIA1+1) = BTEMP
      GO TO 160
  150 A(IA1+1) = BTEMP
      A(MMIA1+1) = ATEMP
  160 ISTART = ISTART + IDIV
      IF (NCOUNT.GT.0) GO TO 80
      DO 180 IP=1,NPOWER
        IF (IEXP(IP).EQ.NEXP(IP)) GO TO 170
        IEXP(IP) = IEXP(IP) + 1
        IDIV = IDIV*IFACT(IP)
        GO TO 50
  170   IEXP(IP) = 0
        IDIV = IDIV/IPOWER(IP)
  180 CONTINUE
      RETURN
  200 IF (N1.NE.N2) NDIM = 0
      RETURN
      END
      SUBROUTINE DTIP (A, N1, N2, MOVED, NWORK, NDIM)
C ----------------------------------------------------------
C TRANSPOSITION OF A RECTANGULAR MATRIX IN SITU.
C BY NORMAN BRENNER, MIT, 1/72.  CF. ALG. 380, CACM, 5/70.
C TRANSPOSITION OF THE N1 BY N2 MATRIX A AMOUNTS TO
C REPLACING THE ELEMENT AT VECTOR POSITION I (0-ORIGIN)
C WITH THE ELEMENT AT POSITION N1*I (MOD N1*N2-1).
C EACH SUBCYCLE OF THIS PERMUTATION IS COMPLETED IN ORDER.
C ----------------------------------------------------------
      DOUBLE PRECISION A(*)
      DOUBLE PRECISION ATEMP, BTEMP
      INTEGER MOVED(NWORK)
      INTEGER IFACT(8), IPOWER(8), NEXP(8), IEXP(8)
      IF (N1.LT.2 .OR. N2.LT.2) GO TO 200
      N12 = N1*N2
      N = N1
      M = N12 - 1
      IF (N1.NE.N2) GO TO 30
C SQUARE MATRICES ARE DONE SEPARATELY FOR SPEED
      I1MIN = 2
      DO 20 I1MAX=N,M,N
        I2 = I1MIN + N - 1
        DO 10 I1=I1MIN,I1MAX
          ATEMP = A(I1)
          A(I1) = A(I2)
          A(I2) = ATEMP
          I2 = I2 + N
   10   CONTINUE
        I1MIN = I1MIN + N + 1
   20 CONTINUE
      RETURN
C MODULUS M IS FACTORED INTO PRIME POWERS.  EIGHT FACTORS
C SUFFICE UP TO M = 2*3*5*7*11*13*17*19 = 9,767,520.
   30 NDIM = 0
      CALL INFCTR(M, IFACT, IPOWER, NEXP, NPOWER)
      DO 40 IP=1,NPOWER
        IEXP(IP) = 0
   40 CONTINUE
C GENERATE EVERY DIVISOR OF M LESS THAN M/2
      IDIV = 1
      MHALF = M/2
   50 IF (IDIV.GE.MHALF) RETURN
C THE NUMBER OF ELEMENTS WHOSE INDEX IS DIVISIBLE BY IDIV
C AND BY NO OTHER DIVISOR OF M IS THE EULER TOTIENT
C FUNCTION, PHI(M/IDIV).
      NCOUNT = M/IDIV
      DO 60 IP=1,NPOWER
        IF (IEXP(IP).EQ.NEXP(IP)) GO TO 60
        NCOUNT = (NCOUNT/IFACT(IP))*(IFACT(IP)-1)
   60 CONTINUE
      IF (NWORK.LE.0) GO TO 75
      DO 70 I=1,NWORK
        MOVED(I) = 0
   70 CONTINUE
   75 ISTART = IDIV
C THE STARTING POINT OF A SUBCYCLE IS DIVISIBLE ONLY BY IDIV
C AND MUST NOT APPEAR IN ANY OTHER SUBCYCLE.
   80 MMIST = M - ISTART
      IF (ISTART.EQ.IDIV) GO TO 120
      NDIM = MAX0(NDIM,ISTART)
      IF (ISTART.GT.NWORK) GO TO 90
      IF (MOVED(ISTART).NE.0) GO TO 160
   90 ISOID = ISTART/IDIV
      DO 100 IP=1,NPOWER
        IF (IEXP(IP).EQ.NEXP(IP)) GO TO 100
        IF (MOD(ISOID,IFACT(IP)).EQ.0) GO TO 160
  100 CONTINUE
      IF (ISTART.LE.NWORK) GO TO 120
      ITEST = ISTART
  110 ITEST = MOD(N*ITEST,M)
      IF (ITEST.LT.ISTART .OR. ITEST.GT.MMIST) GO TO 160
      IF (ITEST.GT.ISTART .AND. ITEST.LT.MMIST) GO TO 110
  120 ATEMP = A(ISTART+1)
      BTEMP = A(MMIST+1)
      IA1 = ISTART
  130 IA2 = MOD(N*IA1,M)
      MMIA1 = M - IA1
      MMIA2 = M - IA2
      IF (IA1.LE.NWORK) MOVED(IA1) = 1
      IF (MMIA1.LE.NWORK) MOVED(MMIA1) = 1
      NCOUNT = NCOUNT - 2
C MOVE TWO ELEMENTS, THE SECOND FROM THE NEGATIVE
C SUBCYCLE.  CHECK FIRST FOR SUBCYCLE CLOSURE.
      IF (IA2.EQ.ISTART) GO TO 140
      IF (MMIA2.EQ.ISTART) GO TO 150
      A(IA1+1) = A(IA2+1)
      A(MMIA1+1) = A(MMIA2+1)
      IA1 = IA2
      GO TO 130
  140 A(IA1+1) = ATEMP
      A(MMIA1+1) = BTEMP
      GO TO 160
  150 A(IA1+1) = BTEMP
      A(MMIA1+1) = ATEMP
  160 ISTART = ISTART + IDIV
      IF (NCOUNT.GT.0) GO TO 80
      DO 180 IP=1,NPOWER
        IF (IEXP(IP).EQ.NEXP(IP)) GO TO 170
        IEXP(IP) = IEXP(IP) + 1
        IDIV = IDIV*IFACT(IP)
        GO TO 50
  170   IEXP(IP) = 0
        IDIV = IDIV/IPOWER(IP)
  180 CONTINUE
      RETURN
  200 IF (N1.NE.N2) NDIM = 0
      RETURN
      END
      SUBROUTINE CTIP (A, N1, N2, MOVED, NWORK, NDIM)
C ----------------------------------------------------------
C TRANSPOSITION OF A RECTANGULAR MATRIX IN SITU.
C BY NORMAN BRENNER, MIT, 1/72.  CF. ALG. 380, CACM, 5/70.
C TRANSPOSITION OF THE N1 BY N2 MATRIX A AMOUNTS TO
C REPLACING THE ELEMENT AT VECTOR POSITION I (0-ORIGIN)
C WITH THE ELEMENT AT POSITION N1*I (MOD N1*N2-1).
C EACH SUBCYCLE OF THIS PERMUTATION IS COMPLETED IN ORDER.
C ----------------------------------------------------------
      COMPLEX A(*)
      COMPLEX ATEMP, BTEMP
      INTEGER MOVED(NWORK)
      INTEGER IFACT(8), IPOWER(8), NEXP(8), IEXP(8)
      IF (N1.LT.2 .OR. N2.LT.2) GO TO 200
      N12 = N1*N2
      N = N1
      M = N12 - 1
      IF (N1.NE.N2) GO TO 30
C SQUARE MATRICES ARE DONE SEPARATELY FOR SPEED
      I1MIN = 2
      DO 20 I1MAX=N,M,N
        I2 = I1MIN + N - 1
        DO 10 I1=I1MIN,I1MAX
          ATEMP = A(I1)
          A(I1) = A(I2)
          A(I2) = ATEMP
          I2 = I2 + N
   10   CONTINUE
        I1MIN = I1MIN + N + 1
   20 CONTINUE
      RETURN
C MODULUS M IS FACTORED INTO PRIME POWERS.  EIGHT FACTORS
C SUFFICE UP TO M = 2*3*5*7*11*13*17*19 = 9,767,520.
   30 NDIM = 0
      CALL INFCTR(M, IFACT, IPOWER, NEXP, NPOWER)
      DO 40 IP=1,NPOWER
        IEXP(IP) = 0
   40 CONTINUE
C GENERATE EVERY DIVISOR OF M LESS THAN M/2
      IDIV = 1
      MHALF = M/2
   50 IF (IDIV.GE.MHALF) RETURN
C THE NUMBER OF ELEMENTS WHOSE INDEX IS DIVISIBLE BY IDIV
C AND BY NO OTHER DIVISOR OF M IS THE EULER TOTIENT
C FUNCTION, PHI(M/IDIV).
      NCOUNT = M/IDIV
      DO 60 IP=1,NPOWER
        IF (IEXP(IP).EQ.NEXP(IP)) GO TO 60
        NCOUNT = (NCOUNT/IFACT(IP))*(IFACT(IP)-1)
   60 CONTINUE
      IF (NWORK.LE.0) GO TO 75
      DO 70 I=1,NWORK
        MOVED(I) = 0
   70 CONTINUE
   75 ISTART = IDIV
C THE STARTING POINT OF A SUBCYCLE IS DIVISIBLE ONLY BY IDIV
C AND MUST NOT APPEAR IN ANY OTHER SUBCYCLE.
   80 MMIST = M - ISTART
      IF (ISTART.EQ.IDIV) GO TO 120
      NDIM = MAX0(NDIM,ISTART)
      IF (ISTART.GT.NWORK) GO TO 90
      IF (MOVED(ISTART).NE.0) GO TO 160
   90 ISOID = ISTART/IDIV
      DO 100 IP=1,NPOWER
        IF (IEXP(IP).EQ.NEXP(IP)) GO TO 100
        IF (MOD(ISOID,IFACT(IP)).EQ.0) GO TO 160
  100 CONTINUE
      IF (ISTART.LE.NWORK) GO TO 120
      ITEST = ISTART
  110 ITEST = MOD(N*ITEST,M)
      IF (ITEST.LT.ISTART .OR. ITEST.GT.MMIST) GO TO 160
      IF (ITEST.GT.ISTART .AND. ITEST.LT.MMIST) GO TO 110
  120 ATEMP = A(ISTART+1)
      BTEMP = A(MMIST+1)
      IA1 = ISTART
  130 IA2 = MOD(N*IA1,M)
      MMIA1 = M - IA1
      MMIA2 = M - IA2
      IF (IA1.LE.NWORK) MOVED(IA1) = 1
      IF (MMIA1.LE.NWORK) MOVED(MMIA1) = 1
      NCOUNT = NCOUNT - 2
C MOVE TWO ELEMENTS, THE SECOND FROM THE NEGATIVE
C SUBCYCLE.  CHECK FIRST FOR SUBCYCLE CLOSURE.
      IF (IA2.EQ.ISTART) GO TO 140
      IF (MMIA2.EQ.ISTART) GO TO 150
      A(IA1+1) = A(IA2+1)
      A(MMIA1+1) = A(MMIA2+1)
      IA1 = IA2
      GO TO 130
  140 A(IA1+1) = ATEMP
      A(MMIA1+1) = BTEMP
      GO TO 160
  150 A(IA1+1) = BTEMP
      A(MMIA1+1) = ATEMP
  160 ISTART = ISTART + IDIV
      IF (NCOUNT.GT.0) GO TO 80
      DO 180 IP=1,NPOWER
        IF (IEXP(IP).EQ.NEXP(IP)) GO TO 170
        IEXP(IP) = IEXP(IP) + 1
        IDIV = IDIV*IFACT(IP)
        GO TO 50
  170   IEXP(IP) = 0
        IDIV = IDIV/IPOWER(IP)
  180 CONTINUE
      RETURN
  200 IF (N1.NE.N2) NDIM = 0
      RETURN
      END
      SUBROUTINE INFCTR(N, IFACT, IPOWER, NEXP, NPOWER)
C FACTOR N INTO ITS PRIME POWERS, NPOWER IN NUMBER.
C E.G., FOR N=1960=2**3 *5 *7**2, NPOWER=3, IFACT=2,5,7,
C IPOWER=8,5,49, AND NEXP=3,1,2.
      DIMENSION IFACT(*), IPOWER(*), NEXP(*)
      IP = 0
      IFCUR = 0
      NPART = N
      IDIV = 2
   10 IQUOT = NPART/IDIV
      IF (NPART-IDIV*IQUOT) 60, 20, 60
   20 IF (IDIV-IFCUR) 40, 40, 30
   30 IP = IP + 1
      IFACT(IP) = IDIV
      IPOWER(IP) = IDIV
      IFCUR = IDIV
      NEXP(IP) = 1
      GO TO 50
   40 IPOWER(IP) = IDIV*IPOWER(IP)
      NEXP(IP) = NEXP(IP) + 1
   50 NPART = IQUOT
      GO TO 10
   60 IF (IQUOT-IDIV) 100, 100, 70
   70 IF (IDIV-2) 80, 80, 90
   80 IDIV = 3
      GO TO 10
   90 IDIV = IDIV + 2
      GO TO 10
  100 IF (NPART-1) 140, 140, 110
  110 IF (NPART-IFCUR) 130, 130, 120
  120 IP = IP + 1
      IFACT(IP) = NPART
      IPOWER(IP) = NPART
      NEXP(IP) = 1
      GO TO 140
  130 IPOWER(IP) = NPART*IPOWER(IP)
      NEXP(IP) = NEXP(IP) + 1
  140 NPOWER = IP
      RETURN
      END
      SUBROUTINE CMADJ(M,N,A,KA,B,KB)
      COMPLEX A(KA,N),B(KB,M)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
   10    B(J,I) = CONJG(A(I,J))
   20 CONTINUE
      RETURN
      END
      SUBROUTINE CTRANS (NM, N, A)
C
C
C     SUBROUTINE CTRANS FINDS THE COMPLEX CONJUGATE OF AN INPUT
C     MATRIX.
C
C
C     ON ENTRY,
C
C     NM IS THE LEADING DIMENSION OF MATRIX A IN THE MAIN PROGRAM.
C
C     N  IS THE ORDER OF MATRIX A.
C
C     A  IS THE INPUT MATRIX.
C
C
C     ON RETURN,
C
C     A  CONTAINS ITS CONJUGATE TRANSPOSE.
C
C
      INTEGER I, J, N, NM
      COMPLEX A(NM,N), TEMP
C
      DO 20 I = 1,N
        DO 10 J = I,N
          TEMP = A(I,J)
          A(I,J) = CONJG(A(J,I))
          A(J,I) = CONJG(TEMP)
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE MADD (M, N, A, KA, B, KB, C, KC)
C-----------------------------------------------------------------------
C                      ADDITION OF REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), B(KB,N), C(KC,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
            C(I,J) = A(I,J) + B(I,J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE DMADD (M, N, A, KA, B, KB, C, KC)
C-----------------------------------------------------------------------
C                ADDITION OF DOUBLE PRECISION MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), B(KB,N), C(KC,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
            C(I,J) = A(I,J) + B(I,J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE CMADD (M, N, A, KA, B, KB, C, KC)
C-----------------------------------------------------------------------
C                   ADDITION OF COMPLEX MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(KA,N), B(KB,N), C(KC,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
            C(I,J) = A(I,J) + B(I,J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE SMADD(N,A,B,C)
      REAL A(*),B(*),C(*)
      M=(N*(N+1))/2
      DO 10 K=1,M
   10 C(K)=A(K)+B(K)
      RETURN
      END
      SUBROUTINE MSUBT (M, N, A, KA, B, KB, C, KC)
C-----------------------------------------------------------------------
C                     SUBTRACTION OF REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), B(KB,N), C(KC,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
            C(I,J) = A(I,J) - B(I,J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE DMSUBT (M, N, A, KA, B, KB, C, KC)
C-----------------------------------------------------------------------
C              SUBTRACTION OF DOUBLE PRECISION MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), B(KB,N), C(KC,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
            C(I,J) = A(I,J) - B(I,J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE CMSUBT (M, N, A, KA, B, KB, C, KC)
C-----------------------------------------------------------------------
C                  SUBTRACTION OF COMPLEX MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(KA,N), B(KB,N), C(KC,N)
C
      DO 20 J = 1,N
         DO 10 I = 1,M
            C(I,J) = A(I,J) - B(I,J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE SMSUBT(N,A,B,C)
      REAL A(*),B(*),C(*)
      M=(N*(N+1))/2
      DO 10 K=1,M
   10 C(K)=A(K)-B(K)
      RETURN
      END
      SUBROUTINE MTMS (M, N, L, A, KA, B, KB, C, KC)
C-----------------------------------------------------------------------
C                     PRODUCT OF REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), B(KB,L), C(KC,L)
      DOUBLE PRECISION W
C
      DO 30 J = 1,L
         DO 20 I = 1,M
            W = 0.D0
            DO 10 K = 1,N
               W = W + DBLE(A(I,K))*DBLE(B(K,J))
   10       CONTINUE
            C(I,J) = W
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE DMTMS (M, N, L, A, KA, B, KB, C, KC)
C-----------------------------------------------------------------------
C                PRODUCT OF DOUBLE PRECISION MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), B(KB,L), C(KC,L), W
C
      DO 30 J = 1,L
         DO 20 I = 1,M
            W = 0.D0
            DO 10 K = 1,N
               W = W + A(I,K)*B(K,J)
   10       CONTINUE
            C(I,J) = W
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE CMTMS (M, N, L, A, KA, B, KB, C, KC)
C-----------------------------------------------------------------------
C                   PRODUCT OF COMPLEX MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(KA,N), B(KB,L), C(KC,L), W
C
      DO 30 J = 1,L
         DO 20 I = 1,M
            W = (0.0,0.0)
            DO 10 K = 1,N
               W = W + A(I,K)*B(K,J)
   10       CONTINUE
            C(I,J) = W
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE MPROD (M, N, L, A, KA, B, KB, C, KC, ROW)
C-----------------------------------------------------------------------
C                     PRODUCT OF REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), B(KB,L), C(KC,L), ROW(*)
      DOUBLE PRECISION W
      LOGICAL RLOC
C
      SAVE = C(1,1)
      C(1,1) = 1.0
      IF (RLOC(C,A)) GO TO 20
      IF (RLOC(C,B)) GO TO 30
C
      DO 12 J = 1,L
         DO 11 I = 1,M
         W = 0.D0
            DO 10 K = 1,N
   10       W = W + DBLE(A(I,K))*DBLE(B(K,J))
   11    C(I,J) = W
   12 CONTINUE
      RETURN
C
C     HERE C BEGINS IN THE SAME LOCATION AS A. THE DIMENSION OF ROW
C     MUST BE GREATER THAN OR EQUAL TO L. IT IS ASSUMED THAT KC=KA.
C
   20 A(1,1) = SAVE
      DO 24 I = 1,M
         DO 22 J = 1,L
         W = 0.D0
            DO 21 K = 1,N
   21       W = W + DBLE(A(I,K))*DBLE(B(K,J))
   22    ROW(J) = W
         DO 23 J = 1,L
   23    A(I,J) = ROW(J)
   24 CONTINUE
      RETURN
C
C     HERE C BEGINS IN THE SAME LOCATION AS B. THE DIMENSION OF ROW
C     MUST BE GREATER THAN OR EQUAL TO M. IT IS ASSUMED THAT KC=KB.
C
   30 B(1,1) = SAVE
      DO 34 J = 1,L
         DO 32 I = 1,M
         W = 0.D0
            DO 31 K = 1,N
   31       W = W + DBLE(A(I,K))*DBLE(B(K,J))
   32    ROW(I) = W
         DO 33 I = 1,M
   33    B(I,J) = ROW(I)
   34 CONTINUE
      RETURN
      END
      LOGICAL FUNCTION RLOC (X, Y)
C-----------------------------------------------------------------------
C     X AND Y ARE ARRAYS. IT IS ASSUMED THAT X(1) AND Y(1) CONTAIN DATA.
C
C     RLOC(X,Y) = .TRUE.   IF X AND Y BEGIN IN THE SAME LOCATION
C     RLOC(X,Y) = .FALSE.  IF X AND Y BEGIN IN DIFFERENT LOCATIONS
C
C     IT IS RECOMMENDED THAT THIS CODING NOT BE OPTIMIZED BY ELIMINATING
C     THE SUBROUTINE YCHG. IF IT IS OPTIMIZED THEN RLOC MAY NOT COMPILE
C     PROPERLY.
C-----------------------------------------------------------------------
      REAL X(*), Y(*)
C
      XOLD = X(1)
      YOLD = Y(1)
      CALL YCHG(X,Y,YOLD)
      IF (X(1) .EQ. XOLD) GO TO 10
C
C     X AND Y BEGIN IN THE SAME LOCATION
C
      Y(1) = YOLD
      RLOC = .TRUE.
      RETURN
C
C     X AND Y BEGIN IN DIFFERENT LOCATIONS
C
   10 Y(1) = YOLD
      RLOC = .FALSE.
      RETURN
      END
      SUBROUTINE YCHG (X, Y, YOLD)
      REAL X(*), Y(*)
C
      Y(1) = 0.0
      IF (YOLD .EQ. 0.0) Y(1) = 1.0
      RETURN
      END
      SUBROUTINE DMPROD (M, N, L, A, KA, B, KB, C, KC, ROW)
C-----------------------------------------------------------------------
C                PRODUCT OF DOUBLE PRECISION MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), B(KB,L), C(KC,L), ROW(*), W
      LOGICAL DLOC
C
      W = C(1,1)
      C(1,1) = 1.D0
      IF (DLOC(C,A)) GO TO 20
      IF (DLOC(C,B)) GO TO 30
C
      DO 12 J = 1,L
         DO 11 I = 1,M
         W = 0.D0
            DO 10 K = 1,N
   10       W = W + A(I,K)*B(K,J)
   11    C(I,J) = W
   12 CONTINUE
      RETURN
C
C     HERE C BEGINS IN THE SAME LOCATION AS A. THE DIMENSION OF ROW
C     MUST BE GREATER THAN OR EQUAL TO L. IT IS ASSUMED THAT KC=KA.
C
   20 A(1,1) = W
      DO 24 I = 1,M
         DO 22 J = 1,L
         W = 0.D0
            DO 21 K = 1,N
   21       W = W + A(I,K)*B(K,J)
   22    ROW(J) = W
         DO 23 J = 1,L
   23    A(I,J) = ROW(J)
   24 CONTINUE
      RETURN
C
C     HERE C BEGINS IN THE SAME LOCATION AS B. THE DIMENSION OF ROW
C     MUST BE GREATER THAN OR EQUAL TO M. IT IS ASSUMED THAT KC=KB.
C
   30 B(1,1) = W
      DO 34 J = 1,L
         DO 32 I = 1,M
         W = 0.D0
            DO 31 K = 1,N
   31       W = W + A(I,K)*B(K,J)
   32    ROW(I) = W
         DO 33 I = 1,M
   33    B(I,J) = ROW(I)
   34 CONTINUE
      RETURN
      END
      LOGICAL FUNCTION DLOC (X, Y)
C-----------------------------------------------------------------------
C     X AND Y ARE ARRAYS. IT IS ASSUMED THAT X(1) AND Y(1) CONTAIN DATA.
C
C     DLOC(X,Y) = .TRUE.   IF X AND Y BEGIN IN THE SAME LOCATION
C     DLOC(X,Y) = .FALSE.  IF X AND Y BEGIN IN DIFFERENT LOCATIONS
C
C     IT IS RECOMMENDED THAT THIS CODING NOT BE OPTIMIZED BY ELIMINATING
C     THE SUBROUTINE DYCHG. IF IT IS OPTIMIZED THEN DLOC MAY NOT COMPILE
C     PROPERLY.
C-----------------------------------------------------------------------
      DOUBLE PRECISION X(*), Y(*), XOLD, YOLD
C
      XOLD = X(1)
      YOLD = Y(1)
      CALL DYCHG(X,Y,YOLD)
      IF (X(1) .EQ. XOLD) GO TO 10
C
C     X AND Y BEGIN IN THE SAME LOCATION
C
      Y(1) = YOLD
      DLOC = .TRUE.
      RETURN
C
C     X AND Y BEGIN IN DIFFERENT LOCATIONS
C
   10 Y(1) = YOLD
      DLOC = .FALSE.
      RETURN
      END
      SUBROUTINE DYCHG (X, Y, YOLD)
      DOUBLE PRECISION X(*), Y(*), YOLD
C
      Y(1) = 0.D0
      IF (YOLD .EQ. 0.D0) Y(1) = 1.D0
      RETURN
      END
      SUBROUTINE CMPROD (M, N, L, A, KA, B, KB, C, KC, ROW)
C-----------------------------------------------------------------------
C                   PRODUCT OF COMPLEX MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(KA,N), B(KB,L), C(KC,L), ROW(*), W
      LOGICAL CLOC
C
      W = C(1,1)
      C(1,1) = (1.0,0.0)
      IF (CLOC(C,A)) GO TO 20
      IF (CLOC(C,B)) GO TO 30
C
      DO 12 J = 1,L
         DO 11 I = 1,M
         W = (0.0,0.0)
            DO 10 K = 1,N
   10       W = W + A(I,K)*B(K,J)
   11    C(I,J) = W
   12 CONTINUE
      RETURN
C
C     HERE C BEGINS IN THE SAME LOCATION AS A. THE DIMENSION OF ROW
C     MUST BE GREATER THAN OR EQUAL TO L. IT IS ASSUMED THAT KC=KA.
C
   20 A(1,1) = W
      DO 24 I = 1,M
         DO 22 J = 1,L
         W = (0.0,0.0)
            DO 21 K = 1,N
   21       W = W + A(I,K)*B(K,J)
   22    ROW(J) = W
         DO 23 J = 1,L
   23    A(I,J) = ROW(J)
   24 CONTINUE
      RETURN
C
C     HERE C BEGINS IN THE SAME LOCATION AS B. THE DIMENSION OF ROW
C     MUST BE GREATER THAN OR EQUAL TO M. IT IS ASSUMED THAT KC=KB.
C
   30 B(1,1) = W
      DO 34 J = 1,L
         DO 32 I = 1,M
         W = (0.0,0.0)
            DO 31 K = 1,N
   31       W = W + A(I,K)*B(K,J)
   32    ROW(I) = W
         DO 33 I = 1,M
   33    B(I,J) = ROW(I)
   34 CONTINUE
      RETURN
      END
      LOGICAL FUNCTION CLOC (X, Y)
C-----------------------------------------------------------------------
C     X AND Y ARE ARRAYS. IT IS ASSUMED THAT X(1) AND Y(1) CONTAIN DATA.
C
C     CLOC(X,Y) = .TRUE.   IF X AND Y BEGIN IN THE SAME LOCATION
C     CLOC(X,Y) = .FALSE.  IF X AND Y BEGIN IN DIFFERENT LOCATIONS
C
C     IT IS RECOMMENDED THAT THIS CODING NOT BE OPTIMIZED BY ELIMINATING
C     THE SUBROUTINE CYCHG. IF IT IS OPTIMIZED THEN CLOC MAY NOT COMPILE
C     PROPERLY.
C-----------------------------------------------------------------------
      COMPLEX X(*), Y(*), XOLD, YOLD
C
      XOLD = X(1)
      YOLD = Y(1)
      CALL CYCHG(X,Y,YOLD)
      IF (X(1) .EQ. XOLD) GO TO 10
C
C     X AND Y BEGIN IN THE SAME LOCATION
C
      Y(1) = YOLD
      CLOC = .TRUE.
      RETURN
C
C     X AND Y BEGIN IN DIFFERENT LOCATIONS
C
   10 Y(1) = YOLD
      CLOC = .FALSE.
      RETURN
      END
      SUBROUTINE CYCHG (X, Y, YOLD)
      COMPLEX X(*), Y(*), YOLD
      COMPLEX ZERO, ONE
      DATA ZERO/(0.0,0.0)/, ONE/(1.0,0.0)/
C
      Y(1) = ZERO
      IF (YOLD .EQ. ZERO) Y(1) = ONE
      RETURN
      END
      SUBROUTINE SVPRD(A,N,X,Y)
      REAL A(*),X(N),Y(N)
      Y(1) = A(1)*X(1)
      IF (N .EQ. 1) RETURN
C
      L = 1
      DO 20 K = 2,N
      KM1 = K - 1
      XK = X(K)
      YK = 0.0
C
      DO 10 I = 1,KM1
      L = L + 1
      Y(I) = Y(I) + A(L)*XK
   10 YK = YK + A(L)*X(I)
C
      L = L + 1
   20 Y(K) = YK + A(L)*XK
      RETURN
      END
      SUBROUTINE DSVPRD(A,N,X,Y)
      DOUBLE PRECISION A(*),X(N),Y(N)
      DOUBLE PRECISION XK,YK
      Y(1) = A(1)*X(1)
      IF (N .EQ. 1) RETURN
C
      L = 1
      DO 20 K = 2,N
      KM1 = K - 1
      XK = X(K)
      YK = 0.D0
C
      DO 10 I = 1,KM1
      L = L + 1
      Y(I) = Y(I) + A(L)*XK
   10 YK = YK + A(L)*X(I)
C
      L = L + 1
   20 Y(K) = YK + A(L)*XK
      RETURN
      END
      SUBROUTINE TMPROD(M,N,L,A,KA,B,KB,C,KC)
      REAL A(KA,N),B(KB,L),C(KC,L)
      DOUBLE PRECISION S
      DO 12 J=1,L
      DO 11 I=1,N
      S = 0.D0
      DO 10 K=1,M
   10 S = S + DBLE(A(K,I))*DBLE(B(K,J))
   11 C(I,J) = S
   12 CONTINUE
      RETURN
      END
      SUBROUTINE SMPROD(M,N,A,KA,B)
      REAL A(KA,N),B(*)
      DOUBLE PRECISION S
      II=1
      DO 12 I=1,N
      DO 11 J=1,I
      S = 0.D0
      DO 10 K=1,M
   10 S = S + DBLE(A(K,I))*DBLE(A(K,J))
      B(II) = S
   11 II = II + 1
   12 CONTINUE
      RETURN
      END
      SUBROUTINE KPROD(A,KA,M,N,B,KB,K,L,C,KC)
C     ******************************************************************
C     KRONECKER PRODUCT OF REAL MATRICES A AND B
C     ******************************************************************
      REAL A(KA,N),B(KB,L),C(KC,*)
      INTEGER R,S
C
      J = 0
      DO 40 S = 1,N
         DO 30 JJ = 1,L
         J = J + 1
C
C        COMPUTE THE J-TH COLUMN OF C
C
            I = 0
            DO 20 R = 1,M
               DO 10 II = 1,K
               I = I + 1
   10          C(I,J) = A(R,S)*B(II,JJ)
   20       CONTINUE
C
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE DKPROD(A,KA,M,N,B,KB,K,L,C,KC)
C     ******************************************************************
C     KRONECKER PRODUCT OF DOUBLE PRECISION MATRICES A AND B
C     ******************************************************************
      DOUBLE PRECISION A(KA,N),B(KB,L),C(KC,*)
      INTEGER R,S
C
      J = 0
      DO 40 S = 1,N
         DO 30 JJ = 1,L
         J = J + 1
C
C        COMPUTE THE J-TH COLUMN OF C
C
            I = 0
            DO 20 R = 1,M
               DO 10 II = 1,K
               I = I + 1
   10          C(I,J) = A(R,S)*B(II,JJ)
   20       CONTINUE
C
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE CKPROD(A,KA,M,N,B,KB,K,L,C,KC)
C     ******************************************************************
C     KRONECKER PRODUCT OF COMPLEX MATRICES A AND B
C     ******************************************************************
      COMPLEX A(KA,N),B(KB,L),C(KC,*)
      INTEGER R,S
C
      J = 0
      DO 40 S = 1,N
         DO 30 JJ = 1,L
         J = J + 1
C
C        COMPUTE THE J-TH COLUMN OF C
C
            I = 0
            DO 20 R = 1,M
               DO 10 II = 1,K
               I = I + 1
   10          C(I,J) = A(R,S)*B(II,JJ)
   20       CONTINUE
C
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE RNK (A, MDA, M, N, RE, AE, KRANK, KSURE, WORK, IWORK)
C-----------------------------------------------------------------------
C
C          UPPER AND LOWER BOUNDS OF THE RANK OF A REAL MATRIX
C
C-----------------------------------------------------------------------
C     REAL WORK(5*M0)  WHERE M0 = 5*MIN0(M,N)
C     INTEGER IWORK(M + N)
C--------------------
      REAL A(MDA,N), WORK(*)
      INTEGER IWORK(*)
C
      M0 = MIN0(M,N)
C
C     DEFINE THE RELATIVE AND ABSOLUTE TOLERANCE LISTS
C
      M1 = 1
      M2 = M1 + M0
      M3 = M2 + M0
      M4 = M3 + M0
      M5 = M4 + M0
C
      EPS = 10.0*SPMPAR(1)
      RERR = AMAX1(EPS,RE)
C
      IMAX = M5 - 1
      DO 20 I = M4,IMAX
         WORK(I) = RERR
   20 CONTINUE
      IMAX = IMAX + M0
      DO 30 I = M5,IMAX
         WORK(I) = AE
   30 CONTINUE
C
C     FACTOR THE MATRIX A
C
      IF (M .LT. N) GO TO 40
C
         CALL U11LS (A,MDA,M,N,WORK(M4),WORK(M5),1,0,KRANK,KSURE,
     *               WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2))
         RETURN
C
   40 CALL U11US (A,MDA,M,N,WORK(M4),WORK(M5),1,0,KRANK,KSURE,
     *            WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2))
      RETURN
      END
      SUBROUTINE DRNK (A, MDA, M, N, RE, AE, KRANK, KSURE, WORK, IWORK)
C-----------------------------------------------------------------------
C
C              UPPER AND LOWER BOUNDS OF THE RANK OF A
C                      DOUBLE PRECISION MATRIX
C
C-----------------------------------------------------------------------
C     DOUBLE PRECISION WORK(5*M0)  WHERE M0 = 5*MIN0(M,N)
C     INTEGER IWORK(M + N)
C--------------------
      DOUBLE PRECISION A(MDA,N), RE, AE, WORK(*)
      INTEGER IWORK(*)
      DOUBLE PRECISION EPS, RERR
      DOUBLE PRECISION DPMPAR
C
      M0 = MIN0(M,N)
C
C     DEFINE THE RELATIVE AND ABSOLUTE TOLERANCE LISTS
C
      M1 = 1
      M2 = M1 + M0
      M3 = M2 + M0
      M4 = M3 + M0
      M5 = M4 + M0
C
      EPS = 10.D0*DPMPAR(1)
      RERR = DMAX1(EPS,RE)
C
      IMAX = M5 - 1
      DO 20 I = M4,IMAX
         WORK(I) = RERR
   20 CONTINUE
      IMAX = IMAX + M0
      DO 30 I = M5,IMAX
         WORK(I) = AE
   30 CONTINUE
C
C     FACTOR THE MATRIX A
C
      IF (M .LT. N) GO TO 40
C
         CALL DU11LS (A,MDA,M,N,WORK(M4),WORK(M5),1,0,KRANK,KSURE,
     *                WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2))
         RETURN
C
   40 CALL DU11US (A,MDA,M,N,WORK(M4),WORK(M5),1,0,KRANK,KSURE,
     *             WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2))
      RETURN
      END
      SUBROUTINE CROUT(MO,N,M,A,KA,B,KB,D,INDEX,TEMP)
C-----------------------------------------------------------------------
C     CROUT PROCEDURE FOR INVERTING MATRICES AND SOLVING EQUATIONS
C-----------------------------------------------------------------------
C     A IS A MATRIX OF ORDER N WHERE N IS GREATER THAN OR EQUAL TO 1.
C     IF MO=0 THEN THE INVERSE OF A IS COMPUTED AND STORED IN A. IF MO
C     IS NOT 0 THEN THE INVERSE IS NOT COMPUTED.
C
C     IF M IS GREATER THAN 0 THEN B IS A MATRIX HAVING N ROWS AND M
C     COLUMNS. IN THIS CASE AX=B IS SOLVED AND THE SOLUTION X IS STORED
C     IN B. IF M=0 THEN THERE ARE NO EQUATIONS TO BE SOLVED.
C
C     KA = THE LENGTH OF THE COLUMNS OF THE ARRAY A
C     KB = THE LENGTH OF THE COLUMNS OF THE ARRAY B (IF M.GT.0)
C
C     THE DETERMINANT D OF A IS ALWAYS COMPUTED. IF D=0 THEN THE
C     ROUTINE IMMEDIATELY TERMINATES.
C
C     INDEX IS AN ARRAY OF DIMENSION N-1 OR LARGER THAT IS USED BY THE
C     ROUTINE FOR KEEPING TRACK OF THE ROW INTERCHANGES THAT ARE MADE.
C     IF MO IS NOT 0 THEN THIS ARRAY IS NOT NEEDED.
C
C     TEMP IS AN ARRAY OF DIMENSION N OR LARGER THAT IS USED WHEN A
C     IS INVERTED. IF MO IS NOT 0 THEN THIS ARRAY IS NOT NEEDED.
C-----------------------------------------------------------------------
      DIMENSION A(KA,N), B(*), INDEX(*), TEMP(*)
      INTEGER ONEJ
      DOUBLE PRECISION DSUM
C
      IF (N .LT. 2) GO TO 200
      D = 1.0
      NM1 = N - 1
      DO 70 K = 1,NM1
         KP1 = K + 1
C
C               SEARCH FOR THE K-TH PIVOT ELEMENT
C
         P = ABS(A(K,K))
         L = K
         DO 10 I = KP1,N
            T = ABS(A(I,K))
            IF (P .GE. T) GO TO 10
            P = T
            L = I
   10    CONTINUE
C
         P = A(L,K)
         D = P*D
         IF (D .EQ. 0.0) RETURN
         IF (MO .EQ. 0) INDEX(K) = L
         IF (K .EQ. L) GO TO 40
         D = -D
C
C                  INTERCHANGING ROWS K AND L
C
         DO 20 J = 1,N
            T = A(K,J)
            A(K,J) = A(L,J)
   20       A(L,J) = T
C
         IF (M .LE. 0) GO TO 40
         KJ = K
         LJ = L
         DO 30 J = 1,M
            T = B(KJ)
            B(KJ) = B(LJ)
            B(LJ) = T
            KJ = KJ + KB
   30       LJ = LJ + KB
C
C                  COMPUTE THE K-TH ROW OF U
C
   40    IF (K .GT. 1) GO TO 50
            DO 41 J = KP1,N
   41          A(K,J) = A(K,J)/P
            GO TO 60
C
   50    DO 52 J = KP1,N
            DSUM = A(K,J)
            DO 51 L = 1,KM1
   51          DSUM = DSUM - DBLE(A(K,L))*DBLE(A(L,J))
            A(K,J) = SNGL(DSUM)/P
   52    CONTINUE
C
C               COMPUTE THE (K+1)-ST COLUMN OF L
C
   60    DO 62 I = KP1,N
            DSUM = A(I,KP1)
            DO 61 L = 1,K
   61          DSUM = DSUM - DBLE(A(I,L))*DBLE(A(L,KP1))
            A(I,KP1) = DSUM
   62    CONTINUE
C
         KM1 = K
   70 CONTINUE
C
C                 CHECK THE N-TH PIVOT ELEMENT
C
      D = A(N,N)*D
      IF (D .EQ. 0.0) RETURN
C
C                 SOLVING THE EQUATION LY = B
C
      IF (M .LE. 0) GO TO 120
      MAXB = KB*M
      DO 102 ONEJ = 1,MAXB,KB
         KJ = ONEJ
         B(KJ) = B(KJ)/A(1,1)
         DO 101 K = 2,N
            KJ = KJ + 1
            DSUM = B(KJ)
            KM1 = K - 1
            LJ = ONEJ
            DO 100 L = 1,KM1
               DSUM = DSUM - DBLE(A(K,L))*DBLE(B(LJ))
  100          LJ = LJ + 1
  101       B(KJ) = SNGL(DSUM)/A(K,K)
  102 CONTINUE
C
C                 SOLVING THE EQUATION UX = Y
C
      DO 112 NJ = N,MAXB,KB
         KJ = NJ
         DO 111 NMK = 1,NM1
            K = N - NMK
            LJ = KJ
            KJ = KJ - 1
            DSUM = B(KJ)
            KP1 = K + 1
            DO 110 L = KP1,N
               DSUM = DSUM - DBLE(A(K,L))*DBLE(B(LJ))
  110          LJ = LJ + 1
            B(KJ) = DSUM
  111    CONTINUE
  112 CONTINUE
C
C               REPLACE L WITH THE INVERSE OF L
C
  120 IF (MO .NE. 0) RETURN
      DO 132 J = 1,NM1
         A(J,J) = 1.0/A(J,J)
         JP1 = J + 1
         DO 131 I = JP1,N
            DSUM = 0.D0
            IM1 = I - 1
            DO 130 L = J,IM1
  130          DSUM = DSUM + DBLE(A(I,L))*DBLE(A(L,J))
  131       A(I,J) = -SNGL(DSUM)/A(I,I)
  132 CONTINUE
      A(N,N) = 1.0/A(N,N)
C
C           SOLVE UX = Y WHERE Y IS THE INVERSE OF L
C
      DO 152 NMK = 1,NM1
         K = N - NMK
         KP1 = K + 1
         DO 140 J = KP1,N
            TEMP(J) = A(K,J)
  140       A(K,J) = 0.0
C
         DO 151 J = 1,N
            DSUM = A(K,J)
            DO 150 L = KP1,N
  150          DSUM = DSUM - DBLE(TEMP(L))*DBLE(A(L,J))
            A(K,J) = DSUM
  151    CONTINUE
  152 CONTINUE
C
C                    COLUMN INTERCHANGES
C
      DO 161 NMJ = 1,NM1
         J = N - NMJ
         K = INDEX(J)
         IF (J .EQ. K) GO TO 161
         DO 160 I = 1,N
            T = A(I,J)
            A(I,J) = A(I,K)
  160       A(I,K) = T
  161 CONTINUE
      RETURN
C
C                      CASE WHEN N = 1
C
  200 D = A(1,1)
      IF (D .EQ. 0.0) RETURN
      IF (MO .EQ. 0) A(1,1) = 1.0/D
C
      IF (M .LE. 0) RETURN
      MAXB = KB*M
      DO 210 KJ = 1,MAXB,KB
  210    B(KJ) = B(KJ)/D
      RETURN
      END
      SUBROUTINE KROUT(MO,N,M,A,KA,B,KB,IERR,INDEX,TEMP)
C-----------------------------------------------------------------------
C     CROUT PROCEDURE FOR INVERTING MATRICES AND SOLVING EQUATIONS
C-----------------------------------------------------------------------
C     A IS A MATRIX OF ORDER N WHERE N IS GREATER THAN OR EQUAL TO 1.
C     IF MO=0 THEN THE INVERSE OF A IS COMPUTED AND STORED IN A. IF MO
C     IS NOT 0 THEN THE INVERSE IS NOT COMPUTED.
C
C     IF M IS GREATER THAN 0 THEN B IS A MATRIX HAVING N ROWS AND M
C     COLUMNS. IN THIS CASE AX=B IS SOLVED AND THE SOLUTION X IS STORED
C     IN B. IF M=0 THEN THERE ARE NO EQUATIONS TO BE SOLVED.
C
C     KA = THE LENGTH OF THE COLUMNS OF THE ARRAY A
C     KB = THE LENGTH OF THE COLUMNS OF THE ARRAY B (IF M.GT.0)
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN
C     THE ROUTINE TERMINATES IERR HAS ONE OF THE FOLLOWING VALUES ...
C        IERR =  0   THE REQUESTED TASK WAS PERFORMED.
C        IERR = -1   EITHER N, KA, OR KB IS INCORRECT.
C        IERR =  K   THE K-TH PIVOT ELEMENT IS 0.
C
C     INDEX IS AN ARRAY OF DIMENSION N-1 OR LARGER THAT IS USED BY THE
C     ROUTINE FOR KEEPING TRACK OF THE ROW INTERCHANGES THAT ARE MADE.
C     IF MO IS NOT 0 THEN THIS ARRAY IS NOT NEEDED.
C
C     TEMP IS AN ARRAY OF DIMENSION N OR LARGER THAT IS USED WHEN A
C     IS INVERTED. IF MO IS NOT 0 THEN THIS ARRAY IS NOT NEEDED.
C-----------------------------------------------------------------------
      DIMENSION A(KA,N), B(*), INDEX(*), TEMP(*)
      INTEGER ONEJ
      DOUBLE PRECISION DSUM
C
      IF (N .LT. 1 .OR. KA .LT. N) GO TO 320
      IF (M .LE. 0) GO TO 5
      IF (KB .LT. N) GO TO 320
C
    5 IERR = 0
      IF (N .LT. 2) GO TO 200
      NM1 = N - 1
      DO 70 K = 1,NM1
         KP1 = K + 1
C
C               SEARCH FOR THE K-TH PIVOT ELEMENT
C
         P = ABS(A(K,K))
         L = K
         DO 10 I = KP1,N
            T = ABS(A(I,K))
            IF (P .GE. T) GO TO 10
            P = T
            L = I
   10    CONTINUE
         IF (P .EQ. 0.0) GO TO 300
C
         P = A(L,K)
         IF (MO .EQ. 0) INDEX(K) = L
         IF (K .EQ. L) GO TO 40
C
C                  INTERCHANGING ROWS K AND L
C
         DO 20 J = 1,N
            T = A(K,J)
            A(K,J) = A(L,J)
   20       A(L,J) = T
C
         IF (M .LE. 0) GO TO 40
         KJ = K
         LJ = L
         DO 30 J = 1,M
            T = B(KJ)
            B(KJ) = B(LJ)
            B(LJ) = T
            KJ = KJ + KB
   30       LJ = LJ + KB
C
C                  COMPUTE THE K-TH ROW OF U
C
   40    IF (K .GT. 1) GO TO 50
            DO 41 J = KP1,N
   41          A(K,J) = A(K,J)/P
            GO TO 60
C
   50    DO 52 J = KP1,N
            DSUM = A(K,J)
            DO 51 L = 1,KM1
   51          DSUM = DSUM - DBLE(A(K,L))*DBLE(A(L,J))
            A(K,J) = SNGL(DSUM)/P
   52    CONTINUE
C
C               COMPUTE THE (K+1)-ST COLUMN OF L
C
   60    DO 62 I = KP1,N
            DSUM = A(I,KP1)
            DO 61 L = 1,K
   61          DSUM = DSUM - DBLE(A(I,L))*DBLE(A(L,KP1))
            A(I,KP1) = DSUM
   62    CONTINUE
C
         KM1 = K
   70 CONTINUE
C
C                 CHECK THE N-TH PIVOT ELEMENT
C
      IF (A(N,N) .EQ. 0.0) GO TO 310
C
C                 SOLVING THE EQUATION LY = B
C
      IF (M .LE. 0) GO TO 120
      MAXB = KB*M
      DO 102 ONEJ = 1,MAXB,KB
         KJ = ONEJ
         B(KJ) = B(KJ)/A(1,1)
         DO 101 K = 2,N
            KJ = KJ + 1
            DSUM = B(KJ)
            KM1 = K - 1
            LJ = ONEJ
            DO 100 L = 1,KM1
               DSUM = DSUM - DBLE(A(K,L))*DBLE(B(LJ))
  100          LJ = LJ + 1
  101       B(KJ) = SNGL(DSUM)/A(K,K)
  102 CONTINUE
C
C                 SOLVING THE EQUATION UX = Y
C
      DO 112 NJ = N,MAXB,KB
         KJ = NJ
         DO 111 NMK = 1,NM1
            K = N - NMK
            LJ = KJ
            KJ = KJ - 1
            DSUM = B(KJ)
            KP1 = K + 1
            DO 110 L = KP1,N
               DSUM = DSUM - DBLE(A(K,L))*DBLE(B(LJ))
  110          LJ = LJ + 1
            B(KJ) = DSUM
  111    CONTINUE
  112 CONTINUE
C
C               REPLACE L WITH THE INVERSE OF L
C
  120 IF (MO .NE. 0) RETURN
      DO 132 J = 1,NM1
         A(J,J) = 1.0/A(J,J)
         JP1 = J + 1
         DO 131 I = JP1,N
            DSUM = 0.D0
            IM1 = I - 1
            DO 130 L = J,IM1
  130          DSUM = DSUM + DBLE(A(I,L))*DBLE(A(L,J))
  131       A(I,J) = -SNGL(DSUM)/A(I,I)
  132 CONTINUE
      A(N,N) = 1.0/A(N,N)
C
C           SOLVE UX = Y WHERE Y IS THE INVERSE OF L
C
      DO 152 NMK = 1,NM1
         K = N - NMK
         KP1 = K + 1
         DO 140 J = KP1,N
            TEMP(J) = A(K,J)
  140       A(K,J) = 0.0
C
         DO 151 J = 1,N
            DSUM = A(K,J)
            DO 150 L = KP1,N
  150          DSUM = DSUM - DBLE(TEMP(L))*DBLE(A(L,J))
            A(K,J) = DSUM
  151    CONTINUE
  152 CONTINUE
C
C                    COLUMN INTERCHANGES
C
      DO 161 NMJ = 1,NM1
         J = N - NMJ
         K = INDEX(J)
         IF (J .EQ. K) GO TO 161
         DO 160 I = 1,N
            T = A(I,J)
            A(I,J) = A(I,K)
  160       A(I,K) = T
  161 CONTINUE
      RETURN
C
C                      CASE WHEN N = 1
C
  200 D = A(1,1)
      IF (D .EQ. 0.0) GO TO 310
      IF (MO .EQ. 0) A(1,1) = 1.0/D
C
      IF (M .LE. 0) RETURN
      MAXB = KB*M
      DO 210 KJ = 1,MAXB,KB
  210    B(KJ) = B(KJ)/D
      RETURN
C
C                  K-TH PIVOT ELEMENT IS 0
C
  300 IERR = K
      RETURN
  310 IERR = N
      RETURN
C
C                        INPUT ERROR
C
  320 IERR = -1
      RETURN
      END
      SUBROUTINE DEC (N, NDIM, A, IP, IER)
C-----------------------------------------------------------------------
C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION.
C INPUT..
C    N = ORDER OF MATRIX.
C    NDIM = DECLARED DIMENSION OF ARRAY  A .
C    A = MATRIX TO BE TRIANGULARIZED.
C OUTPUT..
C    A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U .
C    A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L.
C    IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW.
C    IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O .
C    IER = 0 IF A NONSINGULAR, OR K IF A FOUND TO BE
C          SINGULAR AT STAGE K.
C USE  SOL  TO OBTAIN SOLUTION OF LINEAR SYSTEM.
C DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N).
C IF IP(N)=0, A IS SINGULAR, SOL WILL DIVIDE BY ZERO.
C INTERCHANGES FINISHED IN U , ONLY PARTLY IN L .
C
C REFERENCE..
C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER,
C COMM. ASSOC. COMPUT. MACH., 15 (1972), P. 274.
C-----------------------------------------------------------------------
      INTEGER IER, IP, N, NDIM
      INTEGER I, J, K, KP1, M, NM1
      REAL A
      REAL T
      DIMENSION A(NDIM,N), IP(N)
C
      IER = 0
      IP(N) = 1
      IF (N .EQ. 1) GO TO 70
      NM1 = N - 1
      DO 60 K = 1,NM1
        KP1 = K + 1
C  FIND THE PIVOT IN COLUMN K.  SEARCH ROWS K TO N. --------------------
        M = K
        DO 10 I = KP1,N
  10      IF (ABS(A(I,K)) .GT. ABS(A(M,K))) M = I
        IP(K) = M
C  INTERCHANGE ELEMENTS IN ROWS K AND M. -------------------------------
        T = A(M,K)
        IF (M .EQ. K) GO TO 20
        IP(N) = -IP(N)
        A(M,K) = A(K,K)
        A(K,K) = T
 20     IF (T .EQ. 0.0) GO TO 80
C  STORE MULTIPLIERS IN A(I,K), I = K+1,...,N. -------------------------
        T = 1.0/T
        DO 30 I = KP1,N
 30       A(I,K) = -A(I,K)*T
C  APPLY MULTIPLIERS TO OTHER COLUMNS OF A. ----------------------------
        DO 50 J = KP1,N
          T = A(M,J)
          A(M,J) = A(K,J)
          A(K,J) = T
          IF (T .EQ. 0.0) GO TO 50
          DO 40 I = KP1,N
 40         A(I,J) = A(I,J) + A(I,K)*T
 50       CONTINUE
 60     CONTINUE
 70   K = N
      IF (A(N,N) .EQ. 0.0) GO TO 80
      RETURN
 80   IER = K
      IP(N) = 0
      RETURN
      END
      SUBROUTINE SOL (N, NDIM, A, B, IP)
C-----------------------------------------------------------------------
C SOLUTION OF LINEAR SYSTEM, A*X = B .
C INPUT..
C   N = ORDER OF MATRIX.
C   NDIM = DECLARED DIMENSION OF ARRAY  A .
C   A = TRIANGULARIZED MATRIX OBTAINED FROM DEC.
C   B = RIGHT HAND SIDE VECTOR.
C   IP = PIVOT VECTOR OBTAINED FROM DEC.
C DO NOT USE IF DEC HAS SET IER .NE. 0.
C OUTPUT..
C   B = SOLUTION VECTOR, X .
C-----------------------------------------------------------------------
      INTEGER IP, N, NDIM
      INTEGER I, K, KB, KM1, KP1, M, NM1
      REAL A, B
      REAL T
      DIMENSION A(NDIM, N), B(N), IP(N)
C
      IF (N .EQ. 1) GO TO 50
      NM1 = N - 1
C  APPLY ROW PERMUTATIONS AND MULTIPLIERS TO B. ------------------------
      DO 20 K = 1,NM1
        KP1 = K + 1
        M = IP(K)
        T = B(M)
        B(M) = B(K)
        B(K) = T
        DO 10 I = KP1,N
 10       B(I) = B(I) + A(I,K)*T
 20     CONTINUE
C  BACK SOLVE. ---------------------------------------------------------
      DO 40 KB = 1,NM1
        KM1 = N - KB
        K = KM1 + 1
        B(K) = B(K)/A(K,K)
        T = -B(K)
        DO 30 I = 1,KM1
 30       B(I) = B(I) + A(I,K)*T
 40     CONTINUE
 50   B(1) = B(1)/A(1,1)
      RETURN
      END
      SUBROUTINE NPIVOT (N, M, A, KA, B, KB, D, IERR)
C-----------------------------------------------------------------------
C     MATRIX INVERSION/EQUATION SOLVING WITHOUT PIVOT SEARCH
C-----------------------------------------------------------------------
      REAL A(KA,N), B(*)
C
      IERR = 0
      MAXB = KB*M
      DO 80 K = 1,N
C
C     EXAMINE THE PIVOT ELEMENT
C
      PIVOT = A(K,K)
      D = D*PIVOT
      IF (PIVOT .NE. 0.0) GO TO 10
         IERR = 1
         RETURN
C
C     DIVIDE THE PIVOT ROW BY THE PIVOT ELEMENT
C
   10 A(K,K) = 1.0
      DO 20 L = 1,N
         A(K,L) = A(K,L)/PIVOT
   20 CONTINUE
      IF (M .LE. 0) GO TO 40
C
      DO 30 KL = K,MAXB,KB
         B(KL) = B(KL)/PIVOT
   30 CONTINUE
C
C     REDUCE THE NON-PIVOT ROWS
C
   40 DO 70 J = 1,N
         IF (J .EQ. K) GO TO 70
         T = A(J,K)
         A(J,K) = 0.0
         DO 50 L = 1,N
            A(J,L) = A(J,L) - A(K,L)*T
   50    CONTINUE
         IF (M .LE. 0) GO TO 70
C
         KL = K
         DO 60 JL = J,MAXB,KB
            B(JL) = B(JL) - B(KL)*T
            KL = KL + KB
   60    CONTINUE
   70 CONTINUE
C
   80 CONTINUE
      RETURN
      END
      SUBROUTINE SLV (N, M, A, KA, B, KB, IERR)
      REAL A(KA,N), B(KB,M)
C     ------------------------------------------------------------------
C     PARTIAL PIVOT SOLUTION OF A*X = B WHERE A IS A MATRIX OF
C     ORDER N AND B IS A MATRIX HAVING N ROWS AND M COLUMNS.
C     THE SOLUTION MATRIX X IS STORED IN B.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C        IERR = 0   THE EQUATIONS HAVE BEEN SOLVED.
C        IERR = J   THE J-TH PIVOT ELEMENT WAS FOUND TO BE 0.
C     ------------------------------------------------------------------
      IERR = 0
      NM1 = N - 1
      IF (NM1 .EQ. 0) GO TO 140
      DO 80 J = 1,NM1
C
C     SEARCH FOR THE J-TH PIVOT ELEMENT
C
         P = 0.0
         DO 10 I = J,N
            T = ABS(A(I,J))
            IF (T .LE. P) GO TO 10
            P = T
            L = I
   10    CONTINUE
         IF (P .EQ. 0.0) GO TO 210
         IF (J .EQ. L) GO TO 40
C
C     INTERCHANGE ROWS J AND L
C
         DO 20 K = J,N
            T = A(J,K)
            A(J,K) = A(L,K)
            A(L,K) = T
   20    CONTINUE
         DO 30 K = 1,M
            T = B(J,K)
            B(J,K) = B(L,K)
            B(L,K) = T
   30    CONTINUE
C
C     ELIMINATE THE COEFFICIENTS OF X(J) IN ROWS I = J+1,...,N
C
   40    P = A(J,J)
         JP1 = J + 1
         DO 70 I = JP1,N
            T = A(I,J)/P
            DO 50 K = JP1,N
   50          A(I,K) = A(I,K) - T*A(J,K)
            DO 60 K = 1,M
   60          B(I,K) = B(I,K) - T*B(J,K)
   70    CONTINUE
   80 CONTINUE
      IF (A(N,N) .EQ. 0.0) GO TO 220
C
C     BACKSOLVE THE TRIANGULAR SET OF EQUATIONS
C
      DO 100 J = 1,M
  100 B(N,J) = B(N,J)/A(N,N)
C
      DO 130 L = 1,NM1
      I = N - L
      IP1 = I + 1
         DO 120 J = 1,M
         SUM = B(I,J)
            DO 110 K = IP1,N
  110       SUM = SUM - A(I,K)*B(K,J)
  120    B(I,J) = SUM/A(I,I)
  130 CONTINUE
      RETURN
C
C     CASE WHEN N = 1
C
 140  IF (A(1,1) .EQ. 0.0) GO TO 200
      DO 150 J = 1,M
 150  B(1,J) = B(1,J)/A(1,1)
      RETURN
C
C     ERROR RETURN
C
 200  IERR = 1
      RETURN
 210  IERR = J
      RETURN
 220  IERR = N
      RETURN
      END
      SUBROUTINE DPSLV (N, M, A, KA, B, KB, IERR)
      DOUBLE PRECISION A(KA,N), B(KB,M), P, T
C     ------------------------------------------------------------------
C     PARTIAL PIVOT SOLUTION OF A*X = B WHERE A IS A MATRIX OF
C     ORDER N AND B IS A MATRIX HAVING N ROWS AND M COLUMNS.
C     THE SOLUTION MATRIX X IS STORED IN B.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C        IERR = 0   THE EQUATIONS HAVE BEEN SOLVED.
C        IERR = J   THE J-TH PIVOT ELEMENT WAS FOUND TO BE 0.
C     ------------------------------------------------------------------
      IERR = 0
      NM1 = N - 1
      IF (NM1 .EQ. 0) GO TO 140
      DO 80 K = 1,NM1
C
C     SEARCH FOR THE K-TH PIVOT ELEMENT
C
         P = 0.D0
         DO 10 I = K,N
            T = DABS(A(I,K))
            IF (P .GE. T) GO TO 10
            P = T
            L = I
   10    CONTINUE
         IF (P .EQ. 0.D0) GO TO 210
         IF (K .EQ. L) GO TO 40
C
C     INTERCHANGE ROWS K AND L
C
         DO 20 J = K,N
            T = A(K,J)
            A(K,J) = A(L,J)
            A(L,J) = T
   20    CONTINUE
         DO 30 J = 1,M
            T = B(K,J)
            B(K,J) = B(L,J)
            B(L,J) = T
   30    CONTINUE
C
C     ELIMINATE THE COEFFICIENTS OF X(K) IN ROWS I = K+1,...,N
C
   40    P = A(K,K)
         KP1 = K + 1
         DO 70 I = KP1,N
            T = A(I,K)/P
            DO 50 J = KP1,N
   50          A(I,J) = A(I,J) - T*A(K,J)
            DO 60 J = 1,M
   60          B(I,J) = B(I,J) - T*B(K,J)
   70    CONTINUE
   80 CONTINUE
      IF (A(N,N) .EQ. 0.D0) GO TO 220
C
C     BACKSOLVE THE TRIANGULAR SET OF EQUATIONS
C
      DO 120 J = 1,M
      K = N
      KM1 = NM1
         DO 110 L = 2,N
         B(K,J) = B(K,J)/A(K,K)
         T = B(K,J)
            DO 100 I = 1,KM1
  100       B(I,J) = B(I,J) - T*A(I,K)
         K = KM1
  110    KM1 = K - 1
  120 B(1,J) = B(1,J)/A(1,1)
      RETURN
C
C     CASE WHEN N = 1
C
 140  IF (A(1,1) .EQ. 0.D0) GO TO 200
      DO 150 J = 1,M
 150  B(1,J) = B(1,J)/A(1,1)
      RETURN
C
C     ERROR RETURN
C
 200  IERR = 1
      RETURN
 210  IERR = K
      RETURN
 220  IERR = N
      RETURN
      END
      SUBROUTINE MSLV (MO,N,M,A,KA,B,KB,DET,RCOND,IERR,IPVT,WK)
C-----------------------------------------------------------------------
C     PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING REAL MATRICES
C     AND SOLVING REAL EQUATIONS
C-----------------------------------------------------------------------
      REAL A(KA,N), B(*)
      REAL DET(2), RCOND, T, WK(N)
      INTEGER IPVT(N), ONEJ
C
C          MATRIX FACTORIZATION AND COMPUTATION OF RCOND
C
      IERR = 0
      CALL SGECO (A, KA, N, IPVT, RCOND, WK)
      T = 1.0 + RCOND
      IF (T .EQ. 1.0) GO TO 30
C
C                  SOLUTION OF THE EQUATION AX=B
C
      IF (M .LT. 1) GO TO 20
      ONEJ = 1
      DO 10 J = 1,M
         CALL SGESL (A, KA, N, IPVT, B(ONEJ), 0)
         ONEJ = ONEJ + KB
   10 CONTINUE
C
C             CALCULATION OF DET AND THE INVERSE OF A
C
   20 JOB = 10
      IF (MO .EQ. 0) JOB = 11
      CALL SGEDI (A, KA, N, IPVT, DET, WK, JOB)
      RETURN
C
C                  THE PROBLEM CANNOT BE SOLVED
C
   30 IERR = 1
      RETURN
      END
      SUBROUTINE MSLV1 (MO,N,M,A,KA,B,KB,IERR,IPVT,WK)
C-----------------------------------------------------------------------
C     PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING REAL MATRICES
C     AND SOLVING REAL EQUATIONS
C-----------------------------------------------------------------------
      REAL A(KA,N), B(*), WK(*)
      INTEGER IPVT(N)
      REAL DET(2)
      INTEGER ONEJ
C
      IF (N .LT. 1 .OR. KA .LT. N) GO TO 40
      IF (M .LE. 0) GO TO 10
      IF (KB .LT. N) GO TO 40
C
C                      MATRIX FACTORIZATION
C
   10 CALL SGEFA (A, KA, N, IPVT, IERR)
      IF (IERR .NE. 0) RETURN
C
C                  SOLUTION OF THE EQUATION AX=B
C
      IF (M .LE. 0) GO TO 30
      ONEJ = 1
      DO 20 J = 1,M
         CALL SGESL (A, KA, N, IPVT, B(ONEJ), 0)
         ONEJ = ONEJ + KB
   20 CONTINUE
C
C                 CALCULATION OF THE INVERSE OF A
C
   30 IF (MO .EQ. 0) CALL SGEDI (A, KA, N, IPVT, DET, WK, 1)
      RETURN
C
C                          ERROR RETURN
C
   40 IERR = -1
      RETURN
      END
      SUBROUTINE SLVMP(MO, N, A, KA, B, X, WK, IWK, IERR)
C     ******************************************************************
C     SOLUTION OF REAL LINEAR EQUATIONS WITH ITERATIVE IMPROVEMENT
C     ******************************************************************
      DIMENSION A(KA,N), B(N), X(N), WK(*), IWK(N)
C     -------------------
C     DIMENSION WK(N*N + N)
C     -------------------
      IF (MO .NE. 0) GO TO 10
C
C             COMPUTE THE LU DECOMPOSITION OF A
C
      CALL MCOPY(N, N, A, KA, WK, N)
      CALL SGEFA(WK, N, N, IWK, IERR)
      IF (IERR .EQ. 0) GO TO 10
      IERR = -IERR
      RETURN
C
C            SOLVE THE SYSTEM OF EQUATIONS AX = B
C
   10 DO 11 I = 1,N
   11 X(I) = B(I)
C
      IR = N*N + 1
      CALL SGESL(WK, N, N, IWK, X, 0)
      CALL LUIMP(A, KA, N, WK(1), N, IWK, B, X, WK(IR), IERR)
      RETURN
      END
      SUBROUTINE LUIMP(A, KA, N, Q, KQ, IPVT, B, X, R, IND)
C ----------------------------------------------------------------------
C     PURPOSE
C       GIVEN AN APPROXIMATE SOLUTION X OF A LINEAR SYSTEM AX = B
C       OBTAINED USING SGECO OR SGEFA. LUIMP ATTEMPTS TO COMPUTE
C       AN IMPROVED SOLUTION CORRECT TO MACHINE PRECISION.
C
C     PARAMETERS
C
C       A    AN ARRAY OF DIMENSION (KA,N) CONTAINING THE MATRIX
C            A OF ORDER N.
C       Q    AN ARRAY OF DIMENSION (KQ,N) CONTAINING THE LU
C            DECOMPOSITION OF A PRODUCED BY SGECO OR SGEFA.
C       IPVT AN ARRAY OF DIMENSION N CONTAINING THE PERMUTATION
C            INFORMATION GIVEN BY SGECO OR SGEFA.
C       B    THE RIGHT HAND SIDE OF THE EQUATION AX = B.
C       X    ON INPUT X IS THE APPROXIMATE SOLUTION OF AX = B TO
C            BE IMPROVED. ON OUTPUT X IS THE SOLUTION OBTAINED.
C       R    AN ARRAY FOR INTERNAL USE BY THE ROUTINE.
C       IND  VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C            IND = 0 IF IMPROVEMENT OF X IS SUCCESSFUL WITH A
C            GAIN IN ACCURACY OF AT LEAST 50 PER CENT EACH
C            ITERATION. OTHERWISE IND = 1.
C
C     METHOD
C       LUIMP EXECUTES THE ITERATION CYCLE
C            (1)  AR = B - AX
C            (2)  X = X + R
C       WITH AN INITIAL GIVEN X. THE RESIDUAL VECTOR B - AX IS
C       COMPUTED TO HIGH ACCURACY USING DOUBLE PRECISION. SGESL
C       IS THEN USED TO SOLVE (1).
C
C ----------------------------------------------------------------------
      DIMENSION A(KA,N), Q(KQ,N), IPVT(N), B(N), X(N), R(N)
      DOUBLE PRECISION DSUM
C
C     ********** EPS IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS
C                THE VALUE U WHERE U IS THE SMALLEST FLOATING POINT
C                NUMBER SUCH THAT 1.0 + U .GT. 1.0.
C
      EPS = SPMPAR(1)
C
      IND = 0
      XNRM = 0.0
      DO 10 I = 1,N
   10 XNRM = XNRM + X(I)*X(I)
      IF (XNRM .EQ. 0.0) RETURN
      EPS2 = EPS*EPS
      RATIO = 1.0
C
C                  COMPUTE THE RESIDUAL VECTOR
C
   20 DO 22 I = 1,N
      DSUM = B(I)
        DO 21 J = 1,N
   21   DSUM = DSUM - DBLE(A(I,J))*DBLE(X(J))
   22 R(I) = DSUM
C
C                  FIND THE CORRECTION VECTOR
C
      CALL SGESL(Q, KQ, N, IPVT, R, 0)
      RNRM = 0.0
      DO 30 I = 1,N
   30 RNRM = RNRM + R(I)*R(I)
      IF (RNRM .LE. EPS2*XNRM) RETURN
C
C                FORM A NEW APPROXIMATE SOLUTION
C
      DO 40 I = 1,N
   40 X(I) = X(I) + R(I)
      XNRM = 0.0
      DO 41 I = 1,N
   41 XNRM = XNRM + X(I)*X(I)
C
      IF (XNRM .EQ. 0.0) RETURN
      RAT = RATIO
      RATIO = RNRM/XNRM
      IF (RATIO .LE. 0.25*RAT) GO TO 20
C
      IF (RATIO .GT. AMIN1(RAT,4.0*EPS2)) IND = 1
      RETURN
      END
      SUBROUTINE SGECO(A,LDA,N,IPVT,RCOND,Z)
      INTEGER LDA,N,IPVT(*)
      REAL A(LDA,*),Z(*)
      REAL RCOND
C
C     SGECO FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION
C     AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C     IF  RCOND  IS NOT NEEDED, SGEFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW SGECO BY SGESL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW SGECO BY SGESL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW SGECO BY SGEDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW SGECO BY SGEDI.
C
C     ON ENTRY
C
C        A       REAL(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   REAL
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       REAL(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     LINPACK SGEFA
C     BLAS SAXPY,SDOT,SSCAL,SASUM
C     FORTRAN ABS,AMAX1,SIGN
C
C     INTERNAL VARIABLES
C
      REAL SDOT,EK,T,WK,WKM
      REAL ANORM,S,SASUM,SM,YNORM
      INTEGER INFO,J,K,KB,KP1,L
C
C
C     COMPUTE 1-NORM OF A
C
      ANORM = 0.0E0
      DO 10 J = 1, N
         ANORM = AMAX1(ANORM,SASUM(N,A(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL SGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C     SOLVE TRANS(U)*W = E
C
      EK = 1.0E0
      DO 20 J = 1, N
         Z(J) = 0.0E0
   20 CONTINUE
      DO 100 K = 1, N
         IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K))
         IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30
            S = ABS(A(K,K))/ABS(EK-Z(K))
            CALL SSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = ABS(WK)
         SM = ABS(WKM)
         IF (A(K,K) .EQ. 0.0E0) GO TO 40
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0E0
            WKM = 1.0E0
   50    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 90
            DO 60 J = KP1, N
               SM = SM + ABS(Z(J)+WKM*A(K,J))
               Z(J) = Z(J) + WK*A(K,J)
               S = S + ABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*A(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
C     SOLVE TRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         IF (K .LT. N) Z(K) = Z(K) + SDOT(N-K,A(K+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150
            S = ABS(A(K,K))/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
         IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0
         T = -Z(K)
         CALL SAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END
      SUBROUTINE SGEFA(A,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(*),INFO
      REAL A(LDA,*)
C
C     SGEFA FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION.
C
C     SGEFA IS USUALLY CALLED BY SGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR SGECO) = (1 + 9/N)*(TIME FOR SGEFA) .
C
C     ON ENTRY
C
C        A       REAL(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT SGESL OR SGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN SGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SSCAL,ISAMAX
C
C     INTERNAL VARIABLES
C
      REAL T
      INTEGER ISAMAX,J,K,KP1,L,NM1
C
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = ISAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0E0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0E0/A(K,K)
            CALL SSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL SAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0E0) INFO = N
      RETURN
      END
      SUBROUTINE SGESL(A,LDA,N,IPVT,B,JOB)
      INTEGER LDA,N,IPVT(*),JOB
      REAL A(LDA,*),B(*)
C
C     SGESL SOLVES THE REAL SYSTEM
C     A * X = B  OR  TRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY SGECO OR SGEFA.
C
C     ON ENTRY
C
C        A       REAL(LDA, N)
C                THE OUTPUT FROM SGECO OR SGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SGECO OR SGEFA.
C
C        B       REAL(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF SGECO HAS SET RCOND .GT. 0.0
C        OR SGEFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL SGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL SGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SDOT
C
C     INTERNAL VARIABLES
C
      REAL SDOT,T
      INTEGER K,KB,L,NM1
C
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL SAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL SAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = SDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + SDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE SGEDI(A,LDA,N,IPVT,DET,WORK,JOB)
      INTEGER LDA,N,IPVT(*),JOB
      REAL A(LDA,*),DET(2),WORK(*)
C
C     SGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
C     USING THE FACTORS COMPUTED BY SGECO OR SGEFA.
C
C     ON ENTRY
C
C        A       REAL(LDA, N)
C                THE OUTPUT FROM SGECO OR SGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SGECO OR SGEFA.
C
C        WORK    REAL(N)
C                WORK VECTOR.  CONTENTS DESTROYED.
C
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C
C     ON RETURN
C
C        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE UNCHANGED.
C
C        DET     REAL(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. ABS(DET(1)) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF SGECO HAS SET RCOND .GT. 0.0 OR SGEFA HAS SET
C        INFO .EQ. 0 .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SSCAL,SSWAP
C     FORTRAN ABS,MOD
C
C     INTERNAL VARIABLES
C
      REAL T
      REAL TEN
      INTEGER I,J,K,KB,KP1,L,NM1
C
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0E0
         DET(2) = 0.0E0
         TEN = 10.0E0
         DO 50 I = 1, N
            IF (IPVT(I) .NE. I) DET(1) = -DET(1)
            DET(1) = A(I,I)*DET(1)
C        ...EXIT
            IF (DET(1) .EQ. 0.0E0) GO TO 60
   10       IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20
               DET(1) = TEN*DET(1)
               DET(2) = DET(2) - 1.0E0
            GO TO 10
   20       CONTINUE
   30       IF (ABS(DET(1)) .LT. TEN) GO TO 40
               DET(1) = DET(1)/TEN
               DET(2) = DET(2) + 1.0E0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(U)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 150
         DO 100 K = 1, N
            A(K,K) = 1.0E0/A(K,K)
            T = -A(K,K)
            CALL SSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0E0
               CALL SAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 140
         DO 130 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 110 I = KP1, N
               WORK(I) = A(I,K)
               A(I,K) = 0.0E0
  110       CONTINUE
            DO 120 J = KP1, N
               T = WORK(J)
               CALL SAXPY(N,T,A(1,J),1,A(1,K),1)
  120       CONTINUE
            L = IPVT(K)
            IF (L .NE. K) CALL SSWAP(N,A(1,K),1,A(1,L),1)
  130    CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END
      SUBROUTINE DMSLV (MO,N,M,A,KA,B,KB,DET,RCOND,IERR,IPVT,WK)
C-----------------------------------------------------------------------
C     PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING DOUBLE PRECISION
C     REAL MATRICES AND SOLVING DOUBLE PRECISION REAL EQUATIONS
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), B(*)
      DOUBLE PRECISION DET(2), RCOND, T, WK(N)
      INTEGER IPVT(N), ONEJ
C
C          MATRIX FACTORIZATION AND COMPUTATION OF RCOND
C
      IERR = 0
      CALL DGECO (A, KA, N, IPVT, RCOND, WK)
      T = 1.D0 + RCOND
      IF (T .EQ. 1.D0) GO TO 30
C
C                  SOLUTION OF THE EQUATION AX=B
C
      IF (M .LT. 1) GO TO 20
      ONEJ = 1
      DO 10 J = 1,M
         CALL DGESL (A, KA, N, IPVT, B(ONEJ), 0)
         ONEJ = ONEJ + KB
   10 CONTINUE
C
C             CALCULATION OF DET AND THE INVERSE OF A
C
   20 JOB = 10
      IF (MO .EQ. 0) JOB = 11
      CALL DGEDI (A, KA, N, IPVT, DET, WK, JOB)
      RETURN
C
C                  THE PROBLEM CANNOT BE SOLVED
C
   30 IERR = 1
      RETURN
      END
      SUBROUTINE DMSLV1 (MO,N,M,A,KA,B,KB,IERR,IPVT,WK)
C-----------------------------------------------------------------------
C     PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING DOUBLE PRECISION
C     REAL MATRICES AND SOLVING DOUBLE PRECISION REAL EQUATIONS
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), B(*), WK(*)
      INTEGER IPVT(N)
      DOUBLE PRECISION DET(2)
      INTEGER ONEJ
C
      IF (N .LT. 1 .OR. KA .LT. N) GO TO 40
      IF (M .LE. 0) GO TO 10
      IF (KB .LT. N) GO TO 40
C
C                      MATRIX FACTORIZATION
C
   10 CALL DGEFA (A, KA, N, IPVT, IERR)
      IF (IERR .NE. 0) RETURN
C
C                  SOLUTION OF THE EQUATION AX=B
C
      IF (M .LE. 0) GO TO 30
      ONEJ = 1
      DO 20 J = 1,M
         CALL DGESL (A, KA, N, IPVT, B(ONEJ), 0)
         ONEJ = ONEJ + KB
   20 CONTINUE
C
C                 CALCULATION OF THE INVERSE OF A
C
   30 IF (MO .EQ. 0) CALL DGEDI (A, KA, N, IPVT, DET, WK, 1)
      RETURN
C
C                          ERROR RETURN
C
   40 IERR = -1
      RETURN
      END
      SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z)
      INTEGER LDA,N,IPVT(*)
      DOUBLE PRECISION A(LDA,*),Z(*)
      DOUBLE PRECISION RCOND
C
C     DGECO FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION
C     AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C     IF  RCOND  IS NOT NEEDED, DGEFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW DGECO BY DGESL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW DGECO BY DGESL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW DGECO BY DGEDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW DGECO BY DGEDI.
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   DOUBLE PRECISION
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       DOUBLE PRECISION(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     LINPACK DGEFA
C     BLAS DAXPY,DDOT,DSCAL,DASUM
C     FORTRAN DABS,DMAX1,DSIGN
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,EK,T,WK,WKM
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM
      INTEGER INFO,J,K,KB,KP1,L
C
C
C     COMPUTE 1-NORM OF A
C
      ANORM = 0.0D0
      DO 10 J = 1, N
         ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL DGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C     SOLVE TRANS(U)*W = E
C
      EK = 1.0D0
      DO 20 J = 1, N
         Z(J) = 0.0D0
   20 CONTINUE
      DO 100 K = 1, N
         IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K))
         IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30
            S = DABS(A(K,K))/DABS(EK-Z(K))
            CALL DSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = DABS(WK)
         SM = DABS(WKM)
         IF (A(K,K) .EQ. 0.0D0) GO TO 40
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0D0
            WKM = 1.0D0
   50    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 90
            DO 60 J = KP1, N
               SM = SM + DABS(Z(J)+WKM*A(K,J))
               Z(J) = Z(J) + WK*A(K,J)
               S = S + DABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*A(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
C     SOLVE TRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1)
         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110
            S = 1.0D0/DABS(Z(K))
            CALL DSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
      YNORM = 1.0D0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130
            S = 1.0D0/DABS(Z(K))
            CALL DSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150
            S = DABS(A(K,K))/DABS(Z(K))
            CALL DSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K)
         IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0
         T = -Z(K)
         CALL DAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END
      SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(*),INFO
      DOUBLE PRECISION A(LDA,*)
C
C     DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION.
C
C     DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) .
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,IDAMAX
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      INTEGER IDAMAX,J,K,KP1,L,NM1
C
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IDAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0D0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0D0/A(K,K)
            CALL DSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB)
      INTEGER LDA,N,IPVT(*),JOB
      DOUBLE PRECISION A(LDA,*),B(*)
C
C     DGESL SOLVES THE DOUBLE PRECISION SYSTEM
C     A * X = B  OR  TRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGECO OR DGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGECO OR DGEFA.
C
C        B       DOUBLE PRECISION(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0
C        OR DGEFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL DGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL DGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DDOT
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,NM1
C
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL DAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = DDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE DGEDI(A,LDA,N,IPVT,DET,WORK,JOB)
      INTEGER LDA,N,IPVT(*),JOB
      DOUBLE PRECISION A(LDA,*),DET(2),WORK(*)
C
C     DGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGECO OR DGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGECO OR DGEFA.
C
C        WORK    DOUBLE PRECISION(N)
C                WORK VECTOR.  CONTENTS DESTROYED.
C
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C
C     ON RETURN
C
C        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE UNCHANGED.
C
C        DET     DOUBLE PRECISION(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. DABS(DET(1)) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF DGECO HAS SET RCOND .GT. 0.0 OR DGEFA HAS SET
C        INFO .EQ. 0 .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,DSWAP
C     FORTRAN DABS,MOD
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      DOUBLE PRECISION TEN
      INTEGER I,J,K,KB,KP1,L,NM1
C
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         TEN = 10.0D0
         DO 50 I = 1, N
            IF (IPVT(I) .NE. I) DET(1) = -DET(1)
            DET(1) = A(I,I)*DET(1)
C        ...EXIT
            IF (DET(1) .EQ. 0.0D0) GO TO 60
   10       IF (DABS(DET(1)) .GE. 1.0D0) GO TO 20
               DET(1) = TEN*DET(1)
               DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       IF (DABS(DET(1)) .LT. TEN) GO TO 40
               DET(1) = DET(1)/TEN
               DET(2) = DET(2) + 1.0D0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(U)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 150
         DO 100 K = 1, N
            A(K,K) = 1.0D0/A(K,K)
            T = -A(K,K)
            CALL DSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0D0
               CALL DAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 140
         DO 130 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 110 I = KP1, N
               WORK(I) = A(I,K)
               A(I,K) = 0.0D0
  110       CONTINUE
            DO 120 J = KP1, N
               T = WORK(J)
               CALL DAXPY(N,T,A(1,J),1,A(1,K),1)
  120       CONTINUE
            L = IPVT(K)
            IF (L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1)
  130    CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END
      SUBROUTINE ARCECO(N, ARRAY, MTRSTR, NMBLKS, PIVOT, B, X, IFLAG)
C
C***************************************************************
C
C  THIS PROGRAM SOLVES THE LINEAR SYSTEM  A*X = B  WHERE  A IS
C  AN ALMOST BLOCK DIAGONAL MATRIX.  THE METHOD IMPLEMENTED IS
C  BASED ON GAUSS ELIMINATION WITH ALTERNATE ROW AND COLUMN
C  ELIMINATION WITH PARTIAL PIVOTING, WHICH PRODUCES A STABLE
C  DECOMPOSITION OF THE MATRIX  A  WITHOUT INTRODUCING FILL-IN.
C
C***************************************************************
C
C               *****  PARAMETERS  *****
C
C       *** ON ENTRY ...
C
C                N     - INTEGER
C                         THE ORDER OF THE LINEAR SYSTEM, WHERE
C                           N = SUM(MTRSTR(1,K),K=1,NMBLKS)
C
C                ARRAY - REAL(NUMELS)
C                         WHERE
C                          NUMELS = SUM(MTRSTR(1,K)*MTRSTR(2,K),
C                               K=1,NMBLKS).
C                         CONTAINS THE ENTRIES OF THE ALMOST
C                         BLOCK DIAGONAL MATRIX  A  WHOSE BLOCK
C                         STRUCTURE IS GIVEN BY THE INTEGER ARRAY
C                         MTRSTR. THE ELEMENTS OF A ARE STORED BY
C                         COLUMNS, IN BLOCKS CORRESPONDING TO THE
C                         GIVEN STRUCTURE.
C
C               MTRSTR - INTEGER(3,NMBLKS)
C                         DESCRIBES THE BLOCK STRUCTURE OF  A ...
C                           MTRSTR(1,K)  = NUMBER OF ROWS IN
C                                            BLOCK K.
C                           MTRSTR(2,K)  = NUMBER OF COLUMNS IN
C                                            BLOCK K.
C                           MTRSTR(3,K)  = NUMBER OF COLUMNS
C                                          OVERLAPPED BY BLOCK K
C                                          AND BLOCK (K+1).
C                        MTRSTR MUST SATISFY SOME RESTRICTIONS.
C                         IN ORDER THAT A BE SQUARE, WE NEED
C                         SUM(MTRSTR(1,K),K=1,NMBLKS) = N =
C                         SUM((MTRSTR(2,K)-MTRSTR(3,K)),K=1,NMBLKS).
C                        IN ADDITION, TO ENSURE THAT THREE SUCCESS-
C                         IVE BLOCKS DO NOT HAVE COLUMNS IN COMMON,
C                         MTRSTR MUST SATISFY
C                         MTRSTR(3,K-1)+MTRSTR(3,K).LE.MTRSTR(2,K),
C                         FOR K = 2,NMBLKS.
C                        FINALLY,  A R C E C O,  SETS
C                         MTRSTR(3,NMBLKS) = 0, IN ARCECD.
C
C               NMBLKS - INTEGER
C                         TOTAL NUMBER OF BLOCKS IN  A
C
C                PIVOT - INTEGER(N)
C                         WORK SPACE
C
C                    B - REAL(N)
C                         THE RIGHT HAND SIDE VECTOR
C
C                    X - REAL(N)
C                         WORK SPACE
C
C       *** ON RETURN  ...
C
C                ARRAY - REAL(NUMELS)
C                         CONTAINS THE MODIFIED ALTERNATE ROW
C                         AND COLUMN DECOMPOSITION OF  A (IF
C                         IFLAG = 0)
C
C                PIVOT - INTEGER(N)
C                         RECORDS THE PIVOTING INDICES DETER-
C                         MINED IN THE DECOMPOSITION
C
C                    X - REAL(N)
C                         THE SOLUTION VECTOR (IF IFLAG = 0)
C
C                IFLAG - INTEGER
C                         =  1,IF INPUT PARAMETERS ARE INVALID
C                         = -1, IF MATRIX IS SINGULAR
C                         =  0, OTHERWISE
C
C***************************************************************
C
C               *****  AUXILIARY PROGRAMS  *****
C
C            ARCEDC(ARRAY,MTRSTR,NMBLKS,PIVOT,IFLAG)
C               - DECOMPOSES THE MATRIX  A  USING MODIFIED
C                 ALTERNATE ROW AND COLUMN ELIMINATION
C                 WITH PARTIAL PIVOTING, AND IS USED FOR
C                 THIS PURPOSE IN  A R C E C O.
C                 THE ARGUMENTS ARE ALL AS IN A R C E C O.
C
C            ARCESL(ARRAY,MTRSTR,NMBLKS,PIVOT,B,X)
C               - SOLVES THE SYSTEM  A*X = B  ONCE  A  IS
C                 DECOMPOSED.
C                 THE ARGUMENTS ARE ALL AS IN A R C E C O .
C
C***************************************************************
C
C               *****  BLOCK STRUCTURE OF  A  *****
C
C  THE NMBLKS BLOCKS OF A ARE STORED CONSECUTIVELY IN THE ONE
C  DIMENSIONAL MATRIX  ARRAY, THE ENTRIES OF  A  BEING STORED
C  AS FOLLOWS ...
C
C       IN ARRAY(1)     THE (1,1) ENTRY OF THE TOP BLOCK,
C
C       IN ARRAY(INDEX) THE (1,1) ENTRY OF THE ITH BLOCK WHERE
C                       INDEX = 1 + SUM(MTRSTR(1,J)*MTRSTR(2,J),
C                               J=1,I-1), I=2,NMBLKS.
C
C***************************************************************
C
C       THE SUBROUTINE  A R C E C O  AUTOMATICALLY SOLVES THE
C  INPUT SYSTEM WHEN IFLAG=0.  A R C E C O  IS CALLED ONLY ONCE
C  FOR A GIVEN SYSTEM. THE SOLUTION FOR A SEQUENCE OF P RIGHT
C  HAND SIDES CAN BE OBTAINED BY ONE CALL TO  A R C E C O  AND
C  P-1 CALLS TO ARCESL ONLY. SINCE THE ARRAYS ARRAY AND
C  PIVOT CONTAIN, RESPECTIVELY, THE DECOMPOSITION OF THE GIVEN
C  COEFFICIENT MATRIX AND PIVOTING INFORMATION ON RETURN FROM
C  A R C E C O , THEY MUST NOT BE ALTERED BETWEEN SUCCESSIVE
C  CALLS TO ARCESL WITH THE SAME RIGHT HAND SIDES. FOR THE
C  SAME REASON, IF THE USER WISHES TO SAVE THE COEFFICIENT
C  MATRIX, THE ARRAY ARRAY MUST BE COPIED BEFORE A CALL
C  TO  A R C E C O .
C
C**********************************************************************
      REAL ARRAY, B, X
      INTEGER MTRSTR(3,*), PIVOT(*)
      DIMENSION ARRAY(*), B(*), X(*)
      CALL ARCEDC(N, ARRAY, MTRSTR, NMBLKS, PIVOT, IFLAG)
      IF (IFLAG.NE.0) RETURN
      CALL ARCESL(ARRAY, MTRSTR, NMBLKS, PIVOT, B, X)
      RETURN
      END
      SUBROUTINE ARCEDC(N, ARRAY, MTRSTR, NMBLKS, PIVOT, IFLAG)
C
C***************************************************************
C
C  A R C E D C SUPERVISES THE MODIFIED ALTERNATE ROW AND COLUMN
C  DECOMPOSITION WITH PARTIAL PIVOTING OF THE ALMOST BLOCK
C  DIAGONAL MATRIX  A   STORED IN THE ARRAYS A R R A Y  AND
C  M T R S T R .
C
C***************************************************************
C
C               *****  PARAMETERS  *****
C
C       *** ON ENTRY ...
C
C                N     - INTEGER
C                         THE ORDER OF THE LINEAR SYSTEM, WHERE
C                           N = SUM(MTRSTR(1,K),K=1,NMBLKS)
C
C                ARRAY - REAL(NUMELS)
C                         WHERE
C                          NUMELS = SUM(MTRSTR(1,K)*MTRSTR(2,K),
C                               K=1,NMBLKS).
C                         CONTAINS THE ENTRIES OF THE ALMOST
C                         BLOCK DIAGONAL MATRIX  A  WHOSE BLOCK
C                         STRUCTURE IS GIVEN BY THE INTEGER ARRAY
C                         MTRSTR. THE ELEMENTS OF A ARE STORED BY
C                         COLUMNS, IN BLOCKS CORRESPONDING TO THE
C                         GIVEN STRUCTURE.
C               MTRSTR - INTEGER(3,NMBLKS)
C                         DESCRIBES THE BLOCK STRUCTURE OF  A ...
C                           MTRSTR(1,K)  = NUMBER OF ROWS IN
C                                            BLOCK K.
C                           MTRSTR(2,K)  = NUMBER OF COLUMNS IN
C                                            BLOCK K.
C                           MTRSTR(3,K)  = NUMBER OF COLUMNS
C                                          OVERLAPPED BY BLOCK K
C                                          AND BLOCK (K+1).
C                        MTRSTR MUST SATISFY SOME RESTRICTIONS.
C                         IN ORDER THAT A BE SQUARE, WE NEED
C                         SUM(MTRSTR(1,K),K=1,NMBLKS) = N =
C                         SUM((MTRSTR(2,K)-MTRSTR(3,K)),K=1,NMBLKS).
C                        IN ADDITION, TO ENSURE THAT THREE SUCCESS-
C                         IVE BLOCKS DO NOT HAVE COLUMNS IN COMMON,
C                         MTRSTR MUST SATISFY
C                         MTRSTR(3,K-1)+MTRSTR(3,K).LE.MTRSTR(2,K),
C                         FOR K = 2,NMBLKS.
C                        FINALLY,  A R C E C O,  SETS
C                         MTRSTR(3,NMBLKS) = 0, IN ARCECD.
C
C               NMBLKS - INTEGER
C                         TOTAL NUMBER OF BLOCKS
C
C                PIVOT - INTEGER(N)
C                         WORK SPACE
C
C       *** ON RETURN  ...
C
C                ARRAY - REAL(NUMELS)
C                         CONTAINS THE MODIFIED ALTERNATE ROW
C                         AND COLUMN DECOMPOSITION OF  A (IF
C                         IFLAG = 0)
C
C                PIVOT - INTEGER(N)
C                         RECORDS THE PIVOTING INDICES DETER-
C                         MINED IN THE DECOMPOSITION
C
C                IFLAG - INTEGER
C                         =  1, IF INPUT PARAMETERS ARE INVALID
C                         = -1, IF MATRIX IS SINGULAR
C                         =  0, OTHERWISE
C
C***************************************************************
C
C               *****  AUXILIARY PROGRAMS  *****
C
C       ARCEPR(BLOCK,NRWBLK,NCLBLK,NRWPIV,PIVOT,PIVMAX,IFLAG)
C        CARRIES OUT THE ROW ELIMINATIONS
C
C       ARCEPC(TOPBLK,NRWTOP,NOVRLP,BOTBLK,NRWBOT,NCLPIV,
C            PIVOT,PIVMAX,IFLAG)
C        CARRIES OUT THE COLUMN ELIMINATIONS
C
C***************************************************************
C
      REAL ARRAY, PIVMAX, ZERO
      INTEGER PIVOT(*)
      DIMENSION ARRAY(*), MTRSTR(3,*)
      DATA ZERO /0.0/
C
C***************************************************************
C
C       ****  CHECK VALIDITY OF THE INPUT PARAMETERS....
C
C            IF PARAMETERS ARE INVALID THEN TERMINATE AT 7,
C                                      ELSE CONTINUE AT 8.
C
C***************************************************************
C
C
      MTRSTR(3,NMBLKS) = 0
      DO 10 K=2,NMBLKS
        IF (MTRSTR(3,K-1)+MTRSTR(3,K).GT.MTRSTR(2,K)) GO TO 30
   10 CONTINUE
      ISUM1 = 0
      ISUM2 = 0
      DO 20 K=1,NMBLKS
        ISUM1 = ISUM1 + MTRSTR(1,K)
        ISUM2 = ISUM2 + MTRSTR(2,K) - MTRSTR(3,K)
   20 CONTINUE
      IF (ISUM1.NE.ISUM2) GO TO 30
      IF (ISUM1.NE.N) GO TO 30
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C          PARAMETERS ARE ACCEPTABLE - CONTINUE AT 8
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      GO TO 40
   30 CONTINUE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C        PARAMETERS ARE INVALID.  SET IFLAG = 1, AND TERMINATE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IFLAG = 1
      RETURN
   40 CONTINUE
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C  INTERNAL PARAMETERS ...
C       C
C       C       INDEX1  POINTER TO THE ELEMENT IN THE COLUMN
C       C               WHERE ROW PIVOTING STARTS.
C       C
C       C       INDEX2  POINTER TO THE ELEMENT IN THE COLUMN
C       C               WHERE COLUMN PIVOTING STARTS.
C       C
C       C       INDEX3  POINTER TO 1ST ELEMENT IN 1ST COLUMN
C       C               OF NEXT BLOCK.
C       C
C       C       INDPIV  POINTER TO 1ST ELEMENT OF BLOCK OF PIVOT
C       C
C       C       NRWBLK  NUMBER OF ROWS IN BLOCK.
C       C
C       C       NRWBK2  NUMBER OF ROWS IN NEXT BLOCK.
C       C
C       C       NRWPIV  NUMBER OF ROW ELIMINATIONS.
C       C
C       C       NCLBLK  NUMBER OF COLUMNS IN BLOCK TO BE
C       C               ROW PIVOTED.
C       C
C       C       NCLPIV  NUMBER OF COLUMN ELIMINATIONS.
C       C
C       C       NOVRLP  NUMBER OF COLUMNS OVERLAPPED BY THE
C       C               CURRENT BLOCK AND THE NEXT BLOCK.
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      PIVMAX = ZERO
      IFLAG = 0
      INDEX1 = 1
      INDPIV = 1
      NRWBLK = MTRSTR(1,1)
      NCLBLK = MTRSTR(2,1)
      NOVRLP = MTRSTR(3,1)
      NRWPIV = NCLBLK - NOVRLP
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       CALL ARCEPR TO PERFORM NRWPIV ROW ELIMINATIONS
C       C               ON TOP BLOCK.
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IF (NRWPIV.GT.0) CALL ARCEPR(ARRAY(INDEX1), NRWBLK, NCLBLK,
     * NRWPIV, PIVOT(INDPIV), PIVMAX, IFLAG)
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       IF MATRIX SINGULAR RETURN.
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IF (IFLAG.LT.0) RETURN
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       NOW DO DECOMPOSITION PROCEEDING ONE BLOCK AT A
C       C               TIME.
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      DO 70 K=2,NMBLKS
        INDPIV = INDPIV + NRWPIV
        INDEX2 = INDEX1 + NRWBLK*NRWPIV
        INDEX3 = INDEX2 + NRWBLK*NOVRLP
        NCLPIV = NRWBLK - NRWPIV
        NRWBK2 = MTRSTR(1,K)
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C  CALL ARCEPC TO PERFORM NCLPIV COLUMN ELIMINATIONS.
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (NCLPIV.EQ.0) GO TO 50
        CALL ARCEPC(ARRAY(INDEX2), NRWBLK, NOVRLP, ARRAY(INDEX3),
     *   NRWBK2, NCLPIV, PIVOT(INDPIV), PIVMAX, IFLAG)
C
C             CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C             C
C             C    IF MATRIX IS SINGULAR RETURN.
C             C
C             CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (IFLAG.LT.0) RETURN
   50   CONTINUE
        NRWBLK = NRWBK2
        INDEX1 = INDEX3 + NRWBLK*NCLPIV
        NCLBLK = MTRSTR(2,K) - NCLPIV
        NOVRLP = MTRSTR(3,K)
        NRWPIV = NCLBLK - NOVRLP
        INDPIV = INDPIV + NCLPIV
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    CALL ARCEPR TO PERFORM NRWPIV ROW ELIMINATIONS.
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (NRWPIV.EQ.0) GO TO 60
        CALL ARCEPR(ARRAY(INDEX1), NRWBLK, NCLBLK, NRWPIV,
     *   PIVOT(INDPIV), PIVMAX, IFLAG)
C             CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C             C
C             C    IF MATRIX IS SINGULAR RETURN.
C             C
C             CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (IFLAG.LT.0) RETURN
   60   CONTINUE
   70 CONTINUE
      RETURN
      END
      SUBROUTINE ARCEPR(BLOCK, NRWBLK, NCLBLK, NRWPIV, PIVOT, PIVMAX,
     * IFLAG)
C
C***************************************************************
C
C  A R C E P R  PERFORMS  NRWPIV  ROW ELIMINATIONS ON THE MATRIX
C               BLOCK
C
C***************************************************************
C
      INTEGER PIVOT(NRWBLK)
      REAL BLOCK, ROWMAX, PIVMAX, TEMPIV, ROWPIV, SWAP
      DIMENSION BLOCK(NRWBLK,NCLBLK)
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C        PERFORM NRWPIV ROW ELIMINATIONS...
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      DO 90 J=1,NRWPIV
        JPLUS1 = J + 1
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    DETERMINE ROW PIVOT AND PIVOT INDEX
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        MAX = J
        ROWMAX = ABS(BLOCK(J,J))
        IF (J.EQ.NRWBLK) GO TO 30
        DO 20 I1=JPLUS1,NRWBLK
          TEMPIV = ABS(BLOCK(I1,J))
          IF (TEMPIV.LE.ROWMAX) GO TO 10
          ROWMAX = TEMPIV
          MAX = I1
   10     CONTINUE
   20   CONTINUE
   30   CONTINUE
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    TEST FOR SINGULARITY ...
C          C
C          C             IF SINGULAR THEN TERMINATE AT 90,
C          C                         ELSE CONTINUE.
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (PIVMAX+ROWMAX.EQ.PIVMAX) GO TO 100
        PIVMAX = AMAX1(PIVMAX,ROWMAX)
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    IF NECESSARY INTERCHANGE ROWS
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        PIVOT(J) = MAX
        IF (J.EQ.MAX) GO TO 50
        DO 40 J1=J,NCLBLK
          SWAP = BLOCK(MAX,J1)
          BLOCK(MAX,J1) = BLOCK(J,J1)
          BLOCK(J,J1) = SWAP
   40   CONTINUE
   50   CONTINUE
        IF (J.EQ.NRWBLK) RETURN
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    COMPUTE THE MULTIPLIERS
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        ROWPIV = BLOCK(J,J)
        DO 60 I1=JPLUS1,NRWBLK
          BLOCK(I1,J) = BLOCK(I1,J)/ROWPIV
   60   CONTINUE
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    PERFORM ROW ELIMINATIONS WITH COLUMN INDEXING
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        DO 80 J1=JPLUS1,NCLBLK
          DO 70 L1=JPLUS1,NRWBLK
            BLOCK(L1,J1) = BLOCK(L1,J1) - BLOCK(L1,J)*BLOCK(J,J1)
   70     CONTINUE
   80   CONTINUE
   90 CONTINUE
      RETURN
  100 CONTINUE
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       MATRIX IS SINGULAR - SET IFLAG = -1.
C       C                            TERMINATE AT 90.
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IFLAG = -1
      RETURN
      END
      SUBROUTINE ARCEPC(TOPBLK, NRWTOP, NOVRLP, BOTBLK, NRWBOT, NCLPIV,
     * PIVOT, PIVMAX, IFLAG)
C
C***************************************************************
C
C     A R C E P C PERFORMS NCLPIV COLUMN ELIMINATIONS ON THE
C                 MATRICES TOPBLK AND BOTBLK
C***************************************************************
C
      REAL TOPBLK, BOTBLK, COLMAX, PIVMAX, COLMLT
      REAL TEMPIV, SWAP
      INTEGER PIVOT(NRWTOP)
      DIMENSION TOPBLK(NRWTOP,NOVRLP), BOTBLK(NRWBOT,NOVRLP)
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       PERFORM THE COLUMN ELIMINATIONS ON A LOOP.
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      DO 110 J=1,NCLPIV
        I = NRWTOP - NCLPIV + J
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    DETERMINE COLUMN PIVOT AND PIVOT INDEX
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        MAX = J
        COLMAX = ABS(TOPBLK(I,J))
        IF (J.EQ.NOVRLP) GO TO 30
        JPLUS1 = J + 1
        DO 20 J1=JPLUS1,NOVRLP
          TEMPIV = ABS(TOPBLK(I,J1))
          IF (TEMPIV.LE.COLMAX) GO TO 10
          COLMAX = TEMPIV
          MAX = J1
   10     CONTINUE
   20   CONTINUE
   30   CONTINUE
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    TEST FOR SINGULARITY ...
C          C
C          C             IF SINGULAR THEN TERMINATE AT 110,
C          C                         ELSE CONTINUE.
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (PIVMAX+COLMAX.EQ.PIVMAX) GO TO 120
        PIVMAX = AMAX1(PIVMAX,COLMAX)
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    IF NECESSARY INTERCHANGE COLUMNS
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        PIVOT(J) = MAX
        IF (J.EQ.MAX) GO TO 60
        DO 40 I1=I,NRWTOP
          SWAP = TOPBLK(I1,J)
          TOPBLK(I1,J) = TOPBLK(I1,MAX)
          TOPBLK(I1,MAX) = SWAP
   40   CONTINUE
        DO 50 I2=1,NRWBOT
          SWAP = BOTBLK(I2,J)
          BOTBLK(I2,J) = BOTBLK(I2,MAX)
          BOTBLK(I2,MAX) = SWAP
   50   CONTINUE
   60   CONTINUE
        IF (J.EQ.NOVRLP) RETURN
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    COMPUTE MULTIPLIERS AND PERFORM COLUMN
C          C            ELIMINATION
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        DO 100 J1=JPLUS1,NOVRLP
          COLMLT = TOPBLK(I,J1)/TOPBLK(I,J)
          TOPBLK(I,J1) = COLMLT
          IF (I.EQ.NRWTOP) GO TO 80
          IPLUS1 = I + 1
          DO 70 L1=IPLUS1,NRWTOP
            TOPBLK(L1,J1) = TOPBLK(L1,J1) - COLMLT*TOPBLK(L1,J)
   70     CONTINUE
   80     CONTINUE
          DO 90 L1=1,NRWBOT
            BOTBLK(L1,J1) = BOTBLK(L1,J1) - COLMLT*BOTBLK(L1,J)
   90     CONTINUE
  100   CONTINUE
  110 CONTINUE
      RETURN
  120 CONTINUE
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       MATRIX IS SINGULAR - SET IFLAG = -1.
C       C                            TERMINATE AT 110.
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IFLAG = -1
      RETURN
      END
      SUBROUTINE ARCESL(ARRAY, MTRSTR, NMBLKS, PIVOT, B, X)
C
C***************************************************************
C
C  A R C E S L  SUPERVISES THE SOLUTION OF THE LINEAR SYSTEM
C                          A*X = B
C  USING THE DECOMPOSITION OF THE MATRIX  A  ALREADY GENERATED
C  IN  A R C E D C.  IT INVOLVES TWO LOOPS, THE FORWARD LOOP,
C  CONSISTING OF FORWARD SOLUTION, FORWARD MODIFICATION, AND
C  FORWARD ELIMINATION, AND THE BACKWARD LOOP, CONSISTING OF
C  BACKWARD SOLUTION, BACKWARD MODIFICATION, AND BACKWARD
C  ELIMINATION.
C
C***************************************************************
C
C               *****  PARAMETERS  *****
C
C       *** ON ENTRY ...
C
C                ARRAY - REAL(NUMELS)
C                         WHERE
C                          NUMELS = SUM(MTRSTR(1,K)*MTRSTR(2,K),
C                               K=1,NMBLKS).
C                         OUTPUT FROM A R C E D C
C
C               MTRSTR - INTEGER(3,NMBLKS)
C                         DESCRIBES THE BLOCK STRUCTURE OF  A ...
C                           MTRSTR(1,K)  = NUMBER OF ROWS IN
C                                            BLOCK K.
C                           MTRSTR(2,K)  = NUMBER OF COLUMNS IN
C                                            BLOCK K.
C                           MTRSTR(3,K)  = NUMBER OF COLUMNS
C                                          OVERLAPPED BY BLOCK K
C                                          AND BLOCK (K+1).
C
C                        THE LINEAR SYSTEM IS OF ORDER
C                           N  = SUM(MTRSTR(1,K),K=1,NMBLKS)
C
C               NMBLKS - INTEGER
C                         TOTAL NUMBER OF BLOCKS IN  A
C
C                PIVOT - INTEGER(N)
C                         OUTPUT FROM A R C E D C
C
C                    B - REAL(N)
C                         THE RIGHT HAND SIDE VECTOR
C
C                    X - REAL(N)
C                         WORK SPACE
C
C       *** ON RETURN  ...
C
C
C                    X - REAL(N)
C                         THE SOLUTION VECTOR
C
C***************************************************************
C
C               *****  AUXILIARY PROGRAMS  *****
C
C
C       ARCEFS - PERFORMS FORWARD SOLUTION STEP
C
C       ARCEFM - PERFORMS FORWARD MODIFICATION STEP
C
C       ARCEFE - PERFORMS FORWARD ELIMINATION STEP
C
C       ARCEBS - PERFORMS BACKWARD SOLUTION STEP
C
C       ARCEBM - PERFORMS BACKWARD MODIFICATION STEP
C
C       ARCEBE - PERFORMS BACKWARD ELIMINATION STEP
C
C***************************************************************
C
      REAL ARRAY, B, X
      INTEGER PIVOT(*)
      DIMENSION ARRAY(*), MTRSTR(3,*), B(*), X(*)
      INDPIV = 1
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C  INTERNAL PARAMETERS ...
C       C
C       C       INDEXA  POINTER TO 1ST ELEMENT OF BLOCK OF A.
C       C
C       C       INDEXB  POINTER TO 1ST ELEMENT OF BLOCK OF B.
C       C
C       C       INDPIV,NRWBLK,NRWPIV,NCLBLK,NCLPIV,NOVRLP
C       C       ARE AS IN ARCEDC.
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      INDEXA = 1
      NRWBLK = MTRSTR(1,1)
      NCLBLK = MTRSTR(2,1)
      NOVRLP = MTRSTR(3,1)
      NRWPIV = NCLBLK - NOVRLP
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       CALL ARCEFE TO PERFORM FORWARD ELIMINATION.
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IF (NRWPIV.GT.0) CALL ARCEFE(ARRAY(INDEXA), NRWBLK, NRWPIV,
     * PIVOT(INDPIV), B(INDPIV))
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       FORWARD LOOP
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      DO 10 K=2,NMBLKS
        INDEXA = INDEXA + NRWBLK*NRWPIV
        NCLPIV = NRWBLK - NRWPIV
        INDPIV = INDPIV + NRWPIV
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    CALL ARCEFS TO PERFORM FORWARD SOLUTION
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (NCLPIV.GT.0) CALL ARCEFS(ARRAY(INDEXA), NRWBLK, NCLPIV,
     *   NOVRLP, B(INDPIV), X(INDPIV))
        INDEXA = INDEXA + NOVRLP*NRWBLK
        NRWBLK = MTRSTR(1,K)
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    CALL ARCEFM TO PERFORM FORWARD MODIFICATION
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (NCLPIV.GT.0) CALL ARCEFM(ARRAY(INDEXA), NRWBLK, NCLPIV,
     *   B(INDPIV), X(INDPIV))
        INDEXA = INDEXA + NRWBLK*NCLPIV
        NCLBLK = MTRSTR(2,K) - NCLPIV
        NOVRLP = MTRSTR(3,K)
        NRWPIV = NCLBLK - NOVRLP
        INDPIV = INDPIV + NCLPIV
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    CALL ARCEFE TO PERFORM FORWARD ELIMINATION
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (NRWPIV.GT.0) CALL ARCEFE(ARRAY(INDEXA), NRWBLK, NRWPIV,
     *   PIVOT(INDPIV), B(INDPIV))
   10 CONTINUE
C     INDEXB = INDPIV + NRWPIV - 1
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       BACKWARD LOOP
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      DO 30 LL=2,NMBLKS
        K = NMBLKS - LL + 1
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    CALL ARCEBM TO PERFORM BACKWARD MODIFICATION
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (NRWPIV.EQ.0) GO TO 20
        IF (NRWPIV.NE.NCLBLK) CALL ARCEBM(ARRAY(INDEXA), NRWBLK,
     *   NCLBLK, NRWPIV, B(INDPIV), X(INDPIV))
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    CALL ARCEBS TO PERFORM BACKWARD SOLUTION
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        CALL ARCEBS(ARRAY(INDEXA), NRWBLK, NCLBLK, NRWPIV, B(INDPIV),
     *   X(INDPIV))
   20   CONTINUE
        INDEXA = INDEXA - NRWBLK*NCLPIV
        NRWBLK = MTRSTR(1,K)
        NOVRLP = MTRSTR(3,K)
        INDEXA = INDEXA - NRWBLK*NOVRLP
        INDPIV = INDPIV - NCLPIV
C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C          C
C          C    CALL ARCEBE TO PERFORM BACKWARD ELIMINATION
C          C
C          CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
        IF (NCLPIV.GT.0) CALL ARCEBE(ARRAY(INDEXA), NRWBLK, NCLPIV,
     *   NOVRLP, PIVOT(INDPIV), X(INDPIV))
        NRWPIV = NRWBLK - NCLPIV
        NCLBLK = NOVRLP + NRWPIV
        INDEXA = INDEXA - NRWBLK*NRWPIV
        INDPIV = INDPIV - NRWPIV
        NCLPIV = MTRSTR(2,K) - NCLBLK
   30 CONTINUE
C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       C
C       C       IF ROW ELIMINATIONS WERE DONE IN TOPBLOCK, CALL
C       C       ARCEBS TO PERFORM BACKWARD SOLUTION
C       C
C       CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      IF (NRWPIV.EQ.0) RETURN
      IF (NRWPIV.NE.NCLBLK) CALL ARCEBM(ARRAY(INDEXA), NRWBLK, NCLBLK,
     * NRWPIV, B(INDPIV), X(INDPIV))
      CALL ARCEBS(ARRAY(INDEXA), NRWBLK, NCLBLK, NRWPIV, B(INDPIV),
     * X(INDPIV))
      RETURN
      END
      SUBROUTINE ARCEFS(BLOCK, NRWBLK, NCLPIV, NOVRLP, B, X)
C
C***************************************************************
C
C  A R C E F S PERFORMS THE FORWARD SOLUTION STEP IN THE
C  SOLUTION PHASE OF  A R C E C O.
C
C***************************************************************
C
      REAL BLOCK, B, X, XJ
      DIMENSION BLOCK(NRWBLK,NOVRLP), B(*), X(*)
      DO 20 J=1,NCLPIV
        I = NRWBLK - NCLPIV + J
        X(J) = B(J)/BLOCK(I,J)
        IF (I.EQ.NRWBLK) RETURN
        LONG = NRWBLK - I
        XJ = X(J)
        DO 10 L=1,LONG
          IPLUSL = I + L
          JPLUSL = J + L
          B(JPLUSL) = B(JPLUSL) - BLOCK(IPLUSL,J)*XJ
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE ARCEFM(BLOCK, NRWBLK, NCLPIV, B, X)
C
C***************************************************************
C
C  A R C E F M  PERFORMS THE FORWARD MODIFICATION STEP IN THE
C  SOLUTION PHASE OF  A R C E C O.
C
C***************************************************************
C
      REAL BLOCK, B, X, XJ
      DIMENSION BLOCK(NRWBLK,NCLPIV), B(*), X(*)
      DO 20 J=1,NCLPIV
        XJ = X(J)
        DO 10 L=1,NRWBLK
          NCLPVL = NCLPIV + L
          B(NCLPVL) = B(NCLPVL) - BLOCK(L,J)*XJ
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE ARCEFE(BLOCK, NRWBLK, NRWPIV, PIVOT, B)
C
C***************************************************************
C
C  A R C E F E  PERFORMS THE FORWARD ELIMINATION STEP IN THE
C  SOLUTION PHASE OF  A R C E C O.
C
C***************************************************************
C
      REAL BLOCK, B, BI, SWAP
      INTEGER PIVOT(NRWPIV), PIVOTI
      DIMENSION BLOCK(NRWBLK,NRWPIV), B(*)
      DO 30 I=1,NRWPIV
        PIVOTI = PIVOT(I)
        IF (PIVOTI.EQ.I) GO TO 10
        SWAP = B(I)
        B(I) = B(PIVOTI)
        B(PIVOTI) = SWAP
   10   CONTINUE
        IF (I.EQ.NRWBLK) RETURN
        BI = B(I)
        IPLUS1 = I + 1
        DO 20 L=IPLUS1,NRWBLK
          B(L) = B(L) - BLOCK(L,I)*BI
   20   CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE ARCEBS(BLOCK, NRWBLK, NCLBLK, NRWPIV, B, X)
C
C***************************************************************
C
C  A R C E B S PERFORMS THE BACKWARD SOLUTION STEP IN THE
C  SOLUTION PHASE OF  A R C E C O.
C
C***************************************************************
C
      REAL BLOCK, B, X, XJ
      DIMENSION BLOCK(NRWBLK,NCLBLK), B(*), X(*)
      DO 20 NJ=1,NRWPIV
        J = NRWPIV - NJ + 1
        X(J) = B(J)/BLOCK(J,J)
        IF (J.EQ.1) RETURN
        JMIN1 = J - 1
        XJ = X(J)
        DO 10 L=1,JMIN1
          B(L) = B(L) - BLOCK(L,J)*XJ
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE ARCEBM(BLOCK, NRWBLK, NCLBLK, NRWPIV, B, X)
C
C***************************************************************
C
C  A R C E B M  PERFORMS THE BACKWARD MODIFICATION STEP IN THE
C  SOLUTION PHASE OF  A R C E C O.
C
C***************************************************************
C
      REAL BLOCK, B, X, XJ
      DIMENSION BLOCK(NRWBLK,NCLBLK), B(*), X(*)
      NRWPV1 = NRWPIV + 1
      DO 20 J=NRWPV1,NCLBLK
        XJ = X(J)
        DO 10 L=1,NRWPIV
          B(L) = B(L) - BLOCK(L,J)*XJ
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE ARCEBE(BLOCK, NRWBLK, NCLPIV, NOVRLP, PIVOT, X)
C
C***************************************************************
C
C  A R C E B E PERFORMS THE BACKWARD ELIMINATION STEP IN THE
C  SOLUTION PHASE OF  A R C E C O.
C
C***************************************************************
C
      REAL BLOCK, X, DOTPRD, SWAP
      INTEGER PIVOT(NRWBLK), PIVOTJ
      DIMENSION BLOCK(NRWBLK,NOVRLP), X(*)
      DO 40 NJ=1,NCLPIV
        J = NCLPIV + 1 - NJ
        I = NRWBLK + 1 - NJ
        DOTPRD = X(J)
        IF (J.EQ.NOVRLP) GO TO 20
        JPLUS1 = J + 1
        DO 10 J1=JPLUS1,NOVRLP
          DOTPRD = DOTPRD - X(J1)*BLOCK(I,J1)
   10   CONTINUE
   20   CONTINUE
        X(J) = DOTPRD
        PIVOTJ = PIVOT(J)
        IF (PIVOTJ.EQ.J) GO TO 30
        SWAP = X(PIVOTJ)
        X(PIVOTJ) = X(J)
        X(J) = SWAP
   30   CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE BTSLV(MO, M, N, A, B, C, X, IP, IERR)
      INTEGER MO, M , N, IP(M,N)
      REAL A(M,M,N), B(M,M,N), C(M,M,N), X(*)
C
C     DECOMPOSE THE COEFFICIENT MATRIX
C
      IF (MO .NE. 0) GO TO 10
      CALL DECBT(M, N, A, B, C, IP, IERR)
      IF (IERR .NE. 0) RETURN
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   10 CALL SOLBT(M, N, A, B, C, X, IP)
      RETURN
      END
      SUBROUTINE DECBT (M, N, A, B, C, IP, IER)
      INTEGER M, N, IP(M,N), IER
      REAL A(M,M,N), B(M,M,N), C(M,M,N)
C-----------------------------------------------------------------------
C BLOCK-TRIDIAGONAL MATRIX DECOMPOSITION ROUTINE.
C WRITTEN BY A. C. HINDMARSH.
C LATEST REVISION JANUARY 26, 1977  (AG)
C REFERENCE.. UCID-30150
C             SOLUTION OF BLOCK-TRIDIAGONAL SYSTEMS OF LINEAR
C             ALGEBRAIC EQUATIONS
C             A.C. HINDMARSH
C             FEBRUARY 1977
C THE INPUT MATRIX CONTAINS THREE BLOCKS OF ELEMENTS IN EACH BLOCK-ROW,
C INCLUDING BLOCKS IN THE (1,3) AND (N,N-2) BLOCK POSITIONS.
C DECBT USES BLOCK GAUSS ELIMINATION AND SUBROUTINES DEC AND SOL
C FOR SOLUTION OF BLOCKS.  PARTIAL PIVOTING IS DONE WITHIN
C BLOCK-ROWS ONLY.
C INPUT..
C     M = ORDER OF EACH BLOCK.
C     N = NUMBER OF BLOCKS IN EACH DIRECTION OF THE MATRIX.
C         N MUST BE 4 OR MORE.  THE COMPLETE MATRIX HAS ORDER M*N.
C     A = M BY M BY N ARRAY CONTAINING DIAGONAL BLOCKS.
C         A(I,J,K) CONTAINS THE (I,J) ELEMENT OF THE K-TH BLOCK.
C     B = M BY M BY N ARRAY CONTAINING THE SUPER-DIAGONAL BLOCKS
C         (IN B(*,*,K) FOR K = 1,...,N-1) AND THE BLOCK IN THE (N,N-2)
C         BLOCK POSITION (IN B(*,*,N)).
C     C = M BY M BY N ARRAY CONTAINING THE SUBDIAGONAL BLOCKS
C         (IN C(*,*,K) FOR K = 2,3,...,N) AND THE BLOCK IN THE
C         (1,3) BLOCK POSITION (IN C(*,*,1)).
C    IP = INTEGER ARRAY OF LENGTH M*N FOR WORKING STORAGE.
C OUTPUT..
C A,B,C = M BY M BY N ARRAYS CONTAINING THE BLOCK LU DECOMPOSITION
C         OF THE INPUT MATRIX.
C    IP = M BY N ARRAY OF PIVOT INFORMATION.  IP(*,K) CONTAINS
C         INFORMATION FOR THE K-TH DIGONAL BLOCK.
C   IER = 0  IF NO TROUBLE OCCURRED, OR
C       = -1 IF THE INPUT VALUE OF M OR N WAS ILLEGAL, OR
C       = K  IF A SINGULAR MATRIX WAS FOUND IN THE K-TH DIAGONAL BLOCK.
C USE SOLBT TO SOLVE THE ASSOCIATED LINEAR SYSTEM.
C DECBT CALLS SUBROUTINES  DEC(M,M0,A,IP,IER)  AND  SOL(M,M0,A,Y,IP)
C FOR SOLUTION OF M BY M LINEAR SYSTEMS.
C-----------------------------------------------------------------------
      INTEGER NM1, NM2, KM1,I,J,K,L
      REAL DP
C
      IF (M .LT. 1 .OR. N .LT. 4) GO TO 210
      NM1 = N - 1
      NM2 = N - 2
C PROCESS THE FIRST BLOCK-ROW. -----------------------------------------
      CALL DEC (M, M, A, IP, IER)
      K = 1
      IF (IER .NE. 0) GO TO 200
      DO 10 J = 1,M
        CALL SOL (M, M, A, B(1,J,1), IP)
        CALL SOL (M, M, A, C(1,J,1), IP)
 10     CONTINUE
C ADJUST B(*,*,2). -----------------------------------------------------
      DO 40 J = 1,M
        DO 30 I = 1,M
          DP = 0.
          DO 20 L = 1,M
 20         DP = DP + C(I,L,2)*C(L,J,1)
          B(I,J,2) = B(I,J,2) - DP
 30       CONTINUE
 40     CONTINUE
C MAIN LOOP.  PROCESS BLOCK-ROWS 2 TO N-1. -----------------------------
      DO 100 K = 2,NM1
        KM1 = K - 1
        DO 70 J = 1,M
          DO 60 I = 1,M
            DP = 0.
            DO 50 L = 1,M
 50           DP = DP + C(I,L,K)*B(L,J,KM1)
            A(I,J,K) = A(I,J,K) - DP
 60         CONTINUE
 70       CONTINUE
        CALL DEC (M, M, A(1,1,K), IP(1,K), IER)
        IF (IER .NE. 0) GO TO 200
        DO 80 J = 1,M
 80       CALL SOL (M, M, A(1,1,K), B(1,J,K), IP(1,K))
 100    CONTINUE
C PROCESS LAST BLOCK-ROW AND RETURN. -----------------------------------
      DO 130 J = 1,M
        DO 120 I = 1,M
          DP = 0.
          DO 110 L = 1,M
 110        DP = DP + B(I,L,N)*B(L,J,NM2)
          C(I,J,N) = C(I,J,N) - DP
 120      CONTINUE
 130    CONTINUE
      DO 160 J = 1,M
        DO 150 I = 1,M
          DP = 0.
          DO 140 L = 1,M
 140        DP = DP + C(I,L,N)*B(L,J,NM1)
          A(I,J,N) = A(I,J,N) - DP
 150      CONTINUE
 160    CONTINUE
      CALL DEC (M, M, A(1,1,N), IP(1,N), IER)
      K = N
      IF (IER .NE. 0) GO TO 200
      RETURN
C ERROR RETURNS. -------------------------------------------------------
 200  IER = K
      RETURN
 210  IER = -1
      RETURN
C-----------------------  END OF SUBROUTINE DECBT  ---------------------
      END
      SUBROUTINE SOLBT (M, N, A, B, C, Y, IP)
      INTEGER M, N, IP(M,N)
      REAL A(M,M,N), B(M,M,N), C(M,M,N), Y(M,N)
C-----------------------------------------------------------------------
C SOLUTION OF BLOCK-TRIDIAGONAL LINEAR SYSTEM.
C COEFFICIENT MATRIX MUST HAVE BEEN PREVIOUSLY PROCESSED BY DECBT.
C M, N, A, B, C, AND IP  MUST NOT HAVE BEEN CHANGED SINCE CALL TO DECBT.
C WRITTEN BY A. C. HINDMARSH.
C INPUT..
C     M = ORDER OF EACH BLOCK.
C     N = NUMBER OF BLOCKS IN EACH DIRECTION OF MATRIX.
C A,B,C = M BY M BY N ARRAYS CONTAINING BLOCK LU DECOMPOSITION
C         OF COEFFICIENT MATRIX FROM DECBT.
C    IP = M BY N INTEGER ARRAY OF PIVOT INFORMATION FROM DECBT.
C     Y = ARRAY OF LENGTH M*N CONTAINING THE RIGHT-HAND SIDE VECTOR
C         (TREATED AS AN M BY N ARRAY HERE).
C OUTPUT..
C     Y = SOLUTION VECTOR, OF LENGTH M*N.
C SOLBT MAKES CALLS TO SUBROUTINE SOL(M,M0,A,Y,IP)
C FOR SOLUTION OF M BY M LINEAR SYSTEMS.
C-----------------------------------------------------------------------
      INTEGER NM1, NM2, KM1, I, J, K
      REAL DP
C
      NM1 = N - 1
      NM2 = N - 2
C FORWARD SOLUTION SWEEP. ----------------------------------------------
      CALL SOL (M, M, A, Y, IP)
      DO 30 K = 2,NM1
        KM1 = K - 1
        DO 20 I = 1,M
          DP = 0.
          DO 10 J = 1,M
 10         DP = DP + C(I,J,K)*Y(J,KM1)
          Y(I,K) = Y(I,K) - DP
 20       CONTINUE
        CALL SOL (M, M, A(1,1,K), Y(1,K), IP(1,K))
 30     CONTINUE
      DO 50 I = 1,M
        DP = 0.
        DO 40 J = 1,M
 40       DP = DP + C(I,J,N)*Y(J,NM1) + B(I,J,N)*Y(J,NM2)
        Y(I,N) = Y(I,N) - DP
 50     CONTINUE
      CALL SOL (M, M, A(1,1,N), Y(1,N), IP(1,N))
C BACKWARD SOLUTION SWEEP. ---------------------------------------------
      DO 80 KB = 1,NM1
        K = N - KB
        KP1 = K + 1
        DO 70 I = 1,M
          DP = 0.
          DO 60 J = 1,M
 60         DP = DP + B(I,J,K)*Y(J,KP1)
          Y(I,K) = Y(I,K) - DP
 70       CONTINUE
 80     CONTINUE
      DO 100 I = 1,M
        DP = 0.
        DO 90 J = 1,M
 90       DP = DP + C(I,J,1)*Y(J,3)
        Y(I,1) = Y(I,1) - DP
 100    CONTINUE
      RETURN
C-----------------------  END OF SUBROUTINE SOLBT  ---------------------
      END
      SUBROUTINE SMSLV(MO,N,M,A,B,KB,DET,RCOND,INERT,IERR,IPVT,WK)
C     ------------------
      REAL A(*),B(*)
      REAL DET(2),RCOND,T,WK(N)
      INTEGER INERT(3),IPVT(N),ONEJ
C     ------------------
C
C          MATRIX FACTORIZATION AND COMPUTATION OF RCOND
C
      IERR = 0
      CALL SSPCO(A,N,IPVT,RCOND,WK)
      T = 1.0 + RCOND
      IF (T .EQ. 1.0) GO TO 30
C
C                  SOLUTION OF THE EQUATION AX=B
C
      IF (M .LT. 1) GO TO 20
      ONEJ = 1
      DO 10 J=1,M
      CALL SSPSL(A,N,IPVT,B(ONEJ))
   10 ONEJ = ONEJ + KB
C
C             CALCULATION OF DET AND THE INVERSE OF A
C
   20 JOB = 110
      IF (MO .EQ. 0) JOB = 111
      CALL SSPDI(A,N,IPVT,DET,INERT,WK,JOB)
      RETURN
C
C                  THE PROBLEM CANNOT BE SOLVED
C
   30 IERR = 1
      RETURN
      END
      SUBROUTINE SSPCO(AP,N,KPVT,RCOND,Z)
      INTEGER N,KPVT(*)
      REAL AP(*),Z(*)
      REAL RCOND
C
C     SSPCO FACTORS A REAL SYMMETRIC MATRIX STORED IN PACKED
C     FORM BY ELIMINATION WITH SYMMETRIC PIVOTING AND ESTIMATES
C     THE CONDITION OF THE MATRIX.
C
C     IF  RCOND  IS NOT NEEDED, SSPFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW SSPCO BY SSPSL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW SSPCO BY SSPSL.
C     TO COMPUTE  INVERSE(A) , FOLLOW SSPCO BY SSPDI.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW SSPCO BY SSPDI.
C     TO COMPUTE  INERTIA(A), FOLLOW SSPCO BY SSPDI.
C
C     ON ENTRY
C
C        AP      REAL (N*(N+1)/2)
C                THE PACKED FORM OF A SYMMETRIC MATRIX  A .  THE
C                COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY
C                IN A ONE-DIMENSIONAL ARRAY OF LENGTH  N*(N+1)/2 .
C                SEE COMMENTS BELOW FOR DETAILS.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     OUTPUT
C
C        AP      A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH
C                WERE USED TO OBTAIN IT STORED IN PACKED FORM.
C                THE FACTORIZATION CAN BE WRITTEN  A = U*D*TRANS(U)
C                WHERE  U  IS A PRODUCT OF PERMUTATION AND UNIT
C                UPPER TRIANGULAR MATRICES , TRANS(U) IS THE
C                TRANSPOSE OF  U , AND  D  IS BLOCK DIAGONAL
C                WITH 1 BY 1 AND 2 BY 2 BLOCKS.
C
C        KPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   REAL
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       REAL(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     PACKED STORAGE
C
C          THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER
C          TRIANGLE OF A SYMMETRIC MATRIX.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K) = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     LINPACK SSPFA
C     BLAS SAXPY,SDOT,SSCAL,SASUM
C     FORTRAN ABS,AMAX1,IABS,SIGN
C
C     INTERNAL VARIABLES
C
      REAL AK,AKM1,BK,BKM1,SDOT,DENOM,EK,T
      REAL ANORM,S,SASUM,YNORM
      INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1
      INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS
C
C
C     FIND NORM OF A USING ONLY UPPER HALF
C
      J1 = 1
      DO 30 J = 1, N
         Z(J) = SASUM(J,AP(J1),1)
         IJ = J1
         J1 = J1 + J
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            Z(I) = Z(I) + ABS(AP(IJ))
            IJ = IJ + 1
   10    CONTINUE
   20    CONTINUE
   30 CONTINUE
      ANORM = 0.0E0
      DO 40 J = 1, N
         ANORM = AMAX1(ANORM,Z(J))
   40 CONTINUE
C
C     FACTOR
C
      CALL SSPFA(AP,N,KPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  U*D*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE U*D*W = E
C
      EK = 1.0E0
      DO 50 J = 1, N
         Z(J) = 0.0E0
   50 CONTINUE
      K = N
      IK = (N*(N - 1))/2
   60 IF (K .EQ. 0) GO TO 120
         KK = IK + K
         IKM1 = IK - (K - 1)
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         KP = IABS(KPVT(K))
         KPS = K + 1 - KS
         IF (KP .EQ. KPS) GO TO 70
            T = Z(KPS)
            Z(KPS) = Z(KP)
            Z(KP) = T
   70    CONTINUE
         IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,Z(K))
         Z(K) = Z(K) + EK
         CALL SAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1)
         IF (KS .EQ. 1) GO TO 80
            IF (Z(K-1) .NE. 0.0E0) EK = SIGN(EK,Z(K-1))
            Z(K-1) = Z(K-1) + EK
            CALL SAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1)
   80    CONTINUE
         IF (KS .EQ. 2) GO TO 100
            IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 90
               S = ABS(AP(KK))/ABS(Z(K))
               CALL SSCAL(N,S,Z,1)
               EK = S*EK
   90       CONTINUE
            IF (AP(KK) .NE. 0.0E0) Z(K) = Z(K)/AP(KK)
            IF (AP(KK) .EQ. 0.0E0) Z(K) = 1.0E0
         GO TO 110
  100    CONTINUE
            KM1K = IK + K - 1
            KM1KM1 = IKM1 + K - 1
            AK = AP(KK)/AP(KM1K)
            AKM1 = AP(KM1KM1)/AP(KM1K)
            BK = Z(K)/AP(KM1K)
            BKM1 = Z(K-1)/AP(KM1K)
            DENOM = AK*AKM1 - 1.0E0
            Z(K) = (AKM1*BK - BKM1)/DENOM
            Z(K-1) = (AK*BKM1 - BK)/DENOM
  110    CONTINUE
         K = K - KS
         IK = IK - K
         IF (KS .EQ. 2) IK = IK - (K + 1)
      GO TO 60
  120 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
C     SOLVE TRANS(U)*Y = W
C
      K = 1
      IK = 0
  130 IF (K .GT. N) GO TO 160
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. 1) GO TO 150
            Z(K) = Z(K) + SDOT(K-1,AP(IK+1),1,Z(1),1)
            IKP1 = IK + K
            IF (KS .EQ. 2)
     *         Z(K+1) = Z(K+1) + SDOT(K-1,AP(IKP1+1),1,Z(1),1)
            KP = IABS(KPVT(K))
            IF (KP .EQ. K) GO TO 140
               T = Z(K)
               Z(K) = Z(KP)
               Z(KP) = T
  140       CONTINUE
  150    CONTINUE
         IK = IK + K
         IF (KS .EQ. 2) IK = IK + (K + 1)
         K = K + KS
      GO TO 130
  160 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE U*D*V = Y
C
      K = N
      IK = N*(N - 1)/2
  170 IF (K .EQ. 0) GO TO 230
         KK = IK + K
         IKM1 = IK - (K - 1)
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. KS) GO TO 190
            KP = IABS(KPVT(K))
            KPS = K + 1 - KS
            IF (KP .EQ. KPS) GO TO 180
               T = Z(KPS)
               Z(KPS) = Z(KP)
               Z(KP) = T
  180       CONTINUE
            CALL SAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1)
            IF (KS .EQ. 2) CALL SAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1)
  190    CONTINUE
         IF (KS .EQ. 2) GO TO 210
            IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 200
               S = ABS(AP(KK))/ABS(Z(K))
               CALL SSCAL(N,S,Z,1)
               YNORM = S*YNORM
  200       CONTINUE
            IF (AP(KK) .NE. 0.0E0) Z(K) = Z(K)/AP(KK)
            IF (AP(KK) .EQ. 0.0E0) Z(K) = 1.0E0
         GO TO 220
  210    CONTINUE
            KM1K = IK + K - 1
            KM1KM1 = IKM1 + K - 1
            AK = AP(KK)/AP(KM1K)
            AKM1 = AP(KM1KM1)/AP(KM1K)
            BK = Z(K)/AP(KM1K)
            BKM1 = Z(K-1)/AP(KM1K)
            DENOM = AK*AKM1 - 1.0E0
            Z(K) = (AKM1*BK - BKM1)/DENOM
            Z(K-1) = (AK*BKM1 - BK)/DENOM
  220    CONTINUE
         K = K - KS
         IK = IK - K
         IF (KS .EQ. 2) IK = IK - (K + 1)
      GO TO 170
  230 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE TRANS(U)*Z = V
C
      K = 1
      IK = 0
  240 IF (K .GT. N) GO TO 270
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. 1) GO TO 260
            Z(K) = Z(K) + SDOT(K-1,AP(IK+1),1,Z(1),1)
            IKP1 = IK + K
            IF (KS .EQ. 2)
     *         Z(K+1) = Z(K+1) + SDOT(K-1,AP(IKP1+1),1,Z(1),1)
            KP = IABS(KPVT(K))
            IF (KP .EQ. K) GO TO 250
               T = Z(K)
               Z(K) = Z(KP)
               Z(KP) = T
  250       CONTINUE
  260    CONTINUE
         IK = IK + K
         IF (KS .EQ. 2) IK = IK + (K + 1)
         K = K + KS
      GO TO 240
  270 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END
      SUBROUTINE SSPFA(AP,N,KPVT,INFO)
      INTEGER N,KPVT(*),INFO
      REAL AP(*)
C
C     SSPFA FACTORS A REAL SYMMETRIC MATRIX STORED IN
C     PACKED FORM BY ELIMINATION WITH SYMMETRIC PIVOTING.
C
C     TO SOLVE  A*X = B , FOLLOW SSPFA BY SSPSL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW SSPFA BY SSPSL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW SSPFA BY SSPDI.
C     TO COMPUTE  INERTIA(A) , FOLLOW SSPFA BY SSPDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW SSPFA BY SSPDI.
C
C     ON ENTRY
C
C        AP      REAL (N*(N+1)/2)
C                THE PACKED FORM OF A SYMMETRIC MATRIX  A .  THE
C                COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY
C                IN A ONE-DIMENSIONAL ARRAY OF LENGTH  N*(N+1)/2 .
C                SEE COMMENTS BELOW FOR DETAILS.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     OUTPUT
C
C        AP      A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH
C                WERE USED TO OBTAIN IT STORED IN PACKED FORM.
C                THE FACTORIZATION CAN BE WRITTEN  A = U*D*TRANS(U)
C                WHERE  U  IS A PRODUCT OF PERMUTATION AND UNIT
C                UPPER TRIANGULAR MATRICES , TRANS(U) IS THE
C                TRANSPOSE OF  U , AND  D  IS BLOCK DIAGONAL
C                WITH 1 BY 1 AND 2 BY 2 BLOCKS.
C
C        KPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF THE K-TH PIVOT BLOCK IS SINGULAR. THIS IS
C                     NOT AN ERROR CONDITION FOR THIS SUBROUTINE,
C                     BUT IT DOES INDICATE THAT SSPSL OR SSPDI MAY
C                     DIVIDE BY ZERO IF CALLED.
C
C     PACKED STORAGE
C
C          THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER
C          TRIANGLE OF A SYMMETRIC MATRIX.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K)  = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SSWAP,ISAMAX
C     FORTRAN ABS,AMAX1,SQRT
C
C     INTERNAL VARIABLES
C
      REAL AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T
      REAL ABSAKK,ALPHA,COLMAX,ROWMAX
      INTEGER ISAMAX,IJ,IJJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK
      INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP
      LOGICAL SWAP
C
C
C     INITIALIZE
C
C     ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE.
      ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0
C
      INFO = 0
C
C     MAIN LOOP ON K, WHICH GOES FROM N TO 1.
C
      K = N
      IK = (N*(N - 1))/2
   10 CONTINUE
C
C        LEAVE THE LOOP IF K=0 OR K=1.
C
C     ...EXIT
         IF (K .EQ. 0) GO TO 200
         IF (K .GT. 1) GO TO 20
            KPVT(1) = 1
            IF (AP(1) .EQ. 0.0E0) INFO = 1
C     ......EXIT
            GO TO 200
   20    CONTINUE
C
C        THIS SECTION OF CODE DETERMINES THE KIND OF
C        ELIMINATION TO BE PERFORMED.  WHEN IT IS COMPLETED,
C        KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND
C        SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS
C        REQUIRED.
C
         KM1 = K - 1
         KK = IK + K
         ABSAKK = ABS(AP(KK))
C
C        DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C        COLUMN K.
C
         IMAX = ISAMAX(K-1,AP(IK+1),1)
         IMK = IK + IMAX
         COLMAX = ABS(AP(IMK))
         IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30
            KSTEP = 1
            SWAP = .FALSE.
         GO TO 90
   30    CONTINUE
C
C           DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C           ROW IMAX.
C
            ROWMAX = 0.0E0
            IMAXP1 = IMAX + 1
            IM = IMAX*(IMAX - 1)/2
            IMJ = IM + 2*IMAX
            DO 40 J = IMAXP1, K
               ROWMAX = AMAX1(ROWMAX,ABS(AP(IMJ)))
               IMJ = IMJ + J
   40       CONTINUE
            IF (IMAX .EQ. 1) GO TO 50
               JMAX = ISAMAX(IMAX-1,AP(IM+1),1)
               JMIM = JMAX + IM
               ROWMAX = AMAX1(ROWMAX,ABS(AP(JMIM)))
   50       CONTINUE
            IMIM = IMAX + IM
            IF (ABS(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60
               KSTEP = 1
               SWAP = .TRUE.
            GO TO 80
   60       CONTINUE
            IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70
               KSTEP = 1
               SWAP = .FALSE.
            GO TO 80
   70       CONTINUE
               KSTEP = 2
               SWAP = IMAX .NE. KM1
   80       CONTINUE
   90    CONTINUE
         IF (AMAX1(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100
C
C           COLUMN K IS ZERO.  SET INFO AND ITERATE THE LOOP.
C
            KPVT(K) = K
            INFO = K
         GO TO 190
  100    CONTINUE
         IF (KSTEP .EQ. 2) GO TO 140
C
C           1 X 1 PIVOT BLOCK.
C
            IF (.NOT.SWAP) GO TO 120
C
C              PERFORM AN INTERCHANGE.
C
               CALL SSWAP(IMAX,AP(IM+1),1,AP(IK+1),1)
               IMJ = IK + IMAX
               DO 110 JJ = IMAX, K
                  J = K + IMAX - JJ
                  JK = IK + J
                  T = AP(JK)
                  AP(JK) = AP(IMJ)
                  AP(IMJ) = T
                  IMJ = IMJ - (J - 1)
  110          CONTINUE
  120       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            IJ = IK - (K - 1)
            DO 130 JJ = 1, KM1
               J = K - JJ
               JK = IK + J
               MULK = -AP(JK)/AP(KK)
               T = MULK
               CALL SAXPY(J,T,AP(IK+1),1,AP(IJ+1),1)
               IJJ = IJ + J
               AP(JK) = MULK
               IJ = IJ - (J - 1)
  130       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = K
            IF (SWAP) KPVT(K) = IMAX
         GO TO 190
  140    CONTINUE
C
C           2 X 2 PIVOT BLOCK.
C
            KM1K = IK + K - 1
            IKM1 = IK - (K - 1)
            IF (.NOT.SWAP) GO TO 160
C
C              PERFORM AN INTERCHANGE.
C
               CALL SSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1)
               IMJ = IKM1 + IMAX
               DO 150 JJ = IMAX, KM1
                  J = KM1 + IMAX - JJ
                  JKM1 = IKM1 + J
                  T = AP(JKM1)
                  AP(JKM1) = AP(IMJ)
                  AP(IMJ) = T
                  IMJ = IMJ - (J - 1)
  150          CONTINUE
               T = AP(KM1K)
               AP(KM1K) = AP(IMK)
               AP(IMK) = T
  160       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            KM2 = K - 2
            IF (KM2 .EQ. 0) GO TO 180
               AK = AP(KK)/AP(KM1K)
               KM1KM1 = IKM1 + K - 1
               AKM1 = AP(KM1KM1)/AP(KM1K)
               DENOM = 1.0E0 - AK*AKM1
               IJ = IK - (K - 1) - (K - 2)
               DO 170 JJ = 1, KM2
                  J = KM1 - JJ
                  JK = IK + J
                  BK = AP(JK)/AP(KM1K)
                  JKM1 = IKM1 + J
                  BKM1 = AP(JKM1)/AP(KM1K)
                  MULK = (AKM1*BK - BKM1)/DENOM
                  MULKM1 = (AK*BKM1 - BK)/DENOM
                  T = MULK
                  CALL SAXPY(J,T,AP(IK+1),1,AP(IJ+1),1)
                  T = MULKM1
                  CALL SAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1)
                  AP(JK) = MULK
                  AP(JKM1) = MULKM1
                  IJJ = IJ + J
                  IJ = IJ - (J - 1)
  170          CONTINUE
  180       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = 1 - K
            IF (SWAP) KPVT(K) = -IMAX
            KPVT(K-1) = KPVT(K)
  190    CONTINUE
         IK = IK - (K - 1)
         IF (KSTEP .EQ. 2) IK = IK - (K - 2)
         K = K - KSTEP
      GO TO 10
  200 CONTINUE
      RETURN
      END
      SUBROUTINE SSPSL(AP,N,KPVT,B)
      INTEGER N,KPVT(*)
      REAL AP(*),B(*)
C
C     SSISL SOLVES THE REAL SYMMETRIC SYSTEM
C     A * X = B
C     USING THE FACTORS COMPUTED BY SSPFA.
C
C     ON ENTRY
C
C        AP      REAL(N*(N+1)/2)
C                THE OUTPUT FROM SSPFA.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        KPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SSPFA.
C
C        B       REAL(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO MAY OCCUR IF  SSPCO  HAS SET RCOND .EQ. 0.0
C        OR  SSPFA  HAS SET INFO .NE. 0  .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL SSPFA(AP,N,KPVT,INFO)
C           IF (INFO .NE. 0) GO TO ...
C           DO 10 J = 1, P
C              CALL SSPSL(AP,N,KPVT,C(1,J))
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SDOT
C     FORTRAN IABS
C
C     INTERNAL VARIABLES.
C
      REAL AK,AKM1,BK,BKM1,SDOT,DENOM,TEMP
      INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP
C
C     LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND
C     D INVERSE TO B.
C
      K = N
      IK = (N*(N - 1))/2
   10 IF (K .EQ. 0) GO TO 80
         KK = IK + K
         IF (KPVT(K) .LT. 0) GO TO 40
C
C           1 X 1 PIVOT BLOCK.
C
            IF (K .EQ. 1) GO TO 30
               KP = KPVT(K)
               IF (KP .EQ. K) GO TO 20
C
C                 INTERCHANGE.
C
                  TEMP = B(K)
                  B(K) = B(KP)
                  B(KP) = TEMP
   20          CONTINUE
C
C              APPLY THE TRANSFORMATION.
C
               CALL SAXPY(K-1,B(K),AP(IK+1),1,B(1),1)
   30       CONTINUE
C
C           APPLY D INVERSE.
C
            B(K) = B(K)/AP(KK)
            K = K - 1
            IK = IK - K
         GO TO 70
   40    CONTINUE
C
C           2 X 2 PIVOT BLOCK.
C
            IKM1 = IK - (K - 1)
            IF (K .EQ. 2) GO TO 60
               KP = IABS(KPVT(K))
               IF (KP .EQ. K - 1) GO TO 50
C
C                 INTERCHANGE.
C
                  TEMP = B(K-1)
                  B(K-1) = B(KP)
                  B(KP) = TEMP
   50          CONTINUE
C
C              APPLY THE TRANSFORMATION.
C
               CALL SAXPY(K-2,B(K),AP(IK+1),1,B(1),1)
               CALL SAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1)
   60       CONTINUE
C
C           APPLY D INVERSE.
C
            KM1K = IK + K - 1
            KK = IK + K
            AK = AP(KK)/AP(KM1K)
            KM1KM1 = IKM1 + K - 1
            AKM1 = AP(KM1KM1)/AP(KM1K)
            BK = B(K)/AP(KM1K)
            BKM1 = B(K-1)/AP(KM1K)
            DENOM = AK*AKM1 - 1.0E0
            B(K) = (AKM1*BK - BKM1)/DENOM
            B(K-1) = (AK*BKM1 - BK)/DENOM
            K = K - 2
            IK = IK - (K + 1) - K
   70    CONTINUE
      GO TO 10
   80 CONTINUE
C
C     LOOP FORWARD APPLYING THE TRANSFORMATIONS.
C
      K = 1
      IK = 0
   90 IF (K .GT. N) GO TO 160
         IF (KPVT(K) .LT. 0) GO TO 120
C
C           1 X 1 PIVOT BLOCK.
C
            IF (K .EQ. 1) GO TO 110
C
C              APPLY THE TRANSFORMATION.
C
               B(K) = B(K) + SDOT(K-1,AP(IK+1),1,B(1),1)
               KP = KPVT(K)
               IF (KP .EQ. K) GO TO 100
C
C                 INTERCHANGE.
C
                  TEMP = B(K)
                  B(K) = B(KP)
                  B(KP) = TEMP
  100          CONTINUE
  110       CONTINUE
            IK = IK + K
            K = K + 1
         GO TO 150
  120    CONTINUE
C
C           2 X 2 PIVOT BLOCK.
C
            IF (K .EQ. 1) GO TO 140
C
C              APPLY THE TRANSFORMATION.
C
               B(K) = B(K) + SDOT(K-1,AP(IK+1),1,B(1),1)
               IKP1 = IK + K
               B(K+1) = B(K+1) + SDOT(K-1,AP(IKP1+1),1,B(1),1)
               KP = IABS(KPVT(K))
               IF (KP .EQ. K) GO TO 130
C
C                 INTERCHANGE.
C
                  TEMP = B(K)
                  B(K) = B(KP)
                  B(KP) = TEMP
  130          CONTINUE
  140       CONTINUE
            IK = IK + K + K + 1
            K = K + 2
  150    CONTINUE
      GO TO 90
  160 CONTINUE
      RETURN
      END
      SUBROUTINE SSPDI(AP,N,KPVT,DET,INERT,WORK,JOB)
      INTEGER N,JOB
      REAL AP(*),WORK(*)
      REAL DET(2)
      INTEGER KPVT(*),INERT(3)
C
C     SSPDI COMPUTES THE DETERMINANT, INERTIA AND INVERSE
C     OF A REAL SYMMETRIC MATRIX USING THE FACTORS FROM SSPFA,
C     WHERE THE MATRIX IS STORED IN PACKED FORM.
C
C     ON ENTRY
C
C        AP      REAL (N*(N+1)/2)
C                THE OUTPUT FROM SSPFA.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX A.
C
C        KPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SSPFA.
C
C        WORK    REAL(N)
C                WORK VECTOR.  CONTENTS IGNORED.
C
C        JOB     INTEGER
C                JOB HAS THE DECIMAL EXPANSION  ABC  WHERE
C                   IF  C .NE. 0, THE INVERSE IS COMPUTED,
C                   IF  B .NE. 0, THE DETERMINANT IS COMPUTED,
C                   IF  A .NE. 0, THE INERTIA IS COMPUTED.
C
C                FOR EXAMPLE, JOB = 111  GIVES ALL THREE.
C
C     ON RETURN
C
C        VARIABLES NOT REQUESTED BY JOB ARE NOT USED.
C
C        AP     CONTAINS THE UPPER TRIANGLE OF THE INVERSE OF
C               THE ORIGINAL MATRIX, STORED IN PACKED FORM.
C               THE COLUMNS OF THE UPPER TRIANGLE ARE STORED
C               SEQUENTIALLY IN A ONE-DIMENSIONAL ARRAY.
C
C        DET    REAL(2)
C               DETERMINANT OF ORIGINAL MATRIX.
C               DETERMINANT = DET(1) * 10.0**DET(2)
C               WITH 1.0 .LE. ABS(DET(1)) .LT. 10.0
C               OR DET(1) = 0.0.
C
C        INERT  INTEGER(3)
C               THE INERTIA OF THE ORIGINAL MATRIX.
C               INERT(1)  =  NUMBER OF POSITIVE EIGENVALUES.
C               INERT(2)  =  NUMBER OF NEGATIVE EIGENVALUES.
C               INERT(3)  =  NUMBER OF ZERO EIGENVALUES.
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INVERSE IS REQUESTED
C        AND  SSPCO  HAS SET RCOND .EQ. 0.0
C        OR  SSPFA  HAS SET  INFO .NE. 0 .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SCOPY,SDOT,SSWAP
C     FORTRAN ABS,IABS,MOD
C
C     INTERNAL VARIABLES.
C
      REAL AKKP1,SDOT,TEMP
      REAL TEN,D,T,AK,AKP1
      INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1
      INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP
      LOGICAL NOINV,NODET,NOERT
C
      NOINV = MOD(JOB,10) .EQ. 0
      NODET = MOD(JOB,100)/10 .EQ. 0
      NOERT = MOD(JOB,1000)/100 .EQ. 0
C
      IF (NODET .AND. NOERT) GO TO 140
         IF (NOERT) GO TO 10
            INERT(1) = 0
            INERT(2) = 0
            INERT(3) = 0
   10    CONTINUE
         IF (NODET) GO TO 20
            DET(1) = 1.0E0
            DET(2) = 0.0E0
            TEN = 10.0E0
   20    CONTINUE
         T = 0.0E0
         IK = 0
         DO 130 K = 1, N
            KK = IK + K
            D = AP(KK)
C
C           CHECK IF 1 BY 1
C
            IF (KPVT(K) .GT. 0) GO TO 50
C
C              2 BY 2 BLOCK
C              USE DET (D  S)  =  (D/T * C - T) * T  ,  T = ABS(S)
C                      (S  C)
C              TO AVOID UNDERFLOW/OVERFLOW TROUBLES.
C              TAKE TWO PASSES THROUGH SCALING.  USE  T  FOR FLAG.
C
               IF (T .NE. 0.0E0) GO TO 30
                  IKP1 = IK + K
                  KKP1 = IKP1 + K
                  T = ABS(AP(KKP1))
                  D = (D/T)*AP(KKP1+1) - T
               GO TO 40
   30          CONTINUE
                  D = T
                  T = 0.0E0
   40          CONTINUE
   50       CONTINUE
C
            IF (NOERT) GO TO 60
               IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1
               IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1
               IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1
   60       CONTINUE
C
            IF (NODET) GO TO 120
               DET(1) = D*DET(1)
               IF (DET(1) .EQ. 0.0E0) GO TO 110
   70             IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80
                     DET(1) = TEN*DET(1)
                     DET(2) = DET(2) - 1.0E0
                  GO TO 70
   80             CONTINUE
   90             IF (ABS(DET(1)) .LT. TEN) GO TO 100
                     DET(1) = DET(1)/TEN
                     DET(2) = DET(2) + 1.0E0
                  GO TO 90
  100             CONTINUE
  110          CONTINUE
  120       CONTINUE
            IK = IK + K
  130    CONTINUE
  140 CONTINUE
C
C     COMPUTE INVERSE(A)
C
      IF (NOINV) GO TO 270
         K = 1
         IK = 0
  150    IF (K .GT. N) GO TO 260
            KM1 = K - 1
            KK = IK + K
            IKP1 = IK + K
            KKP1 = IKP1 + K
            IF (KPVT(K) .LT. 0) GO TO 180
C
C              1 BY 1
C
               AP(KK) = 1.0E0/AP(KK)
               IF (KM1 .LT. 1) GO TO 170
                  CALL SCOPY(KM1,AP(IK+1),1,WORK,1)
                  IJ = 0
                  DO 160 J = 1, KM1
                     JK = IK + J
                     AP(JK) = SDOT(J,AP(IJ+1),1,WORK,1)
                     CALL SAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1)
                     IJ = IJ + J
  160             CONTINUE
                  AP(KK) = AP(KK) + SDOT(KM1,WORK,1,AP(IK+1),1)
  170          CONTINUE
               KSTEP = 1
            GO TO 220
  180       CONTINUE
C
C              2 BY 2
C
               T = ABS(AP(KKP1))
               AK = AP(KK)/T
               AKP1 = AP(KKP1+1)/T
               AKKP1 = AP(KKP1)/T
               D = T*(AK*AKP1 - 1.0E0)
               AP(KK) = AKP1/D
               AP(KKP1+1) = AK/D
               AP(KKP1) = -AKKP1/D
               IF (KM1 .LT. 1) GO TO 210
                  CALL SCOPY(KM1,AP(IKP1+1),1,WORK,1)
                  IJ = 0
                  DO 190 J = 1, KM1
                     JKP1 = IKP1 + J
                     AP(JKP1) = SDOT(J,AP(IJ+1),1,WORK,1)
                     CALL SAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1)
                     IJ = IJ + J
  190             CONTINUE
                  AP(KKP1+1) = AP(KKP1+1)
     *                         + SDOT(KM1,WORK,1,AP(IKP1+1),1)
                  AP(KKP1) = AP(KKP1)
     *                       + SDOT(KM1,AP(IK+1),1,AP(IKP1+1),1)
                  CALL SCOPY(KM1,AP(IK+1),1,WORK,1)
                  IJ = 0
                  DO 200 J = 1, KM1
                     JK = IK + J
                     AP(JK) = SDOT(J,AP(IJ+1),1,WORK,1)
                     CALL SAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1)
                     IJ = IJ + J
  200             CONTINUE
                  AP(KK) = AP(KK) + SDOT(KM1,WORK,1,AP(IK+1),1)
  210          CONTINUE
               KSTEP = 2
  220       CONTINUE
C
C           SWAP
C
            KS = IABS(KPVT(K))
            IF (KS .EQ. K) GO TO 250
               IKS = (KS*(KS - 1))/2
               CALL SSWAP(KS,AP(IKS+1),1,AP(IK+1),1)
               KSJ = IK + KS
               DO 230 JB = KS, K
                  J = K + KS - JB
                  JK = IK + J
                  TEMP = AP(JK)
                  AP(JK) = AP(KSJ)
                  AP(KSJ) = TEMP
                  KSJ = KSJ - (J - 1)
  230          CONTINUE
               IF (KSTEP .EQ. 1) GO TO 240
                  KSKP1 = IKP1 + KS
                  TEMP = AP(KSKP1)
                  AP(KSKP1) = AP(KKP1)
                  AP(KKP1) = TEMP
  240          CONTINUE
  250       CONTINUE
            IK = IK + K
            IF (KSTEP .EQ. 2) IK = IK + K + 1
            K = K + KSTEP
         GO TO 150
  260    CONTINUE
  270 CONTINUE
      RETURN
      END
      SUBROUTINE DSMSLV(MO,N,M,A,B,KB,DET,RCOND,INERT,IERR,IPVT,WK)
C     ------------------
      DOUBLE PRECISION A(*),B(*)
      DOUBLE PRECISION DET(2),RCOND,T,WK(N)
      INTEGER INERT(3),IPVT(N),ONEJ
C     ------------------
C
C          MATRIX FACTORIZATION AND COMPUTATION OF RCOND
C
      IERR = 0
      CALL DSPCO(A,N,IPVT,RCOND,WK)
      T = 1.D0 + RCOND
      IF (T .EQ. 1.D0) GO TO 30
C
C                  SOLUTION OF THE EQUATION AX=B
C
      IF (M .LT. 1) GO TO 20
      ONEJ = 1
      DO 10 J=1,M
      CALL DSPSL(A,N,IPVT,B(ONEJ))
   10 ONEJ = ONEJ + KB
C
C             CALCULATION OF DET AND THE INVERSE OF A
C
   20 JOB = 110
      IF (MO .EQ. 0) JOB = 111
      CALL DSPDI(A,N,IPVT,DET,INERT,WK,JOB)
      RETURN
C
C                  THE PROBLEM CANNOT BE SOLVED
C
   30 IERR = 1
      RETURN
      END
      SUBROUTINE DSPCO(AP,N,KPVT,RCOND,Z)
      INTEGER N,KPVT(*)
      DOUBLE PRECISION AP(*),Z(*)
      DOUBLE PRECISION RCOND
C
C     DSPCO FACTORS A DOUBLE PRECISION SYMMETRIC MATRIX STORED IN
C     PACKED FORM BY ELIMINATION WITH SYMMETRIC PIVOTING AND ESTIMATES
C     THE CONDITION OF THE MATRIX.
C
C     IF  RCOND  IS NOT NEEDED, DSPFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW DSPCO BY DSPSL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW DSPCO BY DSPSL.
C     TO COMPUTE  INVERSE(A) , FOLLOW DSPCO BY DSPDI.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW DSPCO BY DSPDI.
C     TO COMPUTE  INERTIA(A), FOLLOW DSPCO BY DSPDI.
C
C     ON ENTRY
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                THE PACKED FORM OF A SYMMETRIC MATRIX  A .  THE
C                COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY
C                IN A ONE-DIMENSIONAL ARRAY OF LENGTH  N*(N+1)/2 .
C                SEE COMMENTS BELOW FOR DETAILS.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     OUTPUT
C
C        AP      A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH
C                WERE USED TO OBTAIN IT STORED IN PACKED FORM.
C                THE FACTORIZATION CAN BE WRITTEN  A = U*D*TRANS(U)
C                WHERE  U  IS A PRODUCT OF PERMUTATION AND UNIT
C                UPPER TRIANGULAR MATRICES , TRANS(U) IS THE
C                TRANSPOSE OF  U , AND  D  IS BLOCK DIAGONAL
C                WITH 1 BY 1 AND 2 BY 2 BLOCKS.
C
C        KPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   DOUBLE PRECISION
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       DOUBLE PRECISION(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     PACKED STORAGE
C
C          THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER
C          TRIANGLE OF A SYMMETRIC MATRIX.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K) = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     LINPACK DSPFA
C     BLAS DAXPY,DDOT,DSCAL,DASUM
C     FORTRAN DABS,DMAX1,IABS,DSIGN
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T
      DOUBLE PRECISION ANORM,S,DASUM,YNORM
      INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1
      INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS
C
C
C     FIND NORM OF A USING ONLY UPPER HALF
C
      J1 = 1
      DO 30 J = 1, N
         Z(J) = DASUM(J,AP(J1),1)
         IJ = J1
         J1 = J1 + J
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            Z(I) = Z(I) + DABS(AP(IJ))
            IJ = IJ + 1
   10    CONTINUE
   20    CONTINUE
   30 CONTINUE
      ANORM = 0.0D0
      DO 40 J = 1, N
         ANORM = DMAX1(ANORM,Z(J))
   40 CONTINUE
C
C     FACTOR
C
      CALL DSPFA(AP,N,KPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  U*D*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE U*D*W = E
C
      EK = 1.0D0
      DO 50 J = 1, N
         Z(J) = 0.0D0
   50 CONTINUE
      K = N
      IK = (N*(N - 1))/2
   60 IF (K .EQ. 0) GO TO 120
         KK = IK + K
         IKM1 = IK - (K - 1)
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         KP = IABS(KPVT(K))
         KPS = K + 1 - KS
         IF (KP .EQ. KPS) GO TO 70
            T = Z(KPS)
            Z(KPS) = Z(KP)
            Z(KP) = T
   70    CONTINUE
         IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K))
         Z(K) = Z(K) + EK
         CALL DAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1)
         IF (KS .EQ. 1) GO TO 80
            IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1))
            Z(K-1) = Z(K-1) + EK
            CALL DAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1)
   80    CONTINUE
         IF (KS .EQ. 2) GO TO 100
            IF (DABS(Z(K)) .LE. DABS(AP(KK))) GO TO 90
               S = DABS(AP(KK))/DABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               EK = S*EK
   90       CONTINUE
            IF (AP(KK) .NE. 0.0D0) Z(K) = Z(K)/AP(KK)
            IF (AP(KK) .EQ. 0.0D0) Z(K) = 1.0D0
         GO TO 110
  100    CONTINUE
            KM1K = IK + K - 1
            KM1KM1 = IKM1 + K - 1
            AK = AP(KK)/AP(KM1K)
            AKM1 = AP(KM1KM1)/AP(KM1K)
            BK = Z(K)/AP(KM1K)
            BKM1 = Z(K-1)/AP(KM1K)
            DENOM = AK*AKM1 - 1.0D0
            Z(K) = (AKM1*BK - BKM1)/DENOM
            Z(K-1) = (AK*BKM1 - BK)/DENOM
  110    CONTINUE
         K = K - KS
         IK = IK - K
         IF (KS .EQ. 2) IK = IK - (K + 1)
      GO TO 60
  120 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
C     SOLVE TRANS(U)*Y = W
C
      K = 1
      IK = 0
  130 IF (K .GT. N) GO TO 160
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. 1) GO TO 150
            Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1)
            IKP1 = IK + K
            IF (KS .EQ. 2)
     *         Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1)
            KP = IABS(KPVT(K))
            IF (KP .EQ. K) GO TO 140
               T = Z(K)
               Z(K) = Z(KP)
               Z(KP) = T
  140       CONTINUE
  150    CONTINUE
         IK = IK + K
         IF (KS .EQ. 2) IK = IK + (K + 1)
         K = K + KS
      GO TO 130
  160 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
      YNORM = 1.0D0
C
C     SOLVE U*D*V = Y
C
      K = N
      IK = N*(N - 1)/2
  170 IF (K .EQ. 0) GO TO 230
         KK = IK + K
         IKM1 = IK - (K - 1)
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. KS) GO TO 190
            KP = IABS(KPVT(K))
            KPS = K + 1 - KS
            IF (KP .EQ. KPS) GO TO 180
               T = Z(KPS)
               Z(KPS) = Z(KP)
               Z(KP) = T
  180       CONTINUE
            CALL DAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1)
            IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1)
  190    CONTINUE
         IF (KS .EQ. 2) GO TO 210
            IF (DABS(Z(K)) .LE. DABS(AP(KK))) GO TO 200
               S = DABS(AP(KK))/DABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               YNORM = S*YNORM
  200       CONTINUE
            IF (AP(KK) .NE. 0.0D0) Z(K) = Z(K)/AP(KK)
            IF (AP(KK) .EQ. 0.0D0) Z(K) = 1.0D0
         GO TO 220
  210    CONTINUE
            KM1K = IK + K - 1
            KM1KM1 = IKM1 + K - 1
            AK = AP(KK)/AP(KM1K)
            AKM1 = AP(KM1KM1)/AP(KM1K)
            BK = Z(K)/AP(KM1K)
            BKM1 = Z(K-1)/AP(KM1K)
            DENOM = AK*AKM1 - 1.0D0
            Z(K) = (AKM1*BK - BKM1)/DENOM
            Z(K-1) = (AK*BKM1 - BK)/DENOM
  220    CONTINUE
         K = K - KS
         IK = IK - K
         IF (KS .EQ. 2) IK = IK - (K + 1)
      GO TO 170
  230 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE TRANS(U)*Z = V
C
      K = 1
      IK = 0
  240 IF (K .GT. N) GO TO 270
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. 1) GO TO 260
            Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1)
            IKP1 = IK + K
            IF (KS .EQ. 2)
     *         Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1)
            KP = IABS(KPVT(K))
            IF (KP .EQ. K) GO TO 250
               T = Z(K)
               Z(K) = Z(KP)
               Z(KP) = T
  250       CONTINUE
  260    CONTINUE
         IK = IK + K
         IF (KS .EQ. 2) IK = IK + (K + 1)
         K = K + KS
      GO TO 240
  270 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END
      SUBROUTINE DSPFA(AP,N,KPVT,INFO)
      INTEGER N,KPVT(*),INFO
      DOUBLE PRECISION AP(*)
C
C     DSPFA FACTORS A DOUBLE PRECISION SYMMETRIC MATRIX STORED IN
C     PACKED FORM BY ELIMINATION WITH SYMMETRIC PIVOTING.
C
C     TO SOLVE  A*X = B , FOLLOW DSPFA BY DSPSL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW DSPFA BY DSPSL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW DSPFA BY DSPDI.
C     TO COMPUTE  INERTIA(A) , FOLLOW DSPFA BY DSPDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW DSPFA BY DSPDI.
C
C     ON ENTRY
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                THE PACKED FORM OF A SYMMETRIC MATRIX  A .  THE
C                COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY
C                IN A ONE-DIMENSIONAL ARRAY OF LENGTH  N*(N+1)/2 .
C                SEE COMMENTS BELOW FOR DETAILS.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     OUTPUT
C
C        AP      A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH
C                WERE USED TO OBTAIN IT STORED IN PACKED FORM.
C                THE FACTORIZATION CAN BE WRITTEN  A = U*D*TRANS(U)
C                WHERE  U  IS A PRODUCT OF PERMUTATION AND UNIT
C                UPPER TRIANGULAR MATRICES , TRANS(U) IS THE
C                TRANSPOSE OF  U , AND  D  IS BLOCK DIAGONAL
C                WITH 1 BY 1 AND 2 BY 2 BLOCKS.
C
C        KPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF THE K-TH PIVOT BLOCK IS SINGULAR. THIS IS
C                     NOT AN ERROR CONDITION FOR THIS SUBROUTINE,
C                     BUT IT DOES INDICATE THAT DSPSL OR DSPDI MAY
C                     DIVIDE BY ZERO IF CALLED.
C
C     PACKED STORAGE
C
C          THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER
C          TRIANGLE OF A SYMMETRIC MATRIX.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K)  = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSWAP,IDAMAX
C     FORTRAN DABS,DMAX1,DSQRT
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T
      DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX
      INTEGER IDAMAX,IJ,IJJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK
      INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP
      LOGICAL SWAP
C
C
C     INITIALIZE
C
C     ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE.
      ALPHA = (1.0D0 + DSQRT(17.0D0))/8.0D0
C
      INFO = 0
C
C     MAIN LOOP ON K, WHICH GOES FROM N TO 1.
C
      K = N
      IK = (N*(N - 1))/2
   10 CONTINUE
C
C        LEAVE THE LOOP IF K=0 OR K=1.
C
C     ...EXIT
         IF (K .EQ. 0) GO TO 200
         IF (K .GT. 1) GO TO 20
            KPVT(1) = 1
            IF (AP(1) .EQ. 0.0D0) INFO = 1
C     ......EXIT
            GO TO 200
   20    CONTINUE
C
C        THIS SECTION OF CODE DETERMINES THE KIND OF
C        ELIMINATION TO BE PERFORMED.  WHEN IT IS COMPLETED,
C        KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND
C        SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS
C        REQUIRED.
C
         KM1 = K - 1
         KK = IK + K
         ABSAKK = DABS(AP(KK))
C
C        DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C        COLUMN K.
C
         IMAX = IDAMAX(K-1,AP(IK+1),1)
         IMK = IK + IMAX
         COLMAX = DABS(AP(IMK))
         IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30
            KSTEP = 1
            SWAP = .FALSE.
         GO TO 90
   30    CONTINUE
C
C           DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN
C           ROW IMAX.
C
            ROWMAX = 0.0D0
            IMAXP1 = IMAX + 1
            IM = IMAX*(IMAX - 1)/2
            IMJ = IM + 2*IMAX
            DO 40 J = IMAXP1, K
               ROWMAX = DMAX1(ROWMAX,DABS(AP(IMJ)))
               IMJ = IMJ + J
   40       CONTINUE
            IF (IMAX .EQ. 1) GO TO 50
               JMAX = IDAMAX(IMAX-1,AP(IM+1),1)
               JMIM = JMAX + IM
               ROWMAX = DMAX1(ROWMAX,DABS(AP(JMIM)))
   50       CONTINUE
            IMIM = IMAX + IM
            IF (DABS(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60
               KSTEP = 1
               SWAP = .TRUE.
            GO TO 80
   60       CONTINUE
            IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70
               KSTEP = 1
               SWAP = .FALSE.
            GO TO 80
   70       CONTINUE
               KSTEP = 2
               SWAP = IMAX .NE. KM1
   80       CONTINUE
   90    CONTINUE
         IF (DMAX1(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100
C
C           COLUMN K IS ZERO.  SET INFO AND ITERATE THE LOOP.
C
            KPVT(K) = K
            INFO = K
         GO TO 190
  100    CONTINUE
         IF (KSTEP .EQ. 2) GO TO 140
C
C           1 X 1 PIVOT BLOCK.
C
            IF (.NOT.SWAP) GO TO 120
C
C              PERFORM AN INTERCHANGE.
C
               CALL DSWAP(IMAX,AP(IM+1),1,AP(IK+1),1)
               IMJ = IK + IMAX
               DO 110 JJ = IMAX, K
                  J = K + IMAX - JJ
                  JK = IK + J
                  T = AP(JK)
                  AP(JK) = AP(IMJ)
                  AP(IMJ) = T
                  IMJ = IMJ - (J - 1)
  110          CONTINUE
  120       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            IJ = IK - (K - 1)
            DO 130 JJ = 1, KM1
               J = K - JJ
               JK = IK + J
               MULK = -AP(JK)/AP(KK)
               T = MULK
               CALL DAXPY(J,T,AP(IK+1),1,AP(IJ+1),1)
               IJJ = IJ + J
               AP(JK) = MULK
               IJ = IJ - (J - 1)
  130       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = K
            IF (SWAP) KPVT(K) = IMAX
         GO TO 190
  140    CONTINUE
C
C           2 X 2 PIVOT BLOCK.
C
            KM1K = IK + K - 1
            IKM1 = IK - (K - 1)
            IF (.NOT.SWAP) GO TO 160
C
C              PERFORM AN INTERCHANGE.
C
               CALL DSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1)
               IMJ = IKM1 + IMAX
               DO 150 JJ = IMAX, KM1
                  J = KM1 + IMAX - JJ
                  JKM1 = IKM1 + J
                  T = AP(JKM1)
                  AP(JKM1) = AP(IMJ)
                  AP(IMJ) = T
                  IMJ = IMJ - (J - 1)
  150          CONTINUE
               T = AP(KM1K)
               AP(KM1K) = AP(IMK)
               AP(IMK) = T
  160       CONTINUE
C
C           PERFORM THE ELIMINATION.
C
            KM2 = K - 2
            IF (KM2 .EQ. 0) GO TO 180
               AK = AP(KK)/AP(KM1K)
               KM1KM1 = IKM1 + K - 1
               AKM1 = AP(KM1KM1)/AP(KM1K)
               DENOM = 1.0D0 - AK*AKM1
               IJ = IK - (K - 1) - (K - 2)
               DO 170 JJ = 1, KM2
                  J = KM1 - JJ
                  JK = IK + J
                  BK = AP(JK)/AP(KM1K)
                  JKM1 = IKM1 + J
                  BKM1 = AP(JKM1)/AP(KM1K)
                  MULK = (AKM1*BK - BKM1)/DENOM
                  MULKM1 = (AK*BKM1 - BK)/DENOM
                  T = MULK
                  CALL DAXPY(J,T,AP(IK+1),1,AP(IJ+1),1)
                  T = MULKM1
                  CALL DAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1)
                  AP(JK) = MULK
                  AP(JKM1) = MULKM1
                  IJJ = IJ + J
                  IJ = IJ - (J - 1)
  170          CONTINUE
  180       CONTINUE
C
C           SET THE PIVOT ARRAY.
C
            KPVT(K) = 1 - K
            IF (SWAP) KPVT(K) = -IMAX
            KPVT(K-1) = KPVT(K)
  190    CONTINUE
         IK = IK - (K - 1)
         IF (KSTEP .EQ. 2) IK = IK - (K - 2)
         K = K - KSTEP
      GO TO 10
  200 CONTINUE
      RETURN
      END
      SUBROUTINE DSPSL(AP,N,KPVT,B)
      INTEGER N,KPVT(*)
      DOUBLE PRECISION AP(*),B(*)
C
C     DSISL SOLVES THE DOUBLE PRECISION SYMMETRIC SYSTEM
C     A * X = B
C     USING THE FACTORS COMPUTED BY DSPFA.
C
C     ON ENTRY
C
C        AP      DOUBLE PRECISION(N*(N+1)/2)
C                THE OUTPUT FROM DSPFA.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        KPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DSPFA.
C
C        B       DOUBLE PRECISION(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO MAY OCCUR IF  DSPCO  HAS SET RCOND .EQ. 0.0
C        OR  DSPFA  HAS SET INFO .NE. 0  .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL DSPFA(AP,N,KPVT,INFO)
C           IF (INFO .NE. 0) GO TO ...
C           DO 10 J = 1, P
C              CALL DSPSL(AP,N,KPVT,C(1,J))
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DDOT
C     FORTRAN IABS
C
C     INTERNAL VARIABLES.
C
      DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP
      INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP
C
C     LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND
C     D INVERSE TO B.
C
      K = N
      IK = (N*(N - 1))/2
   10 IF (K .EQ. 0) GO TO 80
         KK = IK + K
         IF (KPVT(K) .LT. 0) GO TO 40
C
C           1 X 1 PIVOT BLOCK.
C
            IF (K .EQ. 1) GO TO 30
               KP = KPVT(K)
               IF (KP .EQ. K) GO TO 20
C
C                 INTERCHANGE.
C
                  TEMP = B(K)
                  B(K) = B(KP)
                  B(KP) = TEMP
   20          CONTINUE
C
C              APPLY THE TRANSFORMATION.
C
               CALL DAXPY(K-1,B(K),AP(IK+1),1,B(1),1)
   30       CONTINUE
C
C           APPLY D INVERSE.
C
            B(K) = B(K)/AP(KK)
            K = K - 1
            IK = IK - K
         GO TO 70
   40    CONTINUE
C
C           2 X 2 PIVOT BLOCK.
C
            IKM1 = IK - (K - 1)
            IF (K .EQ. 2) GO TO 60
               KP = IABS(KPVT(K))
               IF (KP .EQ. K - 1) GO TO 50
C
C                 INTERCHANGE.
C
                  TEMP = B(K-1)
                  B(K-1) = B(KP)
                  B(KP) = TEMP
   50          CONTINUE
C
C              APPLY THE TRANSFORMATION.
C
               CALL DAXPY(K-2,B(K),AP(IK+1),1,B(1),1)
               CALL DAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1)
   60       CONTINUE
C
C           APPLY D INVERSE.
C
            KM1K = IK + K - 1
            KK = IK + K
            AK = AP(KK)/AP(KM1K)
            KM1KM1 = IKM1 + K - 1
            AKM1 = AP(KM1KM1)/AP(KM1K)
            BK = B(K)/AP(KM1K)
            BKM1 = B(K-1)/AP(KM1K)
            DENOM = AK*AKM1 - 1.0D0
            B(K) = (AKM1*BK - BKM1)/DENOM
            B(K-1) = (AK*BKM1 - BK)/DENOM
            K = K - 2
            IK = IK - (K + 1) - K
   70    CONTINUE
      GO TO 10
   80 CONTINUE
C
C     LOOP FORWARD APPLYING THE TRANSFORMATIONS.
C
      K = 1
      IK = 0
   90 IF (K .GT. N) GO TO 160
         IF (KPVT(K) .LT. 0) GO TO 120
C
C           1 X 1 PIVOT BLOCK.
C
            IF (K .EQ. 1) GO TO 110
C
C              APPLY THE TRANSFORMATION.
C
               B(K) = B(K) + DDOT(K-1,AP(IK+1),1,B(1),1)
               KP = KPVT(K)
               IF (KP .EQ. K) GO TO 100
C
C                 INTERCHANGE.
C
                  TEMP = B(K)
                  B(K) = B(KP)
                  B(KP) = TEMP
  100          CONTINUE
  110       CONTINUE
            IK = IK + K
            K = K + 1
         GO TO 150
  120    CONTINUE
C
C           2 X 2 PIVOT BLOCK.
C
            IF (K .EQ. 1) GO TO 140
C
C              APPLY THE TRANSFORMATION.
C
               B(K) = B(K) + DDOT(K-1,AP(IK+1),1,B(1),1)
               IKP1 = IK + K
               B(K+1) = B(K+1) + DDOT(K-1,AP(IKP1+1),1,B(1),1)
               KP = IABS(KPVT(K))
               IF (KP .EQ. K) GO TO 130
C
C                 INTERCHANGE.
C
                  TEMP = B(K)
                  B(K) = B(KP)
                  B(KP) = TEMP
  130          CONTINUE
  140       CONTINUE
            IK = IK + K + K + 1
            K = K + 2
  150    CONTINUE
      GO TO 90
  160 CONTINUE
      RETURN
      END
      SUBROUTINE DSPDI(AP,N,KPVT,DET,INERT,WORK,JOB)
      INTEGER N,JOB
      DOUBLE PRECISION AP(*),WORK(*)
      DOUBLE PRECISION DET(2)
      INTEGER KPVT(*),INERT(3)
C
C     DSPDI COMPUTES THE DETERMINANT, INERTIA AND INVERSE
C     OF A DOUBLE PRECISION SYMMETRIC MATRIX USING THE FACTORS FROM
C     DSPFA, WHERE THE MATRIX IS STORED IN PACKED FORM.
C
C     ON ENTRY
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                THE OUTPUT FROM DSPFA.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX A.
C
C        KPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DSPFA.
C
C        WORK    DOUBLE PRECISION(N)
C                WORK VECTOR.  CONTENTS IGNORED.
C
C        JOB     INTEGER
C                JOB HAS THE DECIMAL EXPANSION  ABC  WHERE
C                   IF  C .NE. 0, THE INVERSE IS COMPUTED,
C                   IF  B .NE. 0, THE DETERMINANT IS COMPUTED,
C                   IF  A .NE. 0, THE INERTIA IS COMPUTED.
C
C                FOR EXAMPLE, JOB = 111  GIVES ALL THREE.
C
C     ON RETURN
C
C        VARIABLES NOT REQUESTED BY JOB ARE NOT USED.
C
C        AP     CONTAINS THE UPPER TRIANGLE OF THE INVERSE OF
C               THE ORIGINAL MATRIX, STORED IN PACKED FORM.
C               THE COLUMNS OF THE UPPER TRIANGLE ARE STORED
C               SEQUENTIALLY IN A ONE-DIMENSIONAL ARRAY.
C
C        DET    DOUBLE PRECISION(2)
C               DETERMINANT OF ORIGINAL MATRIX.
C               DETERMINANT = DET(1) * 10.0**DET(2)
C               WITH 1.0 .LE. DABS(DET(1)) .LT. 10.0
C               OR DET(1) = 0.0.
C
C        INERT  INTEGER(3)
C               THE INERTIA OF THE ORIGINAL MATRIX.
C               INERT(1)  =  NUMBER OF POSITIVE EIGENVALUES.
C               INERT(2)  =  NUMBER OF NEGATIVE EIGENVALUES.
C               INERT(3)  =  NUMBER OF ZERO EIGENVALUES.
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INVERSE IS REQUESTED
C        AND  DSPCO  HAS SET RCOND .EQ. 0.0
C        OR  DSPFA  HAS SET  INFO .NE. 0 .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DCOPY,DDOT,DSWAP
C     FORTRAN DABS,IABS,MOD
C
C     INTERNAL VARIABLES.
C
      DOUBLE PRECISION AKKP1,DDOT,TEMP
      DOUBLE PRECISION TEN,D,T,AK,AKP1
      INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1
      INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP
      LOGICAL NOINV,NODET,NOERT
C
      NOINV = MOD(JOB,10) .EQ. 0
      NODET = MOD(JOB,100)/10 .EQ. 0
      NOERT = MOD(JOB,1000)/100 .EQ. 0
C
      IF (NODET .AND. NOERT) GO TO 140
         IF (NOERT) GO TO 10
            INERT(1) = 0
            INERT(2) = 0
            INERT(3) = 0
   10    CONTINUE
         IF (NODET) GO TO 20
            DET(1) = 1.0D0
            DET(2) = 0.0D0
            TEN = 10.0D0
   20    CONTINUE
         T = 0.0D0
         IK = 0
         DO 130 K = 1, N
            KK = IK + K
            D = AP(KK)
C
C           CHECK IF 1 BY 1
C
            IF (KPVT(K) .GT. 0) GO TO 50
C
C              2 BY 2 BLOCK
C              USE DET (D  S)  =  (D/T * C - T) * T  ,  T = DABS(S)
C                      (S  C)
C              TO AVOID UNDERFLOW/OVERFLOW TROUBLES.
C              TAKE TWO PASSES THROUGH SCALING.  USE  T  FOR FLAG.
C
               IF (T .NE. 0.0D0) GO TO 30
                  IKP1 = IK + K
                  KKP1 = IKP1 + K
                  T = DABS(AP(KKP1))
                  D = (D/T)*AP(KKP1+1) - T
               GO TO 40
   30          CONTINUE
                  D = T
                  T = 0.0D0
   40          CONTINUE
   50       CONTINUE
C
            IF (NOERT) GO TO 60
               IF (D .GT. 0.0D0) INERT(1) = INERT(1) + 1
               IF (D .LT. 0.0D0) INERT(2) = INERT(2) + 1
               IF (D .EQ. 0.0D0) INERT(3) = INERT(3) + 1
   60       CONTINUE
C
            IF (NODET) GO TO 120
               DET(1) = D*DET(1)
               IF (DET(1) .EQ. 0.0D0) GO TO 110
   70             IF (DABS(DET(1)) .GE. 1.0D0) GO TO 80
                     DET(1) = TEN*DET(1)
                     DET(2) = DET(2) - 1.0D0
                  GO TO 70
   80             CONTINUE
   90             IF (DABS(DET(1)) .LT. TEN) GO TO 100
                     DET(1) = DET(1)/TEN
                     DET(2) = DET(2) + 1.0D0
                  GO TO 90
  100             CONTINUE
  110          CONTINUE
  120       CONTINUE
            IK = IK + K
  130    CONTINUE
  140 CONTINUE
C
C     COMPUTE INVERSE(A)
C
      IF (NOINV) GO TO 270
         K = 1
         IK = 0
  150    IF (K .GT. N) GO TO 260
            KM1 = K - 1
            KK = IK + K
            IKP1 = IK + K
            KKP1 = IKP1 + K
            IF (KPVT(K) .LT. 0) GO TO 180
C
C              1 BY 1
C
               AP(KK) = 1.0D0/AP(KK)
               IF (KM1 .LT. 1) GO TO 170
                  CALL DCOPY(KM1,AP(IK+1),1,WORK,1)
                  IJ = 0
                  DO 160 J = 1, KM1
                     JK = IK + J
                     AP(JK) = DDOT(J,AP(IJ+1),1,WORK,1)
                     CALL DAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1)
                     IJ = IJ + J
  160             CONTINUE
                  AP(KK) = AP(KK) + DDOT(KM1,WORK,1,AP(IK+1),1)
  170          CONTINUE
               KSTEP = 1
            GO TO 220
  180       CONTINUE
C
C              2 BY 2
C
               T = DABS(AP(KKP1))
               AK = AP(KK)/T
               AKP1 = AP(KKP1+1)/T
               AKKP1 = AP(KKP1)/T
               D = T*(AK*AKP1 - 1.0D0)
               AP(KK) = AKP1/D
               AP(KKP1+1) = AK/D
               AP(KKP1) = -AKKP1/D
               IF (KM1 .LT. 1) GO TO 210
                  CALL DCOPY(KM1,AP(IKP1+1),1,WORK,1)
                  IJ = 0
                  DO 190 J = 1, KM1
                     JKP1 = IKP1 + J
                     AP(JKP1) = DDOT(J,AP(IJ+1),1,WORK,1)
                     CALL DAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1)
                     IJ = IJ + J
  190             CONTINUE
                  AP(KKP1+1) = AP(KKP1+1)
     *                         + DDOT(KM1,WORK,1,AP(IKP1+1),1)
                  AP(KKP1) = AP(KKP1)
     *                       + DDOT(KM1,AP(IK+1),1,AP(IKP1+1),1)
                  CALL DCOPY(KM1,AP(IK+1),1,WORK,1)
                  IJ = 0
                  DO 200 J = 1, KM1
                     JK = IK + J
                     AP(JK) = DDOT(J,AP(IJ+1),1,WORK,1)
                     CALL DAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1)
                     IJ = IJ + J
  200             CONTINUE
                  AP(KK) = AP(KK) + DDOT(KM1,WORK,1,AP(IK+1),1)
  210          CONTINUE
               KSTEP = 2
  220       CONTINUE
C
C           SWAP
C
            KS = IABS(KPVT(K))
            IF (KS .EQ. K) GO TO 250
               IKS = (KS*(KS - 1))/2
               CALL DSWAP(KS,AP(IKS+1),1,AP(IK+1),1)
               KSJ = IK + KS
               DO 230 JB = KS, K
                  J = K + KS - JB
                  JK = IK + J
                  TEMP = AP(JK)
                  AP(JK) = AP(KSJ)
                  AP(KSJ) = TEMP
                  KSJ = KSJ - (J - 1)
  230          CONTINUE
               IF (KSTEP .EQ. 1) GO TO 240
                  KSKP1 = IKP1 + KS
                  TEMP = AP(KSKP1)
                  AP(KSKP1) = AP(KKP1)
                  AP(KKP1) = TEMP
  240          CONTINUE
  250       CONTINUE
            IK = IK + K
            IF (KSTEP .EQ. 2) IK = IK + K + 1
            K = K + KSTEP
         GO TO 150
  260    CONTINUE
  270 CONTINUE
      RETURN
      END
      SUBROUTINE PCHOL (MO,N,M,A,B,KB,IERR)
C     -----------------
      REAL A(*), B(*), D(2)
      INTEGER ONEJ
C     -----------------
C
C              MATRIX FACTORIZATION
C
      CALL SPPFA (A,N,IERR)
      IF (IERR .NE. 0) RETURN
C
C          SOLUTION OF THE EQUATION AX=B
C
      IF (M .LT. 1) GO TO 20
      ONEJ = 1
      DO 10 J = 1,M
         CALL SPPSL (A,N,B(ONEJ))
   10 ONEJ = ONEJ + KB
C
C         COMPUTATION OF THE INVERSE OF A
C
   20 IF (MO .EQ. 0) CALL SPPDI (A,N,D,1)
      RETURN
      END
      SUBROUTINE SPPFA(AP,N,INFO)
      INTEGER N,INFO
      REAL AP(*)
C
C     SPPFA FACTORS A REAL SYMMETRIC POSITIVE DEFINITE MATRIX
C     STORED IN PACKED FORM.
C
C     SPPFA IS USUALLY CALLED BY SPPCO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR SPPCO) = (1 + 18/N)*(TIME FOR SPPFA) .
C
C     ON ENTRY
C
C        AP      REAL (N*(N+1)/2)
C                THE PACKED FORM OF A SYMMETRIC MATRIX  A .  THE
C                COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY
C                IN A ONE-DIMENSIONAL ARRAY OF LENGTH  N*(N+1)/2 .
C                SEE COMMENTS BELOW FOR DETAILS.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        AP      AN UPPER TRIANGULAR MATRIX  R , STORED IN PACKED
C                FORM, SO THAT  A = TRANS(R)*R .
C
C        INFO    INTEGER
C                = 0  FOR NORMAL RETURN.
C                = K  IF THE LEADING MINOR OF ORDER  K  IS NOT
C                     POSITIVE DEFINITE.
C
C
C     PACKED STORAGE
C
C          THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER
C          TRIANGLE OF A SYMMETRIC MATRIX.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K) = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SDOT
C     FORTRAN SQRT
C
C     INTERNAL VARIABLES
C
      REAL SDOT,T
      REAL S
      INTEGER J,JJ,JM1,K,KJ,KK
C     BEGIN BLOCK WITH ...EXITS TO 40
C
C
         JJ = 0
         DO 30 J = 1, N
            INFO = J
            S = 0.0E0
            JM1 = J - 1
            KJ = JJ
            KK = 0
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               KJ = KJ + 1
               T = AP(KJ) - SDOT(K-1,AP(KK+1),1,AP(JJ+1),1)
               KK = KK + K
               T = T/AP(KK)
               AP(KJ) = T
               S = S + T*T
   10       CONTINUE
   20       CONTINUE
            JJ = JJ + J
            S = AP(JJ) - S
C     ......EXIT
            IF (S .LE. 0.0E0) GO TO 40
            AP(JJ) = SQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END
      SUBROUTINE SPPSL(AP,N,B)
      INTEGER N
      REAL AP(*),B(*)
C
C     SPPSL SOLVES THE REAL SYMMETRIC POSITIVE DEFINITE SYSTEM
C     A * X = B
C     USING THE FACTORS COMPUTED BY SPPCO OR SPPFA.
C
C     ON ENTRY
C
C        AP      REAL (N*(N+1)/2)
C                THE OUTPUT FROM SPPCO OR SPPFA.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        B       REAL(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES
C        SINGULARITY BUT IT IS USUALLY CAUSED BY IMPROPER SUBROUTINE
C        ARGUMENTS.  IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED
C        CORRECTLY AND  INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL SPPCO(AP,N,RCOND,Z,INFO)
C           IF (RCOND IS TOO SMALL .OR. INFO .NE. 0) GO TO ...
C           DO 10 J = 1, P
C              CALL SPPSL(AP,N,C(1,J))
C        10 CONTINUE
C
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SDOT
C
C     INTERNAL VARIABLES
C
      REAL SDOT,T
      INTEGER K,KB,KK
C
      KK = 0
      DO 10 K = 1, N
         T = SDOT(K-1,AP(KK+1),1,B(1),1)
         KK = KK + K
         B(K) = (B(K) - T)/AP(KK)
   10 CONTINUE
      DO 20 KB = 1, N
         K = N + 1 - KB
         B(K) = B(K)/AP(KK)
         KK = KK - K
         T = -B(K)
         CALL SAXPY(K-1,T,AP(KK+1),1,B(1),1)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE SPPDI(AP,N,DET,JOB)
      INTEGER N,JOB
      REAL AP(*)
      REAL DET(2)
C
C     SPPDI COMPUTES THE DETERMINANT AND INVERSE
C     OF A REAL SYMMETRIC POSITIVE DEFINITE MATRIX
C     USING THE FACTORS COMPUTED BY SPPCO OR SPPFA .
C
C     ON ENTRY
C
C        AP      REAL (N*(N+1)/2)
C                THE OUTPUT FROM SPPCO OR SPPFA.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C
C     ON RETURN
C
C        AP      THE UPPER TRIANGULAR HALF OF THE INVERSE .
C
C        DET     REAL(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. DET(1) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF SPOCO OR SPOFA HAS SET INFO .EQ. 0 .
C
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SSCAL
C     FORTRAN MOD
C
C     INTERNAL VARIABLES
C
      REAL T
      REAL S
      INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0E0
         DET(2) = 0.0E0
         S = 10.0E0
         II = 0
         DO 50 I = 1, N
            II = II + I
            DET(1) = AP(II)**2*DET(1)
C        ...EXIT
            IF (DET(1) .EQ. 0.0E0) GO TO 60
   10       IF (DET(1) .GE. 1.0E0) GO TO 20
               DET(1) = S*DET(1)
               DET(2) = DET(2) - 1.0E0
            GO TO 10
   20       CONTINUE
   30       IF (DET(1) .LT. S) GO TO 40
               DET(1) = DET(1)/S
               DET(2) = DET(2) + 1.0E0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(R)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 140
         KK = 0
         DO 100 K = 1, N
            K1 = KK + 1
            KK = KK + K
            AP(KK) = 1.0E0/AP(KK)
            T = -AP(KK)
            CALL SSCAL(K-1,T,AP(K1),1)
            KP1 = K + 1
            J1 = KK + 1
            KJ = KK + K
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = AP(KJ)
               AP(KJ) = 0.0E0
               CALL SAXPY(K,T,AP(K1),1,AP(J1),1)
               J1 = J1 + J
               KJ = KJ + J
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM  INVERSE(R) * TRANS(INVERSE(R))
C
         JJ = 0
         DO 130 J = 1, N
            J1 = JJ + 1
            JJ = JJ + J
            JM1 = J - 1
            K1 = 1
            KJ = J1
            IF (JM1 .LT. 1) GO TO 120
            DO 110 K = 1, JM1
               T = AP(KJ)
               CALL SAXPY(K,T,AP(J1),1,AP(K1),1)
               K1 = K1 + K
               KJ = KJ + 1
  110       CONTINUE
  120       CONTINUE
            T = AP(JJ)
            CALL SSCAL(J,T,AP(J1),1)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END
      SUBROUTINE DPCHOL (MO,N,M,A,B,KB,IERR)
C     -----------------
      DOUBLE PRECISION A(*), B(*), D(2)
      INTEGER ONEJ
C     -----------------
C
C              MATRIX FACTORIZATION
C
      CALL DPPFA (A,N,IERR)
      IF (IERR .NE. 0) RETURN
C
C          SOLUTION OF THE EQUATION AX=B
C
      IF (M .LT. 1) GO TO 20
      ONEJ = 1
      DO 10 J = 1,M
         CALL DPPSL (A,N,B(ONEJ))
   10 ONEJ = ONEJ + KB
C
C         COMPUTATION OF THE INVERSE OF A
C
   20 IF (MO .EQ. 0) CALL DPPDI (A,N,D,1)
      RETURN
      END
      SUBROUTINE DPPFA(AP,N,INFO)
      INTEGER N,INFO
      DOUBLE PRECISION AP(*)
C
C     DPPFA FACTORS A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE
C     MATRIX STORED IN PACKED FORM.
C
C     DPPFA IS USUALLY CALLED BY DPPCO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR DPPCO) = (1 + 18/N)*(TIME FOR DPPFA) .
C
C     ON ENTRY
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                THE PACKED FORM OF A SYMMETRIC MATRIX  A .  THE
C                COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY
C                IN A ONE-DIMENSIONAL ARRAY OF LENGTH  N*(N+1)/2 .
C                SEE COMMENTS BELOW FOR DETAILS.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        AP      AN UPPER TRIANGULAR MATRIX  R , STORED IN PACKED
C                FORM, SO THAT  A = TRANS(R)*R .
C
C        INFO    INTEGER
C                = 0  FOR NORMAL RETURN.
C                = K  IF THE LEADING MINOR OF ORDER  K  IS NOT
C                     POSITIVE DEFINITE.
C
C
C     PACKED STORAGE
C
C          THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER
C          TRIANGLE OF A SYMMETRIC MATRIX.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K) = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DDOT
C     FORTRAN DSQRT
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,T
      DOUBLE PRECISION S
      INTEGER J,JJ,JM1,K,KJ,KK
C     BEGIN BLOCK WITH ...EXITS TO 40
C
C
         JJ = 0
         DO 30 J = 1, N
            INFO = J
            S = 0.0D0
            JM1 = J - 1
            KJ = JJ
            KK = 0
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               KJ = KJ + 1
               T = AP(KJ) - DDOT(K-1,AP(KK+1),1,AP(JJ+1),1)
               KK = KK + K
               T = T/AP(KK)
               AP(KJ) = T
               S = S + T*T
   10       CONTINUE
   20       CONTINUE
            JJ = JJ + J
            S = AP(JJ) - S
C     ......EXIT
            IF (S .LE. 0.0D0) GO TO 40
            AP(JJ) = DSQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END
      SUBROUTINE DPPSL(AP,N,B)
      INTEGER N
      DOUBLE PRECISION AP(*),B(*)
C
C     DPPSL SOLVES THE DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE
C     SYSTEM A * X = B
C     USING THE FACTORS COMPUTED BY DPPCO OR DPPFA.
C
C     ON ENTRY
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                THE OUTPUT FROM DPPCO OR DPPFA.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        B       DOUBLE PRECISION(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES
C        SINGULARITY BUT IT IS USUALLY CAUSED BY IMPROPER SUBROUTINE
C        ARGUMENTS.  IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED
C        CORRECTLY AND  INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL DPPCO(AP,N,RCOND,Z,INFO)
C           IF (RCOND IS TOO SMALL .OR. INFO .NE. 0) GO TO ...
C           DO 10 J = 1, P
C              CALL DPPSL(AP,N,C(1,J))
C        10 CONTINUE
C
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DDOT
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,KK
C
      KK = 0
      DO 10 K = 1, N
         T = DDOT(K-1,AP(KK+1),1,B(1),1)
         KK = KK + K
         B(K) = (B(K) - T)/AP(KK)
   10 CONTINUE
      DO 20 KB = 1, N
         K = N + 1 - KB
         B(K) = B(K)/AP(KK)
         KK = KK - K
         T = -B(K)
         CALL DAXPY(K-1,T,AP(KK+1),1,B(1),1)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE DPPDI(AP,N,DET,JOB)
      INTEGER N,JOB
      DOUBLE PRECISION AP(*)
      DOUBLE PRECISION DET(2)
C
C     DPPDI COMPUTES THE DETERMINANT AND INVERSE
C     OF A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX
C     USING THE FACTORS COMPUTED BY DPPCO OR DPPFA .
C
C     ON ENTRY
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                THE OUTPUT FROM DPPCO OR DPPFA.
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C
C     ON RETURN
C
C        AP      THE UPPER TRIANGULAR HALF OF THE INVERSE .
C
C        DET     DOUBLE PRECISION(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. DET(1) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF DPOCO OR DPOFA HAS SET INFO .EQ. 0 .
C
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL
C     FORTRAN MOD
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      DOUBLE PRECISION S
      INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         S = 10.0D0
         II = 0
         DO 50 I = 1, N
            II = II + I
            DET(1) = AP(II)**2*DET(1)
C        ...EXIT
            IF (DET(1) .EQ. 0.0D0) GO TO 60
   10       IF (DET(1) .GE. 1.0D0) GO TO 20
               DET(1) = S*DET(1)
               DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       IF (DET(1) .LT. S) GO TO 40
               DET(1) = DET(1)/S
               DET(2) = DET(2) + 1.0D0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(R)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 140
         KK = 0
         DO 100 K = 1, N
            K1 = KK + 1
            KK = KK + K
            AP(KK) = 1.0D0/AP(KK)
            T = -AP(KK)
            CALL DSCAL(K-1,T,AP(K1),1)
            KP1 = K + 1
            J1 = KK + 1
            KJ = KK + K
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = AP(KJ)
               AP(KJ) = 0.0D0
               CALL DAXPY(K,T,AP(K1),1,AP(J1),1)
               J1 = J1 + J
               KJ = KJ + J
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM  INVERSE(R) * TRANS(INVERSE(R))
C
         JJ = 0
         DO 130 J = 1, N
            J1 = JJ + 1
            JJ = JJ + J
            JM1 = J - 1
            K1 = 1
            KJ = J1
            IF (JM1 .LT. 1) GO TO 120
            DO 110 K = 1, JM1
               T = AP(KJ)
               CALL DAXPY(K,T,AP(J1),1,AP(K1),1)
               K1 = K1 + K
               KJ = KJ + 1
  110       CONTINUE
  120       CONTINUE
            T = AP(JJ)
            CALL DSCAL(J,T,AP(J1),1)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END
      SUBROUTINE TOPLX (A, B, X, N, G, H, IERR)
C-----------------------------------------------------------------------
C            SOLUTION OF THE TOEPLITZ SYSTEM OF EQUATIONS
C
C               SUM(J = 1,...,N) A(N+I-J)*X(J) = B(I)
C
C     FOR I = 1,...,N.
C-----------------------------------------------------------------------
C     REAL A(2*N - 1)
C----------------------
      REAL A(*), B(N), X(N), G(N), H(N)
C
      IF (A(N) .EQ. 0.0) GO TO 100
      IERR = 0
      X(1) = B(1)/A(N)
      IF (N .EQ. 1) RETURN
      G(1) = A(N - 1)/A(N)
      H(1) = A(N + 1)/A(N)
      MP1 = 1
C
C     COMPUTE NUMERATOR AND DENOMINATOR OF X(M+1)
C
   10 M = MP1
      MP1 = M + 1
      XN = -B(MP1)
      XD = -A(N)
      DO 20 J = 1,M
         L = MP1 - J
         NPL = N + L
         XN = XN + A(NPL)*X(J)
   20    XD = XD + A(NPL)*G(L)
      IF (XD .EQ. 0.0) GO TO 100
      X(MP1) = XN/XD
C
C        COMPUTE X
C
      C = X(MP1)
      DO 30 J = 1,M
         L = MP1 - J
   30    X(J) = X(J) - C*G(L)
      IF (MP1 .EQ. N) RETURN
C
C     COMPUTE NUMERATOR AND DENOMINATOR OF G(M+1) AND H(M+1)
C
      L = N - MP1
      GN = -A(L)
      GD = -A(N)
      L = N + MP1
      HN = -A(L)
      DO 40 J = 1,M
         L = MP1 - J
         NML = N - L
         NPL = N + L
         GN = GN + A(NML)*G(J)
         GD = GD + A(NML)*H(L)
   40    HN = HN + A(NPL)*H(J)
      IF (GD .EQ. 0.0) GO TO 100
      G(MP1) = GN/GD
      H(MP1) = HN/XD
C
C     COMPUTE G AND H
C
      C1 = G(MP1)
      C2 = H(MP1)
      MAX = MP1/2
      K = M
      DO 50 J = 1,MAX
         GJ = G(J)
         GK = G(K)
         HJ = H(J)
         HK = H(K)
         G(J) = GJ - C1*HK
         G(K) = GK - C1*HJ
         H(J) = HJ - C2*GK
         H(K) = HK - C2*GJ
   50    K = K - 1
      GO TO 10
C
C     ERROR RETURN
C
  100 IERR = 1
      RETURN
      END
      SUBROUTINE DTOPLX (A, B, X, N, G, H, IERR)
C-----------------------------------------------------------------------
C            SOLUTION OF THE TOEPLITZ SYSTEM OF EQUATIONS
C
C               SUM(J = 1,...,N) A(N+I-J)*X(J) = B(I)
C
C     FOR I = 1,...,N.
C-----------------------------------------------------------------------
C     DOUBLE PRECISION A(2*N - 1)
C----------------------
      DOUBLE PRECISION A(*), B(N), X(N), G(N), H(N)
      DOUBLE PRECISION C, C1, C2, GD, GJ, GK, GN, HJ, HK, HN, XD, XN
C
      IF (A(N) .EQ. 0.D0) GO TO 100
      IERR = 0
      X(1) = B(1)/A(N)
      IF (N .EQ. 1) RETURN
      G(1) = A(N - 1)/A(N)
      H(1) = A(N + 1)/A(N)
      MP1 = 1
C
C     COMPUTE NUMERATOR AND DENOMINATOR OF X(M+1)
C
   10 M = MP1
      MP1 = M + 1
      XN = -B(MP1)
      XD = -A(N)
      DO 20 J = 1,M
         L = MP1 - J
         NPL = N + L
         XN = XN + A(NPL)*X(J)
   20    XD = XD + A(NPL)*G(L)
      IF (XD .EQ. 0.D0) GO TO 100
      X(MP1) = XN/XD
C
C        COMPUTE X
C
      C = X(MP1)
      DO 30 J = 1,M
         L = MP1 - J
   30    X(J) = X(J) - C*G(L)
      IF (MP1 .EQ. N) RETURN
C
C     COMPUTE NUMERATOR AND DENOMINATOR OF G(M+1) AND H(M+1)
C
      L = N - MP1
      GN = -A(L)
      GD = -A(N)
      L = N + MP1
      HN = -A(L)
      DO 40 J = 1,M
         L = MP1 - J
         NML = N - L
         NPL = N + L
         GN = GN + A(NML)*G(J)
         GD = GD + A(NML)*H(L)
   40    HN = HN + A(NPL)*H(J)
      IF (GD .EQ. 0.D0) GO TO 100
      G(MP1) = GN/GD
      H(MP1) = HN/XD
C
C     COMPUTE G AND H
C
      C1 = G(MP1)
      C2 = H(MP1)
      MAX = MP1/2
      K = M
      DO 50 J = 1,MAX
         GJ = G(J)
         GK = G(K)
         HJ = H(J)
         HK = H(K)
         G(J) = GJ - C1*HK
         G(K) = GK - C1*HJ
         H(J) = HJ - C2*GK
         H(K) = HK - C2*GJ
   50    K = K - 1
      GO TO 10
C
C     ERROR RETURN
C
  100 IERR = 1
      RETURN
      END
      SUBROUTINE CMSLV(MO,N,M,A,KA,B,KB,DET,RCOND,IERR,IPVT,WK)
C-----------------------------------------------------------------------
C     PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING COMPLEX MATRICES
C     AND SOLVING COMPLEX EQUATIONS
C-----------------------------------------------------------------------
      COMPLEX A(KA,N), B(*), DET(2), WK(N)
      REAL RCOND, T
      INTEGER IPVT(N), ONEJ
C
C          MATRIX FACTORIZATION AND COMPUTATION OF RCOND
C
      IERR = 0
      CALL CGECO (A, KA, N, IPVT, RCOND, WK)
      T = 1.0 + RCOND
      IF (T .EQ. 1.0) GO TO 30
C
C                  SOLUTION OF THE EQUATION AX=B
C
      IF (M .LT. 1) GO TO 20
      ONEJ = 1
      DO 10 J = 1,M
         CALL CGESL (A, KA, N, IPVT, B(ONEJ), 0)
         ONEJ = ONEJ + KB
   10 CONTINUE
C
C             CALCULATION OF DET AND THE INVERSE OF A
C
   20 JOB = 10
      IF (MO .EQ. 0) JOB = 11
      CALL CGEDI (A, KA, N, IPVT, DET, WK, JOB)
      RETURN
C
C                  THE PROBLEM CANNOT BE SOLVED
C
   30 IERR = 1
      RETURN
      END
      SUBROUTINE CMSLV1 (MO, N, M, A, KA, B, KB, IERR, IPVT, WK)
C-----------------------------------------------------------------------
C     PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING COMPLEX MATRICES
C     AND SOLVING COMPLEX EQUATIONS
C-----------------------------------------------------------------------
      COMPLEX A(KA,N), B(*), WK(*)
      INTEGER IPVT(N)
      COMPLEX D(2)
      INTEGER ONEJ
C
      IF (N .LT. 1 .OR. KA .LT. N) GO TO 40
      IF (M .LE. 0) GO TO 10
      IF (KB .LT. N) GO TO 40
C
C                      MATRIX FACTORIZATION
C
   10 CALL CGEFA (A, KA, N, IPVT, IERR)
      IF (IERR .NE. 0) RETURN
C
C                 SOLUTION OF THE EQUATION AX = B
C
      IF (M .LE. 0) GO TO 30
      ONEJ = 1
      DO 20 J = 1,M
         CALL CGESL (A, KA, N, IPVT, B(ONEJ), 0)
         ONEJ = ONEJ + KB
   20 CONTINUE
C
C                 CALCULATION OF THE INVERSE OF A
C
   30 IF (MO .EQ. 0) CALL CGEDI (A, KA, N, IPVT, D, WK, 1)
      RETURN
C
C                          ERROR RETURN
C
   40 IERR = -1
      RETURN
      END
      SUBROUTINE CSLVMP(MO, N, A, KA, B, X, WK, IWK, IERR)
C     ******************************************************************
C     SOLUTION OF COMPLEX LINEAR EQUATIONS WITH ITERATIVE IMPROVEMENT
C     ******************************************************************
      COMPLEX A(KA,N), B(N), X(N), WK(*)
      INTEGER IWK(N)
C     -----------------
C     COMPLEX WK(N*N + N)
C     -----------------
      IF (MO .NE. 0) GO TO 10
C
C             COMPUTE THE LU DECOMPOSITION OF A
C
      CALL CMCOPY(N, N, A, KA, WK, N)
      CALL CGEFA(WK, N, N, IWK, IERR)
      IF (IERR .EQ. 0) GO TO 10
      IERR = -IERR
      RETURN
C
C            SOLVE THE SYSTEM OF EQUATIONS AX = B
C
   10 DO 11 I = 1,N
   11 X(I) = B(I)
C
      IR = N*N + 1
      CALL CGESL(WK, N, N, IWK, X, 0)
      CALL CLUIMP(A, KA, N, WK(1), N, IWK, B, X, WK(IR), IERR)
      RETURN
      END
      SUBROUTINE CLUIMP(A, KA, N, Q, KQ, IPVT, B, X, R, IND)
C ----------------------------------------------------------------------
C     PURPOSE
C       GIVEN AN APPROXIMATE SOLUTION X OF A COMPLEX SYSTEM AX = B
C       OBTAINED USING CGECO OR CGEFA. CLUIMP ATTEMPTS TO COMPUTE
C       AN IMPROVED SOLUTION CORRECT TO MACHINE PRECISION.
C
C     PARAMETERS
C
C       A    A COMPLEX ARRAY OF DIMENSION (KA,N) CONTAINING THE
C            MATRIX A OF ORDER N.
C       Q    A COMPLEX ARRAY OF DIMENSION (KQ,N) CONTAINING THE
C            LU DECOMPOSITION OF A PRODUCED BY CGECO OR CGEFA.
C       IPVT AN ARRAY OF DIMENSION N CONTAINING THE PERMUTATION
C            INFORMATION GIVEN BY CGECO OR CGEFA.
C       B    THE RIGHT HAND SIDE OF THE EQUATION AX = B.
C       X    ON INPUT X IS THE APPROXIMATE SOLUTION OF AX = B TO
C            BE IMPROVED. ON OUTPUT X IS THE SOLUTION OBTAINED.
C       R    A COMPLEX ARRAY FOR INTERNAL USE BY THE ROUTINE.
C       IND  VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C            IND = 0 IF IMPROVEMENT OF X IS SUCCESSFUL WITH A
C            GAIN IN ACCURACY OF AT LEAST 50 PER CENT EACH
C            ITERATION. OTHERWISE IND = 1.
C
C ----------------------------------------------------------------------
      COMPLEX A(KA,N), Q(KQ,N), B(N), X(N), R(N)
      INTEGER IPVT(N)
      DOUBLE PRECISION RA, IA, RX, IX, RSUM, ISUM
C
C     ********** EPS IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS
C                THE VALUE U WHERE U IS THE SMALLEST FLOATING POINT
C                NUMBER SUCH THAT 1.0 + U .GT. 1.0.
C
      EPS = SPMPAR(1)
C
      IND = 0
      XNRM = 0.0
      DO 10 I = 1,N
   10 XNRM = XNRM + (REAL(X(I))**2 + AIMAG(X(I))**2)
      IF (XNRM .EQ. 0.0) RETURN
      EPS2 = EPS*EPS
      RATIO = 1.0
C
C                  COMPUTE THE RESIDUAL VECTOR
C
   20 DO 22 I = 1,N
      RSUM = DBLE(REAL(B(I)))
      ISUM = DBLE(AIMAG(B(I)))
        DO 21 J = 1,N
        RA = DBLE(REAL(A(I,J)))
        IA = DBLE(AIMAG(A(I,J)))
        RX = DBLE(REAL(X(J)))
        IX = DBLE(AIMAG(X(J)))
        RSUM = RSUM - RA*RX + IA*IX
   21   ISUM = ISUM - RA*IX - IA*RX
   22 R(I) = CMPLX(SNGL(RSUM),SNGL(ISUM))
C
C                  FIND THE CORRECTION VECTOR
C
      CALL CGESL(Q, KQ, N, IPVT, R, 0)
      RNRM = 0.0
      DO 30 I = 1,N
   30 RNRM = RNRM + (REAL(R(I))**2 + AIMAG(R(I))**2)
      IF (RNRM .LE. EPS2*XNRM) RETURN
C
C                FORM A NEW APPROXIMATE SOLUTION
C
      DO 40 I = 1,N
   40 X(I) = X(I) + R(I)
      XNRM = 0.0
      DO 41 I = 1,N
   41 XNRM = XNRM + (REAL(X(I))**2 + AIMAG(X(I))**2)
C
      IF (XNRM .EQ. 0.0) RETURN
      RAT = RATIO
      RATIO = RNRM/XNRM
      IF (RATIO .LE. 0.25*RAT) GO TO 20
C
      IF (RATIO .GT. AMIN1(RAT,4.0*EPS2)) IND = 1
      RETURN
      END
      SUBROUTINE CGECO(A,LDA,N,IPVT,RCOND,Z)
      INTEGER LDA,N,IPVT(*)
      COMPLEX A(LDA,*),Z(*)
      REAL RCOND
C
C     CGECO FACTORS A COMPLEX MATRIX BY GAUSSIAN ELIMINATION
C     AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C     IF  RCOND  IS NOT NEEDED, CGEFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW CGECO BY CGESL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW CGECO BY CGESL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW CGECO BY CGEDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW CGECO BY CGEDI.
C
C     ON ENTRY
C
C        A       COMPLEX(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   REAL
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       COMPLEX(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     LINPACK CGEFA
C     BLAS CAXPY,CDOTC,CSSCAL,SCASUM
C     FORTRAN ABS,AIMAG,AMAX1,CMPLX,CONJG,REAL
C
C     INTERNAL VARIABLES
C
      COMPLEX CDOTC,EK,T,WK,WKM
      REAL ANORM,S,SCASUM,SM,YNORM
      INTEGER INFO,J,K,KB,KP1,L
C
      COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
      CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2))
C
C     COMPUTE 1-NORM OF A
C
      ANORM = 0.0E0
      DO 10 J = 1, N
         ANORM = AMAX1(ANORM,SCASUM(N,A(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL CGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  CTRANS(A)*Y = E .
C     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(U)*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE CTRANS(U)*W = E
C
      EK = (1.0E0,0.0E0)
      DO 20 J = 1, N
         Z(J) = (0.0E0,0.0E0)
   20 CONTINUE
      DO 100 K = 1, N
         IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
         IF (CABS1(EK-Z(K)) .LE. CABS1(A(K,K))) GO TO 30
            S = CABS1(A(K,K))/CABS1(EK-Z(K))
            CALL CSSCAL(N,S,Z,1)
            EK = CMPLX(S,0.0E0)*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = CABS1(WK)
         SM = CABS1(WKM)
         IF (CABS1(A(K,K)) .EQ. 0.0E0) GO TO 40
            WK = WK/CONJG(A(K,K))
            WKM = WKM/CONJG(A(K,K))
         GO TO 50
   40    CONTINUE
            WK = (1.0E0,0.0E0)
            WKM = (1.0E0,0.0E0)
   50    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 90
            DO 60 J = KP1, N
               SM = SM + CABS1(Z(J)+WKM*CONJG(A(K,J)))
               Z(J) = Z(J) + WK*CONJG(A(K,J))
               S = S + CABS1(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*CONJG(A(K,J))
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
C
C     SOLVE CTRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         IF (K .LT. N) Z(K) = Z(K) + CDOTC(N-K,A(K+1,K),1,Z(K+1),1)
         IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110
            S = 1.0E0/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL CAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130
            S = 1.0E0/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 150
            S = CABS1(A(K,K))/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
         IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
         T = -Z(K)
         CALL CAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END
      SUBROUTINE CGEFA(A,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(*),INFO
      COMPLEX A(LDA,*)
C
C     CGEFA FACTORS A COMPLEX MATRIX BY GAUSSIAN ELIMINATION.
C
C     CGEFA IS USUALLY CALLED BY CGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR CGECO) = (1 + 9/N)*(TIME FOR CGEFA) .
C
C     ON ENTRY
C
C        A       COMPLEX(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT CGESL OR CGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN CGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS CAXPY,CSCAL,ICAMAX
C     FORTRAN ABS,AIMAG,REAL
C
C     INTERNAL VARIABLES
C
      COMPLEX T
      INTEGER ICAMAX,J,K,KP1,L,NM1
C
      COMPLEX ZDUM
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = ICAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (CABS1(A(L,K)) .EQ. 0.0E0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -(1.0E0,0.0E0)/A(K,K)
            CALL CSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL CAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (CABS1(A(N,N)) .EQ. 0.0E0) INFO = N
      RETURN
      END
      SUBROUTINE CGESL(A,LDA,N,IPVT,B,JOB)
      INTEGER LDA,N,IPVT(*),JOB
      COMPLEX A(LDA,*),B(*)
C
C     CGESL SOLVES THE COMPLEX SYSTEM
C     A * X = B  OR  CTRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY CGECO OR CGEFA.
C
C     ON ENTRY
C
C        A       COMPLEX(LDA, N)
C                THE OUTPUT FROM CGECO OR CGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM CGECO OR CGEFA.
C
C        B       COMPLEX(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  CTRANS(A)*X = B  WHERE
C                            CTRANS(A)  IS THE CONJUGATE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF CGECO HAS SET RCOND .GT. 0.0
C        OR CGEFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL CGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL CGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS CAXPY,CDOTC
C     FORTRAN CONJG
C
C     INTERNAL VARIABLES
C
      COMPLEX CDOTC,T
      INTEGER K,KB,L,NM1
C
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL CAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL CAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  CTRANS(A) * X = B
C        FIRST SOLVE  CTRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = CDOTC(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/CONJG(A(K,K))
   60    CONTINUE
C
C        NOW SOLVE CTRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + CDOTC(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE CGEDI(A,LDA,N,IPVT,DET,WORK,JOB)
      INTEGER LDA,N,IPVT(*),JOB
      COMPLEX A(LDA,*),DET(2),WORK(*)
C
C     CGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX
C     USING THE FACTORS COMPUTED BY CGECO OR CGEFA.
C
C     ON ENTRY
C
C        A       COMPLEX(LDA, N)
C                THE OUTPUT FROM CGECO OR CGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM CGECO OR CGEFA.
C
C        WORK    COMPLEX(N)
C                WORK VECTOR.  CONTENTS DESTROYED.
C
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C
C     ON RETURN
C
C        A       INVERSE OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE UNCHANGED.
C
C        DET     COMPLEX(2)
C                DETERMINANT OF ORIGINAL MATRIX IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. CABS1(DET(1)) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF CGECO HAS SET RCOND .GT. 0.0 OR CGEFA HAS SET
C        INFO .EQ. 0 .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS CAXPY,CSCAL,CSWAP
C     FORTRAN ABS,AIMAG,CMPLX,MOD,REAL
C
C     INTERNAL VARIABLES
C
      COMPLEX T
      REAL TEN
      INTEGER I,J,K,KB,KP1,L,NM1
C
      COMPLEX ZDUM
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = (1.0E0,0.0E0)
         DET(2) = (0.0E0,0.0E0)
         TEN = 10.0E0
         DO 50 I = 1, N
            IF (IPVT(I) .NE. I) DET(1) = -DET(1)
            DET(1) = A(I,I)*DET(1)
C        ...EXIT
            IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60
   10       IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20
               DET(1) = CMPLX(TEN,0.0E0)*DET(1)
               DET(2) = DET(2) - (1.0E0,0.0E0)
            GO TO 10
   20       CONTINUE
   30       IF (CABS1(DET(1)) .LT. TEN) GO TO 40
               DET(1) = DET(1)/CMPLX(TEN,0.0E0)
               DET(2) = DET(2) + (1.0E0,0.0E0)
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(U)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 150
         DO 100 K = 1, N
            A(K,K) = (1.0E0,0.0E0)/A(K,K)
            T = -A(K,K)
            CALL CSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = (0.0E0,0.0E0)
               CALL CAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM INVERSE(U)*INVERSE(L)
C
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 140
         DO 130 KB = 1, NM1
            K = N - KB
            KP1 = K + 1
            DO 110 I = KP1, N
               WORK(I) = A(I,K)
               A(I,K) = (0.0E0,0.0E0)
  110       CONTINUE
            DO 120 J = KP1, N
               T = WORK(J)
               CALL CAXPY(N,T,A(1,J),1,A(1,K),1)
  120       CONTINUE
            L = IPVT(K)
            IF (L .NE. K) CALL CSWAP(N,A(1,K),1,A(1,L),1)
  130    CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END
      SUBROUTINE DCMSLV (MO,N,M,AR,AI,KA,BR,BI,KB,IERR,IPVT,WK)
C-----------------------------------------------------------------------
C     PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING DOUBLE PRECISION
C     COMPLEX MATRICES AND SOLVING DOUBLE PRECISION COMPLEX EQUATIONS
C-----------------------------------------------------------------------
      DOUBLE PRECISION AR(KA,N), AI(KA,N), BR(*), BI(*), WK(*)
      INTEGER IPVT(N)
C
      IF (N .LT. 1 .OR. KA .LT. N) GO TO 30
      IF (M .LE. 0) GO TO 10
      IF (KB .LT. N) GO TO 30
C
C                      MATRIX FACTORIZATION
C
   10 CALL DCFACT (AR, AI, KA, N, IPVT, IERR)
      IF (IERR .NE. 0) RETURN
C
C                 SOLUTION OF THE EQUATION AX = B
C
      IF (M .LE. 0) GO TO 20
      CALL DCSOL (N, M, AR, AI, KA, BR, BI, KB, IPVT)
C
C                 CALCULATION OF THE INVERSE OF A
C
   20 IF (MO .EQ. 0) CALL DCMINV (AR, AI, KA, N, IPVT, WK)
      RETURN
C
C                          ERROR RETURN
C
   30 IERR = -1
      RETURN
      END
      SUBROUTINE DCFACT (AR, AI, KA, N, IPVT, IERR)
C-----------------------------------------------------------------------
C     DECOMPOSES A COMPLEX MATRIX BY PARTIAL PIVOT GAUSS ELIMINATION
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C        AR AND AI ARE THE REAL AND IMAGINARY PARTS OF THE MATRIX A
C        TO BE DECOMPOSED.
C
C        KA = DECLARED ROW DIMENSION OF THE ARRAYS AR AND AI
C
C        N  = ORDER OF THE MATRIX A
C
C     OUTPUT ...
C
C        AR AND AI CONTAIN AN UPPER TRIANGULAR MATRIX U AND THE
C        MULTIPLIERS NEEDED TO CONSTRUCT L SO THAT A = L*U .
C
C        IPVT = THE PIVOT VECTOR.
C            IPVT(I) = THE INDEX OF THE K-TH PIVOT ROW (I .LT. N)
C            IPVT(N) = (-1)**(NUMBER OF INTERCHANGES)
C
C        IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C        IERR HAS ONE OF THE FOLLOWING VALUES ...
C            IERR = 0   THE DECOMPOSITION OF A WAS OBTAINED.
C            IERR = K   THE K-TH PIVOT ELEMENT IS 0.
C
C     IF IERR = 0 THEN THE DETERMINANT OF A HAS THE VALUE ...
C        DET(A) = IPVT(N) * A(1,1) * A(2,2) * ... * A(N,N)
C-----------------------------------------------------------------------
      DOUBLE PRECISION AR(KA,N), AI(KA,N)
      INTEGER IPVT(N)
      DOUBLE PRECISION P, PR, PI, T, TR, TI
C
      IERR = 0
      IPVT(N) = 1
      IF (N .EQ. 1) GO TO 50
      NM1 = N - 1
C
      DO 40 K = 1,NM1
         KP1 = K + 1
C
C               SEARCH FOR THE K-TH PIVOT ELEMENT
C
         P = DABS(AR(K,K)) + DABS(AI(K,K))
         L = K
         DO 10 I = KP1,N
            T = DABS(AR(I,K)) + DABS(AI(I,K))
            IF (P .GE. T) GO TO 10
            P = T
            L = I
   10    CONTINUE
         IF (P .EQ. 0.D0) GO TO 100
C
         PR = AR(L,K)
         PI = AI(L,K)
         IPVT(K) = L
         IF (L .EQ. K) GO TO 20
         IPVT(N) = -IPVT(N)
         AR(L,K) = AR(K,K)
         AR(K,K) = PR
         AI(L,K) = AI(K,K)
         AI(K,K) = PI
C
C                    COMPUTE THE MULTIPLIERS
C
   20    CALL CDIVID(1.D0, 0.D0, PR, PI, PR, PI)
         DO 21 I = KP1,N
            TR = AR(I,K)
            TI = AI(I,K)
            AR(I,K) = TR*PR - TI*PI
            AI(I,K) = TR*PI + TI*PR
   21    CONTINUE
C
C              INTERCHANGE AND ELIMINATE BY COLUMNS
C
         DO 31 J = KP1,N
            TR = AR(L,J)
            AR(L,J) = AR(K,J)
            AR(K,J) = TR
            TI = AI(L,J)
            AI(L,J) = AI(K,J)
            AI(K,J) = TI
            IF (DABS(TR) + DABS(TI) .EQ. 0.D0) GO TO 31
            DO 30 I = KP1,N
               AR(I,J) = AR(I,J) - AR(I,K)*TR + AI(I,K)*TI
               AI(I,J) = AI(I,J) - AR(I,K)*TI - AI(I,K)*TR
   30       CONTINUE
   31    CONTINUE
   40 CONTINUE
C
C                  CHECK THE N-TH PIVOT ELEMENT
C
   50 IF (DABS(AR(N,N)) + DABS(AI(N,N)) .EQ. 0.D0) IERR = N
      RETURN
C
C                    K-TH PIVOT ELEMENT IS 0
C
  100 IERR = K
      RETURN
      END
      SUBROUTINE DCSOL (N, M, AR, AI, KA, BR, BI, KB, IPVT)
C-----------------------------------------------------------------------
C     SOLUTION OF THE SYSTEM OF M EQUATIONS A*X = B USING THE
C     DECOMPOSITION OBTAINED BY DCFACT. THIS ROUTINE CANNOT BE
C     USED WHEN DCFACT TERMINATES WITH NONZERO IERR.
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C        AR AND AI CONTAIN THE LU DECOMPOSITION OF THE MATRIX
C        OBTAINED BY DCFACT.
C
C        KA = DECLARED ROW DIMENSION OF THE ARRAYS AR AND AI
C
C        N  = ORDER OF THE MATRIX
C
C        BR AND BI ARE THE REAL AND IMAGINARY PARTS OF THE
C        RIGHT HAND SIDE MATRIX.
C
C        KB = DECLARED ROW DIMENSION OF THE ARRAYS BR AND BI
C
C        M  = NUMBER OF COLUMNS OF B
C
C        IPVT = PIVOT VECTOR OBTAINED FROM DCFACT
C
C     OUTPUT ...
C
C        BR AND BI CONTAIN THE REAL AND IMAGINARY PARTS OF THE
C        SOLUTION X.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION AR(KA,N), AI(KA,N), BR(KB,M), BI(KB,M)
      INTEGER IPVT(N)
      DOUBLE PRECISION PR, PI, TR, TI
C
C                    FORWARD ELIMINATION
C
      IF (N .EQ. 1) GO TO 50
      NM1 = N - 1
      DO 20 K = 1, NM1
         KP1 = K + 1
         L = IPVT(K)
         DO 11 J = 1,M
            TR = BR(L,J)
            BR(L,J) = BR(K,J)
            BR(K,J) = TR
            TI = BI(L,J)
            BI(L,J) = BI(K,J)
            BI(K,J) = TI
            IF (DABS(TR) + DABS(TI) .EQ. 0.D0) GO TO 11
            DO 10 I = KP1, N
               BR(I,J) = BR(I,J) - AR(I,K)*TR + AI(I,K)*TI
               BI(I,J) = BI(I,J) - AR(I,K)*TI - AI(I,K)*TR
   10       CONTINUE
   11    CONTINUE
   20 CONTINUE
C
C                   BACKWARD ELIMINATION
C               FOR THE LAST N - 1 VARIABLES
C
      DO 40 L = 1,NM1
         KM1 = N - L
         K = KM1 + 1
         CALL CDIVID (1.D0, 0.D0, AR(K,K), AI(K,K), PR, PI)
         DO 31 J = 1,M
            TR = BR(K,J)
            TI = BI(K,J)
            BR(K,J) = TR*PR - TI*PI
            BI(K,J) = TR*PI + TI*PR
            TR = BR(K,J)
            TI = BI(K,J)
            DO 30 I = 1, KM1
               BR(I,J) = BR(I,J) - AR(I,K)*TR + AI(I,K)*TI
               BI(I,J) = BI(I,J) - AR(I,K)*TI - AI(I,K)*TR
   30       CONTINUE
   31    CONTINUE
   40 CONTINUE
C
   50 CALL CDIVID (1.D0, 0.D0, AR(1,1), AI(1,1), PR, PI)
      DO 60 J = 1,M
         TR = BR(1,J)
         TI = BI(1,J)
         BR(1,J) = TR*PR - TI*PI
         BI(1,J) = TR*PI + TI*PR
   60 CONTINUE
      RETURN
      END
      SUBROUTINE DCMINV (AR, AI, KA, N, IPVT, TEMP)
C-----------------------------------------------------------------------
C     COMPUTATION OF THE INVERSE OF A MATRIX A USING THE LU
C     DECOMPOSITION OBTAINED BY DCFACT. THIS ROUTINE CANNOT
C     BE USED WHEN DCFACT TERMINATES WITH NONZERO IERR.
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C        AR AND AI CONTAIN THE LU DECOMPOSITION OF THE MATRIX
C        OBTAINED BY DCFACT.
C
C        KA = DECLARED ROW DIMENSION OF THE ARRAYS AR AND AI
C
C        N  = ORDER OF THE MATRIX
C
C        IPVT = PIVOT VECTOR OBTAINED FROM DCFACT
C
C        TEMP = TEMPORARY STORAGE AREA FOR THE SUBROUTINE
C
C     OUTPUT ...
C
C        AR AND AI CONTAIN THE INVERSE OF THE MATRIX.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION AR(KA,N), AI(KA,N), TEMP(2,N)
      INTEGER IPVT(N)
      DOUBLE PRECISION SR, SI, TR, TI
C
      CALL CDIVID (1.D0, 0.D0, AR(N,N), AI(N,N), AR(N,N), AI(N,N))
      IF (N .EQ. 1) RETURN
      NP1 = N + 1
      NM1 = N - 1
C
C                REPLACE U WITH THE INVERSE OF U
C
      DO 20 NMI = 1,NM1
         I = N - NMI
         IP1 = I + 1
         CALL CDIVID (1.D0, 0.D0, AR(I,I), AI(I,I), TR, TI)
         DO 11 JB = 1,NMI
            J = NP1 - JB
            SR = 0.D0
            SI = 0.D0
            DO 10 L = IP1,J
               SR = SR + AR(I,L)*AR(L,J) - AI(I,L)*AI(L,J)
               SI = SI + AR(I,L)*AI(L,J) + AI(I,L)*AR(L,J)
   10       CONTINUE
            AR(I,J) = -SR*TR + SI*TI
            AI(I,J) = -SR*TI - SI*TR
   11    CONTINUE
         AR(I,I) = TR
         AI(I,I) = TI
   20 CONTINUE
C
C                COMPUTE  INVERSE(U)*INVERSE(L)
C
      DO 60 NMK = 1,NM1
         K = N - NMK
         KP1 = K + 1
         DO 30 I = KP1,N
            TEMP(1,I) = AR(I,K)
            TEMP(2,I) = AI(I,K)
            AR(I,K) = 0.D0
            AI(I,K) = 0.D0
   30    CONTINUE
C
         DO 41 J = KP1,N
            TR = TEMP(1,J)
            TI = TEMP(2,J)
            DO 40 I = 1,N
               AR(I,K) = AR(I,K) - AR(I,J)*TR + AI(I,J)*TI
               AI(I,K) = AI(I,K) - AR(I,J)*TI - AI(I,J)*TR
   40       CONTINUE
   41    CONTINUE
C
         L = IPVT(K)
         IF (K .EQ. L) GO TO 60
         DO 50 I = 1,N
            TR = AR(I,K)
            AR(I,K) = AR(I,L)
            AR(I,L) = TR
            TI = AI(I,K)
            AI(I,K) = AI(I,L)
   50       AI(I,L) = TI
   60 CONTINUE
      RETURN
      END
      SUBROUTINE SSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO)
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      REAL X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*)
C
C
C     SSVDC IS A SUBROUTINE TO REDUCE A REAL NXP MATRIX X BY
C     ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM.  THE
C     DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X.  THE
C     COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
C     AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
C
C     ON ENTRY
C
C         X         REAL(LDX,P), WHERE LDX.GE.N.
C                   X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
C                   DECOMPOSITION IS TO BE COMPUTED.  X IS
C                   DESTROYED BY SSVDC.
C
C         LDX       INTEGER.
C                   LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C         N         INTEGER.
C                   N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C         P         INTEGER.
C                   P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C         LDU       INTEGER.
C                   LDU IS THE LEADING DIMENSION OF THE ARRAY U.
C                   (SEE BELOW).
C
C         LDV       INTEGER.
C                   LDV IS THE LEADING DIMENSION OF THE ARRAY V.
C                   (SEE BELOW).
C
C         WORK      REAL(N).
C                   WORK IS A SCRATCH ARRAY.
C
C         JOB       INTEGER.
C                   JOB CONTROLS THE COMPUTATION OF THE SINGULAR
C                   VECTORS.  IT HAS THE DECIMAL EXPANSION AB
C                   WITH THE FOLLOWING MEANING
C
C                        A.EQ.0    DO NOT COMPUTE THE LEFT SINGULAR
C                                  VECTORS.
C                        A.EQ.1    RETURN THE N LEFT SINGULAR VECTORS
C                                  IN U.
C                        A.GE.2    RETURN THE FIRST MIN(N,P) SINGULAR
C                                  VECTORS IN U.
C                        B.EQ.0    DO NOT COMPUTE THE RIGHT SINGULAR
C                                  VECTORS.
C                        B.EQ.1    RETURN THE RIGHT SINGULAR VECTORS
C                                  IN V.
C
C     ON RETURN
C
C         S         REAL(MM), WHERE MM=MIN(N+1,P).
C                   THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
C                   SINGULAR VALUES OF X ARRANGED IN DESCENDING
C                   ORDER OF MAGNITUDE.
C
C         E         REAL(P).
C                   E ORDINARILY CONTAINS ZEROS.  HOWEVER SEE THE
C                   DISCUSSION OF INFO FOR EXCEPTIONS.
C
C         U         REAL(LDU,K), WHERE LDU.GE.N.  IF JOBA.EQ.1 THEN
C                                   K.EQ.N, IF JOBA.GE.2 THEN
C                                   K.EQ.MIN(N,P).
C                   U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS.
C                   U IS NOT REFERENCED IF JOBA.EQ.0.  IF N.LE.P
C                   OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X
C                   IN THE SUBROUTINE CALL.
C
C         V         REAL(LDV,P), WHERE LDV.GE.P.
C                   V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C                   V IS NOT REFERENCED IF JOB.EQ.0.  IF P.LE.N,
C                   THEN V MAY BE IDENTIFIED WITH X IN THE
C                   SUBROUTINE CALL.
C
C         INFO      INTEGER.
C                   THE SINGULAR VALUES (AND THEIR CORRESPONDING
C                   SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
C                   ARE CORRECT (HERE M=MIN(N,P)).  THUS IF
C                   INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR
C                   VECTORS ARE CORRECT.  IN ANY EVENT, THE MATRIX
C                   B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX
C                   WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
C                   ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U)
C                   IS THE TRANSPOSE OF U).  THUS THE SINGULAR
C                   VALUES OF X AND B ARE THE SAME.
C
C     LINPACK. THIS VERSION DATED 03/19/79 .
C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C     ***** USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C     EXTERNAL SROT
C     BLAS SAXPY,SDOT,SSCAL,SSWAP,SNRM2,SROTG
C     FORTRAN ABS,AMAX1,MAX0,MIN0,MOD,SQRT
C
C     INTERNAL VARIABLES
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     *        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
      REAL SDOT,T
      REAL B,C,CS,EL,EMM1,F,G,SNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST,
     *     ZTEST
      LOGICAL WANTU,WANTV
C
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
      MAXIT = 30
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN0(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN0(N-1,P)
      NRT = MAX0(0,MIN0(P-2,N))
      LU = MAX0(NCT,NRT)
      IF (LU .LT. 1) GO TO 170
      DO 160 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 20
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            S(L) = SNRM2(N-L+1,X(L,L),1)
            IF (S(L) .EQ. 0.0E0) GO TO 10
               IF (X(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),X(L,L))
               CALL SSCAL(N-L+1,1.0E0/S(L),X(L,L),1)
               X(L,L) = 1.0E0 + X(L,L)
   10       CONTINUE
            S(L) = -S(L)
   20    CONTINUE
         IF (P .LT. LP1) GO TO 50
         DO 40 J = LP1, P
            IF (L .GT. NCT) GO TO 30
            IF (S(L) .EQ. 0.0E0) GO TO 30
C
C              APPLY THE TRANSFORMATION.
C
               T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
               CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
   30       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            E(J) = X(L,J)
   40    CONTINUE
   50    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 60 I = L, N
               U(I,L) = X(I,L)
   60       CONTINUE
   70    CONTINUE
         IF (L .GT. NRT) GO TO 150
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            E(L) = SNRM2(P-L,E(LP1),1)
            IF (E(L) .EQ. 0.0E0) GO TO 80
               IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1))
               CALL SSCAL(P-L,1.0E0/E(L),E(LP1),1)
               E(LP1) = 1.0E0 + E(LP1)
   80       CONTINUE
            E(L) = -E(L)
            IF (LP1 .GT. N .OR. E(L) .EQ. 0.0E0) GO TO 120
C
C              APPLY THE TRANSFORMATION.
C
               DO 90 I = LP1, N
                  WORK(I) = 0.0E0
   90          CONTINUE
               DO 100 J = LP1, P
                  CALL SAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
  100          CONTINUE
               DO 110 J = LP1, P
                  CALL SAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1)
  110          CONTINUE
  120       CONTINUE
            IF (.NOT.WANTV) GO TO 140
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 130 I = LP1, P
                  V(I,L) = E(I)
  130          CONTINUE
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OF ORDER M.
C
      M = MIN0(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
      IF (N .LT. M) S(M) = 0.0E0
      IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
      E(M) = 0.0E0
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 300
         IF (NCU .LT. NCTP1) GO TO 200
         DO 190 J = NCTP1, NCU
            DO 180 I = 1, N
               U(I,J) = 0.0E0
  180       CONTINUE
            U(J,J) = 1.0E0
  190    CONTINUE
  200    CONTINUE
         IF (NCT .LT. 1) GO TO 290
         DO 280 LL = 1, NCT
            L = NCT - LL + 1
            IF (S(L) .EQ. 0.0E0) GO TO 250
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 220
               DO 210 J = LP1, NCU
                  T = -SDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
                  CALL SAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
  210          CONTINUE
  220          CONTINUE
               CALL SSCAL(N-L+1,-1.0E0,U(L,L),1)
               U(L,L) = 1.0E0 + U(L,L)
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 240
               DO 230 I = 1, LM1
                  U(I,L) = 0.0E0
  230          CONTINUE
  240          CONTINUE
            GO TO 270
  250       CONTINUE
               DO 260 I = 1, N
                  U(I,L) = 0.0E0
  260          CONTINUE
               U(L,L) = 1.0E0
  270       CONTINUE
  280    CONTINUE
  290    CONTINUE
  300 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 350
         DO 340 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 320
            IF (E(L) .EQ. 0.0E0) GO TO 320
               DO 310 J = LP1, P
                  T = -SDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
                  CALL SAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
  310          CONTINUE
  320       CONTINUE
            DO 330 I = 1, P
               V(I,L) = 0.0E0
  330       CONTINUE
            V(L,L) = 1.0E0
  340    CONTINUE
  350 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  360 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C     ...EXIT
         IF (M .EQ. 0) GO TO 620
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 370
            INFO = M
C     ......EXIT
            GO TO 620
  370    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF S(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 390 LL = 1, M
            L = M - LL
C        ...EXIT
            IF (L .EQ. 0) GO TO 400
            TEST = ABS(S(L)) + ABS(S(L+1))
            ZTEST = TEST + ABS(E(L))
            IF (ZTEST .NE. TEST) GO TO 380
               E(L) = 0.0E0
C        ......EXIT
               GO TO 400
  380       CONTINUE
  390    CONTINUE
  400    CONTINUE
         IF (L .NE. M - 1) GO TO 410
            KASE = 4
         GO TO 480
  410    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 430 LLS = LP1, MP1
               LS = M - LLS + LP1
C           ...EXIT
               IF (LS .EQ. L) GO TO 440
               TEST = 0.0E0
               IF (LS .NE. M) TEST = TEST + ABS(E(LS))
               IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1))
               ZTEST = TEST + ABS(S(LS))
               IF (ZTEST .NE. TEST) GO TO 420
                  S(LS) = 0.0E0
C           ......EXIT
                  GO TO 440
  420          CONTINUE
  430       CONTINUE
  440       CONTINUE
            IF (LS .NE. L) GO TO 450
               KASE = 3
            GO TO 470
  450       CONTINUE
            IF (LS .NE. M) GO TO 460
               KASE = 1
            GO TO 470
  460       CONTINUE
               KASE = 2
               L = LS
  470       CONTINUE
  480    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (490,520,540,570), KASE
C
C        DEFLATE NEGLIGIBLE S(M).
C
  490    CONTINUE
            MM1 = M - 1
            F = E(M-1)
            E(M-1) = 0.0E0
            DO 510 KK = L, MM1
               K = MM1 - KK + L
               T1 = S(K)
               CALL SROTG(T1,F,CS,SN)
               S(K) = T1
               IF (K .EQ. L) GO TO 500
                  F = -SN*E(K-1)
                  E(K-1) = CS*E(K-1)
  500          CONTINUE
               IF (WANTV) CALL SROT(P,V(1,K),1,V(1,M),1,CS,SN)
  510       CONTINUE
         GO TO 610
C
C        SPLIT AT NEGLIGIBLE S(L).
C
  520    CONTINUE
            F = E(L-1)
            E(L-1) = 0.0E0
            DO 530 K = L, M
               T1 = S(K)
               CALL SROTG(T1,F,CS,SN)
               S(K) = T1
               F = -SN*E(K)
               E(K) = CS*E(K)
               IF (WANTU) CALL SROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
  530       CONTINUE
         GO TO 610
C
C        PERFORM ONE QR STEP.
C
  540    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = AMAX1(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)),
     *                    ABS(E(L)))
            SM = S(M)/SCALE
            SMM1 = S(M-1)/SCALE
            EMM1 = E(M-1)/SCALE
            SL = S(L)/SCALE
            EL = E(L)/SCALE
            B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0
            C = (SM*EMM1)**2
            SHIFT = 0.0E0
            IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 550
               SHIFT = SQRT(B**2+C)
               IF (B .LT. 0.0E0) SHIFT = -SHIFT
               SHIFT = C/(B + SHIFT)
  550       CONTINUE
            F = (SL + SM)*(SL - SM) - SHIFT
            G = SL*EL
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 560 K = L, MM1
               CALL SROTG(F,G,CS,SN)
               IF (K .NE. L) E(K-1) = F
               F = CS*S(K) + SN*E(K)
               E(K) = CS*E(K) - SN*S(K)
               G = SN*S(K+1)
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL SROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
               CALL SROTG(F,G,CS,SN)
               S(K) = F
               F = CS*E(K) + SN*S(K+1)
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*E(K+1)
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K .LT. N)
     *            CALL SROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
  560       CONTINUE
            E(M-1) = F
            ITER = ITER + 1
         GO TO 610
C
C        CONVERGENCE.
C
  570    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE.
C
            IF (S(L) .GE. 0.0E0) GO TO 580
               S(L) = -S(L)
               IF (WANTV) CALL SSCAL(P,-1.0E0,V(1,L),1)
  580       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  590       IF (L .EQ. MM) GO TO 600
C           ...EXIT
               IF (S(L) .GE. S(L+1)) GO TO 600
               T = S(L)
               S(L) = S(L+1)
               S(L+1) = T
               IF (WANTV .AND. L .LT. P)
     *            CALL SSWAP(P,V(1,L),1,V(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     *            CALL SSWAP(N,U(1,L),1,U(1,L+1),1)
               L = L + 1
            GO TO 590
  600       CONTINUE
            ITER = 0
            M = M - 1
  610    CONTINUE
      GO TO 360
  620 CONTINUE
      RETURN
      END
      SUBROUTINE DSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO)
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      DOUBLE PRECISION X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*)
C
C
C     DSVDC IS A SUBROUTINE TO REDUCE A DOUBLE PRECISION NXP MATRIX X
C     BY ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM.  THE
C     DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X.  THE
C     COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
C     AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
C
C     ON ENTRY
C
C         X         DOUBLE PRECISION(LDX,P), WHERE LDX.GE.N.
C                   X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
C                   DECOMPOSITION IS TO BE COMPUTED.  X IS
C                   DESTROYED BY DSVDC.
C
C         LDX       INTEGER.
C                   LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C         N         INTEGER.
C                   N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C         P         INTEGER.
C                   P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C         LDU       INTEGER.
C                   LDU IS THE LEADING DIMENSION OF THE ARRAY U.
C                   (SEE BELOW).
C
C         LDV       INTEGER.
C                   LDV IS THE LEADING DIMENSION OF THE ARRAY V.
C                   (SEE BELOW).
C
C         WORK      DOUBLE PRECISION(N).
C                   WORK IS A SCRATCH ARRAY.
C
C         JOB       INTEGER.
C                   JOB CONTROLS THE COMPUTATION OF THE SINGULAR
C                   VECTORS.  IT HAS THE DECIMAL EXPANSION AB
C                   WITH THE FOLLOWING MEANING
C
C                        A.EQ.0    DO NOT COMPUTE THE LEFT SINGULAR
C                                  VECTORS.
C                        A.EQ.1    RETURN THE N LEFT SINGULAR VECTORS
C                                  IN U.
C                        A.GE.2    RETURN THE FIRST MIN(N,P) SINGULAR
C                                  VECTORS IN U.
C                        B.EQ.0    DO NOT COMPUTE THE RIGHT SINGULAR
C                                  VECTORS.
C                        B.EQ.1    RETURN THE RIGHT SINGULAR VECTORS
C                                  IN V.
C
C     ON RETURN
C
C         S         DOUBLE PRECISION(MM), WHERE MM=MIN(N+1,P).
C                   THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
C                   SINGULAR VALUES OF X ARRANGED IN DESCENDING
C                   ORDER OF MAGNITUDE.
C
C         E         DOUBLE PRECISION(P).
C                   E ORDINARILY CONTAINS ZEROS.  HOWEVER SEE THE
C                   DISCUSSION OF INFO FOR EXCEPTIONS.
C
C         U         DOUBLE PRECISION(LDU,K), WHERE LDU.GE.N.  IF
C                                   JOBA.EQ.1 THEN K.EQ.N, IF JOBA.GE.2
C                                   THEN K.EQ.MIN(N,P).
C                   U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS.
C                   U IS NOT REFERENCED IF JOBA.EQ.0.  IF N.LE.P
C                   OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X
C                   IN THE SUBROUTINE CALL.
C
C         V         DOUBLE PRECISION(LDV,P), WHERE LDV.GE.P.
C                   V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C                   V IS NOT REFERENCED IF JOB.EQ.0.  IF P.LE.N,
C                   THEN V MAY BE IDENTIFIED WITH X IN THE
C                   SUBROUTINE CALL.
C
C         INFO      INTEGER.
C                   THE SINGULAR VALUES (AND THEIR CORRESPONDING
C                   SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
C                   ARE CORRECT (HERE M=MIN(N,P)).  THUS IF
C                   INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR
C                   VECTORS ARE CORRECT.  IN ANY EVENT, THE MATRIX
C                   B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX
C                   WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
C                   ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U)
C                   IS THE TRANSPOSE OF U).  THUS THE SINGULAR
C                   VALUES OF X AND B ARE THE SAME.
C
C     LINPACK. THIS VERSION DATED 03/19/79 .
C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C     DSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C     EXTERNAL DROT
C     BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2,DROTG
C     FORTRAN DABS,DMAX1,MAX0,MIN0,MOD,DSQRT
C
C     INTERNAL VARIABLES
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     *        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
      DOUBLE PRECISION DDOT,T
      DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,DNRM2,SCALE,SHIFT,SL,SM,SN,
     *                 SMM1,T1,TEST,ZTEST
      LOGICAL WANTU,WANTV
C
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
      MAXIT = 30
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN0(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN0(N-1,P)
      NRT = MAX0(0,MIN0(P-2,N))
      LU = MAX0(NCT,NRT)
      IF (LU .LT. 1) GO TO 170
      DO 160 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 20
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            S(L) = DNRM2(N-L+1,X(L,L),1)
            IF (S(L) .EQ. 0.0D0) GO TO 10
               IF (X(L,L) .NE. 0.0D0) S(L) = DSIGN(S(L),X(L,L))
               CALL DSCAL(N-L+1,1.0D0/S(L),X(L,L),1)
               X(L,L) = 1.0D0 + X(L,L)
   10       CONTINUE
            S(L) = -S(L)
   20    CONTINUE
         IF (P .LT. LP1) GO TO 50
         DO 40 J = LP1, P
            IF (L .GT. NCT) GO TO 30
            IF (S(L) .EQ. 0.0D0) GO TO 30
C
C              APPLY THE TRANSFORMATION.
C
               T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
               CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
   30       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            E(J) = X(L,J)
   40    CONTINUE
   50    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 60 I = L, N
               U(I,L) = X(I,L)
   60       CONTINUE
   70    CONTINUE
         IF (L .GT. NRT) GO TO 150
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            E(L) = DNRM2(P-L,E(LP1),1)
            IF (E(L) .EQ. 0.0D0) GO TO 80
               IF (E(LP1) .NE. 0.0D0) E(L) = DSIGN(E(L),E(LP1))
               CALL DSCAL(P-L,1.0D0/E(L),E(LP1),1)
               E(LP1) = 1.0D0 + E(LP1)
   80       CONTINUE
            E(L) = -E(L)
            IF (LP1 .GT. N .OR. E(L) .EQ. 0.0D0) GO TO 120
C
C              APPLY THE TRANSFORMATION.
C
               DO 90 I = LP1, N
                  WORK(I) = 0.0D0
   90          CONTINUE
               DO 100 J = LP1, P
                  CALL DAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
  100          CONTINUE
               DO 110 J = LP1, P
                  CALL DAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1)
  110          CONTINUE
  120       CONTINUE
            IF (.NOT.WANTV) GO TO 140
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 130 I = LP1, P
                  V(I,L) = E(I)
  130          CONTINUE
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OF ORDER M.
C
      M = MIN0(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
      IF (N .LT. M) S(M) = 0.0D0
      IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
      E(M) = 0.0D0
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 300
         IF (NCU .LT. NCTP1) GO TO 200
         DO 190 J = NCTP1, NCU
            DO 180 I = 1, N
               U(I,J) = 0.0D0
  180       CONTINUE
            U(J,J) = 1.0D0
  190    CONTINUE
  200    CONTINUE
         IF (NCT .LT. 1) GO TO 290
         DO 280 LL = 1, NCT
            L = NCT - LL + 1
            IF (S(L) .EQ. 0.0D0) GO TO 250
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 220
               DO 210 J = LP1, NCU
                  T = -DDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
                  CALL DAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
  210          CONTINUE
  220          CONTINUE
               CALL DSCAL(N-L+1,-1.0D0,U(L,L),1)
               U(L,L) = 1.0D0 + U(L,L)
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 240
               DO 230 I = 1, LM1
                  U(I,L) = 0.0D0
  230          CONTINUE
  240          CONTINUE
            GO TO 270
  250       CONTINUE
               DO 260 I = 1, N
                  U(I,L) = 0.0D0
  260          CONTINUE
               U(L,L) = 1.0D0
  270       CONTINUE
  280    CONTINUE
  290    CONTINUE
  300 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 350
         DO 340 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 320
            IF (E(L) .EQ. 0.0D0) GO TO 320
               DO 310 J = LP1, P
                  T = -DDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
                  CALL DAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
  310          CONTINUE
  320       CONTINUE
            DO 330 I = 1, P
               V(I,L) = 0.0D0
  330       CONTINUE
            V(L,L) = 1.0D0
  340    CONTINUE
  350 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  360 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C     ...EXIT
         IF (M .EQ. 0) GO TO 620
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 370
            INFO = M
C     ......EXIT
            GO TO 620
  370    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF S(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 390 LL = 1, M
            L = M - LL
C        ...EXIT
            IF (L .EQ. 0) GO TO 400
            TEST = DABS(S(L)) + DABS(S(L+1))
            ZTEST = TEST + DABS(E(L))
            IF (ZTEST .NE. TEST) GO TO 380
               E(L) = 0.0D0
C        ......EXIT
               GO TO 400
  380       CONTINUE
  390    CONTINUE
  400    CONTINUE
         IF (L .NE. M - 1) GO TO 410
            KASE = 4
         GO TO 480
  410    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 430 LLS = LP1, MP1
               LS = M - LLS + LP1
C           ...EXIT
               IF (LS .EQ. L) GO TO 440
               TEST = 0.0D0
               IF (LS .NE. M) TEST = TEST + DABS(E(LS))
               IF (LS .NE. L + 1) TEST = TEST + DABS(E(LS-1))
               ZTEST = TEST + DABS(S(LS))
               IF (ZTEST .NE. TEST) GO TO 420
                  S(LS) = 0.0D0
C           ......EXIT
                  GO TO 440
  420          CONTINUE
  430       CONTINUE
  440       CONTINUE
            IF (LS .NE. L) GO TO 450
               KASE = 3
            GO TO 470
  450       CONTINUE
            IF (LS .NE. M) GO TO 460
               KASE = 1
            GO TO 470
  460       CONTINUE
               KASE = 2
               L = LS
  470       CONTINUE
  480    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (490,520,540,570), KASE
C
C        DEFLATE NEGLIGIBLE S(M).
C
  490    CONTINUE
            MM1 = M - 1
            F = E(M-1)
            E(M-1) = 0.0D0
            DO 510 KK = L, MM1
               K = MM1 - KK + L
               T1 = S(K)
               CALL DROTG(T1,F,CS,SN)
               S(K) = T1
               IF (K .EQ. L) GO TO 500
                  F = -SN*E(K-1)
                  E(K-1) = CS*E(K-1)
  500          CONTINUE
               IF (WANTV) CALL DROT(P,V(1,K),1,V(1,M),1,CS,SN)
  510       CONTINUE
         GO TO 610
C
C        SPLIT AT NEGLIGIBLE S(L).
C
  520    CONTINUE
            F = E(L-1)
            E(L-1) = 0.0D0
            DO 530 K = L, M
               T1 = S(K)
               CALL DROTG(T1,F,CS,SN)
               S(K) = T1
               F = -SN*E(K)
               E(K) = CS*E(K)
               IF (WANTU) CALL DROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
  530       CONTINUE
         GO TO 610
C
C        PERFORM ONE QR STEP.
C
  540    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = DMAX1(DABS(S(M)),DABS(S(M-1)),DABS(E(M-1)),
     *                    DABS(S(L)),DABS(E(L)))
            SM = S(M)/SCALE
            SMM1 = S(M-1)/SCALE
            EMM1 = E(M-1)/SCALE
            SL = S(L)/SCALE
            EL = E(L)/SCALE
            B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0
            C = (SM*EMM1)**2
            SHIFT = 0.0D0
            IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 550
               SHIFT = DSQRT(B**2+C)
               IF (B .LT. 0.0D0) SHIFT = -SHIFT
               SHIFT = C/(B + SHIFT)
  550       CONTINUE
            F = (SL + SM)*(SL - SM) - SHIFT
            G = SL*EL
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 560 K = L, MM1
               CALL DROTG(F,G,CS,SN)
               IF (K .NE. L) E(K-1) = F
               F = CS*S(K) + SN*E(K)
               E(K) = CS*E(K) - SN*S(K)
               G = SN*S(K+1)
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL DROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
               CALL DROTG(F,G,CS,SN)
               S(K) = F
               F = CS*E(K) + SN*S(K+1)
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*E(K+1)
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K .LT. N)
     *            CALL DROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
  560       CONTINUE
            E(M-1) = F
            ITER = ITER + 1
         GO TO 610
C
C        CONVERGENCE.
C
  570    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE.
C
            IF (S(L) .GE. 0.0D0) GO TO 580
               S(L) = -S(L)
               IF (WANTV) CALL DSCAL(P,-1.0D0,V(1,L),1)
  580       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  590       IF (L .EQ. MM) GO TO 600
C           ...EXIT
               IF (S(L) .GE. S(L+1)) GO TO 600
               T = S(L)
               S(L) = S(L+1)
               S(L+1) = T
               IF (WANTV .AND. L .LT. P)
     *            CALL DSWAP(P,V(1,L),1,V(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     *            CALL DSWAP(N,U(1,L),1,U(1,L+1),1)
               L = L + 1
            GO TO 590
  600       CONTINUE
            ITER = 0
            M = M - 1
  610    CONTINUE
      GO TO 360
  620 CONTINUE
      RETURN
      END
      SUBROUTINE CSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO)
      INTEGER LDX,N,P,LDU,LDV,JOB,INFO
      COMPLEX X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*)
C
C
C     CSVDC IS A SUBROUTINE TO REDUCE A COMPLEX NXP MATRIX X BY
C     UNITARY TRANSFORMATIONS U AND V TO DIAGONAL FORM.  THE
C     DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X.  THE
C     COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS,
C     AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS.
C
C     ON ENTRY
C
C         X         COMPLEX(LDX,P), WHERE LDX.GE.N.
C                   X CONTAINS THE MATRIX WHOSE SINGULAR VALUE
C                   DECOMPOSITION IS TO BE COMPUTED.  X IS
C                   DESTROYED BY CSVDC.
C
C         LDX       INTEGER.
C                   LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C         N         INTEGER.
C                   N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C         P         INTEGER.
C                   P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C         LDU       INTEGER.
C                   LDU IS THE LEADING DIMENSION OF THE ARRAY U
C                   (SEE BELOW).
C
C         LDV       INTEGER.
C                   LDV IS THE LEADING DIMENSION OF THE ARRAY V
C                   (SEE BELOW).
C
C         WORK      COMPLEX(N).
C                   WORK IS A SCRATCH ARRAY.
C
C         JOB       INTEGER.
C                   JOB CONTROLS THE COMPUTATION OF THE SINGULAR
C                   VECTORS.  IT HAS THE DECIMAL EXPANSION AB
C                   WITH THE FOLLOWING MEANING
C
C                        A.EQ.0    DO NOT COMPUTE THE LEFT SINGULAR
C                                  VECTORS.
C                        A.EQ.1    RETURN THE N LEFT SINGULAR VECTORS
C                                  IN U.
C                        A.GE.2    RETURNS THE FIRST MIN(N,P)
C                                  LEFT SINGULAR VECTORS IN U.
C                        B.EQ.0    DO NOT COMPUTE THE RIGHT SINGULAR
C                                  VECTORS.
C                        B.EQ.1    RETURN THE RIGHT SINGULAR VECTORS
C                                  IN V.
C
C     ON RETURN
C
C         S         COMPLEX(MM), WHERE MM=MIN(N+1,P).
C                   THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE
C                   SINGULAR VALUES OF X ARRANGED IN DESCENDING
C                   ORDER OF MAGNITUDE.
C
C         E         COMPLEX(P).
C                   E ORDINARILY CONTAINS ZEROS.  HOWEVER SEE THE
C                   DISCUSSION OF INFO FOR EXCEPTIONS.
C
C         U         COMPLEX(LDU,K), WHERE LDU.GE.N.  IF JOBA.EQ.1 THEN
C                                   K.EQ.N, IF JOBA.GE.2 THEN
C                                   K.EQ.MIN(N,P).
C                   U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS.
C                   U IS NOT REFERENCED IF JOBA.EQ.0.  IF N.LE.P
C                   OR IF JOBA.GT.2, THEN U MAY BE IDENTIFIED WITH X
C                   IN THE SUBROUTINE CALL.
C
C         V         COMPLEX(LDV,P), WHERE LDV.GE.P.
C                   V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS.
C                   V IS NOT REFERENCED IF JOBB.EQ.0.  IF P.LE.N,
C                   THEN V MAY BE IDENTIFIED WHTH X IN THE
C                   SUBROUTINE CALL.
C
C         INFO      INTEGER.
C                   THE SINGULAR VALUES (AND THEIR CORRESPONDING
C                   SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M)
C                   ARE CORRECT (HERE M=MIN(N,P)).  THUS IF
C                   INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR
C                   VECTORS ARE CORRECT.  IN ANY EVENT, THE MATRIX
C                   B = CTRANS(U)*X*V IS THE BIDIAGONAL MATRIX
C                   WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE
C                   ELEMENTS OF E ON ITS SUPER-DIAGONAL (CTRANS(U)
C                   IS THE CONJUGATE-TRANSPOSE OF U).  THUS THE
C                   SINGULAR VALUES OF X AND B ARE THE SAME.
C
C     LINPACK. THIS VERSION DATED 03/19/79 .
C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C     CSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C     EXTERNAL CSROT
C     BLAS CAXPY,CDOTC,CSCAL,CSWAP,SCNRM2,SROTG
C     FORTRAN ABS,AIMAG,AMAX1,CABS,CMPLX
C     FORTRAN CONJG,MAX0,MIN0,MOD,REAL,SQRT
C
C     INTERNAL VARIABLES
C
      INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT,
     *        MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1
      COMPLEX CDOTC,T,R
      REAL B,C,CS,EL,EMM1,F,G,SCNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST,
     *     ZTEST
      LOGICAL WANTU,WANTV
C
      COMPLEX CSIGN,ZDUM,ZDUM1,ZDUM2
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
      CSIGN(ZDUM1,ZDUM2) = CABS(ZDUM1)*(ZDUM2/CABS(ZDUM2))
C
C     SET THE MAXIMUM NUMBER OF ITERATIONS.
C
      MAXIT = 30
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      WANTU = .FALSE.
      WANTV = .FALSE.
      JOBU = MOD(JOB,100)/10
      NCU = N
      IF (JOBU .GT. 1) NCU = MIN0(N,P)
      IF (JOBU .NE. 0) WANTU = .TRUE.
      IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE.
C
C     REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS
C     IN S AND THE SUPER-DIAGONAL ELEMENTS IN E.
C
      INFO = 0
      NCT = MIN0(N-1,P)
      NRT = MAX0(0,MIN0(P-2,N))
      LU = MAX0(NCT,NRT)
      IF (LU .LT. 1) GO TO 170
      DO 160 L = 1, LU
         LP1 = L + 1
         IF (L .GT. NCT) GO TO 20
C
C           COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND
C           PLACE THE L-TH DIAGONAL IN S(L).
C
            S(L) = CMPLX(SCNRM2(N-L+1,X(L,L),1),0.0E0)
            IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 10
               IF (CABS1(X(L,L)) .NE. 0.0E0) S(L) = CSIGN(S(L),X(L,L))
               CALL CSCAL(N-L+1,1.0E0/S(L),X(L,L),1)
               X(L,L) = (1.0E0,0.0E0) + X(L,L)
   10       CONTINUE
            S(L) = -S(L)
   20    CONTINUE
         IF (P .LT. LP1) GO TO 50
         DO 40 J = LP1, P
            IF (L .GT. NCT) GO TO 30
            IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 30
C
C              APPLY THE TRANSFORMATION.
C
               T = -CDOTC(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
               CALL CAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
   30       CONTINUE
C
C           PLACE THE L-TH ROW OF X INTO  E FOR THE
C           SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION.
C
            E(J) = CONJG(X(L,J))
   40    CONTINUE
   50    CONTINUE
         IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70
C
C           PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK
C           MULTIPLICATION.
C
            DO 60 I = L, N
               U(I,L) = X(I,L)
   60       CONTINUE
   70    CONTINUE
         IF (L .GT. NRT) GO TO 150
C
C           COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE
C           L-TH SUPER-DIAGONAL IN E(L).
C
            E(L) = CMPLX(SCNRM2(P-L,E(LP1),1),0.0E0)
            IF (CABS1(E(L)) .EQ. 0.0E0) GO TO 80
               IF (CABS1(E(LP1)) .NE. 0.0E0) E(L) = CSIGN(E(L),E(LP1))
               CALL CSCAL(P-L,1.0E0/E(L),E(LP1),1)
               E(LP1) = (1.0E0,0.0E0) + E(LP1)
   80       CONTINUE
            E(L) = -CONJG(E(L))
            IF (LP1 .GT. N .OR. CABS1(E(L)) .EQ. 0.0E0) GO TO 120
C
C              APPLY THE TRANSFORMATION.
C
               DO 90 I = LP1, N
                  WORK(I) = (0.0E0,0.0E0)
   90          CONTINUE
               DO 100 J = LP1, P
                  CALL CAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1)
  100          CONTINUE
               DO 110 J = LP1, P
                  CALL CAXPY(N-L,CONJG(-E(J)/E(LP1)),WORK(LP1),1,
     *                       X(LP1,J),1)
  110          CONTINUE
  120       CONTINUE
            IF (.NOT.WANTV) GO TO 140
C
C              PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT
C              BACK MULTIPLICATION.
C
               DO 130 I = LP1, P
                  V(I,L) = E(I)
  130          CONTINUE
  140       CONTINUE
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
C
C     SET UP THE FINAL BIDIAGONAL MATRIX OF ORDER M.
C
      M = MIN0(P,N+1)
      NCTP1 = NCT + 1
      NRTP1 = NRT + 1
      IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1)
      IF (N .LT. M) S(M) = (0.0E0,0.0E0)
      IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M)
      E(M) = (0.0E0,0.0E0)
C
C     IF REQUIRED, GENERATE U.
C
      IF (.NOT.WANTU) GO TO 300
         IF (NCU .LT. NCTP1) GO TO 200
         DO 190 J = NCTP1, NCU
            DO 180 I = 1, N
               U(I,J) = (0.0E0,0.0E0)
  180       CONTINUE
            U(J,J) = (1.0E0,0.0E0)
  190    CONTINUE
  200    CONTINUE
         IF (NCT .LT. 1) GO TO 290
         DO 280 LL = 1, NCT
            L = NCT - LL + 1
            IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 250
               LP1 = L + 1
               IF (NCU .LT. LP1) GO TO 220
               DO 210 J = LP1, NCU
                  T = -CDOTC(N-L+1,U(L,L),1,U(L,J),1)/U(L,L)
                  CALL CAXPY(N-L+1,T,U(L,L),1,U(L,J),1)
  210          CONTINUE
  220          CONTINUE
               CALL CSCAL(N-L+1,(-1.0E0,0.0E0),U(L,L),1)
               U(L,L) = (1.0E0,0.0E0) + U(L,L)
               LM1 = L - 1
               IF (LM1 .LT. 1) GO TO 240
               DO 230 I = 1, LM1
                  U(I,L) = (0.0E0,0.0E0)
  230          CONTINUE
  240          CONTINUE
            GO TO 270
  250       CONTINUE
               DO 260 I = 1, N
                  U(I,L) = (0.0E0,0.0E0)
  260          CONTINUE
               U(L,L) = (1.0E0,0.0E0)
  270       CONTINUE
  280    CONTINUE
  290    CONTINUE
  300 CONTINUE
C
C     IF IT IS REQUIRED, GENERATE V.
C
      IF (.NOT.WANTV) GO TO 350
         DO 340 LL = 1, P
            L = P - LL + 1
            LP1 = L + 1
            IF (L .GT. NRT) GO TO 320
            IF (CABS1(E(L)) .EQ. 0.0E0) GO TO 320
               DO 310 J = LP1, P
                  T = -CDOTC(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L)
                  CALL CAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1)
  310          CONTINUE
  320       CONTINUE
            DO 330 I = 1, P
               V(I,L) = (0.0E0,0.0E0)
  330       CONTINUE
            V(L,L) = (1.0E0,0.0E0)
  340    CONTINUE
  350 CONTINUE
C
C     TRANSFORM S AND E SO THAT THEY ARE REAL.
C
      DO 380 I = 1, M
         IF (CABS1(S(I)) .EQ. 0.0E0) GO TO 360
            T = CMPLX(CABS(S(I)),0.0E0)
            R = S(I)/T
            S(I) = T
            IF (I .LT. M) E(I) = E(I)/R
            IF (WANTU) CALL CSCAL(N,R,U(1,I),1)
  360    CONTINUE
C     ...EXIT
         IF (I .EQ. M) GO TO 390
         IF (CABS1(E(I)) .EQ. 0.0E0) GO TO 370
            T = CMPLX(CABS(E(I)),0.0E0)
            R = T/E(I)
            E(I) = T
            S(I+1) = S(I+1)*R
            IF (WANTV) CALL CSCAL(P,R,V(1,I+1),1)
  370    CONTINUE
  380 CONTINUE
  390 CONTINUE
C
C     MAIN ITERATION LOOP FOR THE SINGULAR VALUES.
C
      MM = M
      ITER = 0
  400 CONTINUE
C
C        QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND.
C
C     ...EXIT
         IF (M .EQ. 0) GO TO 660
C
C        IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET
C        FLAG AND RETURN.
C
         IF (ITER .LT. MAXIT) GO TO 410
            INFO = M
C     ......EXIT
            GO TO 660
  410    CONTINUE
C
C        THIS SECTION OF THE PROGRAM INSPECTS FOR
C        NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS.  ON
C        COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS.
C
C           KASE = 1     IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M
C           KASE = 2     IF S(L) IS NEGLIGIBLE AND L.LT.M
C           KASE = 3     IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND
C                        S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP).
C           KASE = 4     IF E(M-1) IS NEGLIGIBLE (CONVERGENCE).
C
         DO 430 LL = 1, M
            L = M - LL
C        ...EXIT
            IF (L .EQ. 0) GO TO 440
            TEST = CABS(S(L)) + CABS(S(L+1))
            ZTEST = TEST + CABS(E(L))
            IF (ZTEST .NE. TEST) GO TO 420
               E(L) = (0.0E0,0.0E0)
C        ......EXIT
               GO TO 440
  420       CONTINUE
  430    CONTINUE
  440    CONTINUE
         IF (L .NE. M - 1) GO TO 450
            KASE = 4
         GO TO 520
  450    CONTINUE
            LP1 = L + 1
            MP1 = M + 1
            DO 470 LLS = LP1, MP1
               LS = M - LLS + LP1
C           ...EXIT
               IF (LS .EQ. L) GO TO 480
               TEST = 0.0E0
               IF (LS .NE. M) TEST = TEST + CABS(E(LS))
               IF (LS .NE. L + 1) TEST = TEST + CABS(E(LS-1))
               ZTEST = TEST + CABS(S(LS))
               IF (ZTEST .NE. TEST) GO TO 460
                  S(LS) = (0.0E0,0.0E0)
C           ......EXIT
                  GO TO 480
  460          CONTINUE
  470       CONTINUE
  480       CONTINUE
            IF (LS .NE. L) GO TO 490
               KASE = 3
            GO TO 510
  490       CONTINUE
            IF (LS .NE. M) GO TO 500
               KASE = 1
            GO TO 510
  500       CONTINUE
               KASE = 2
               L = LS
  510       CONTINUE
  520    CONTINUE
         L = L + 1
C
C        PERFORM THE TASK INDICATED BY KASE.
C
         GO TO (530, 560, 580, 610), KASE
C
C        DEFLATE NEGLIGIBLE S(M).
C
  530    CONTINUE
            MM1 = M - 1
            F = REAL(E(M-1))
            E(M-1) = (0.0E0,0.0E0)
            DO 550 KK = L, MM1
               K = MM1 - KK + L
               T1 = REAL(S(K))
               CALL SROTG(T1,F,CS,SN)
               S(K) = CMPLX(T1,0.0E0)
               IF (K .EQ. L) GO TO 540
                  F = -SN*REAL(E(K-1))
                  E(K-1) = CS*E(K-1)
  540          CONTINUE
               IF (WANTV) CALL CSROT(P,V(1,K),1,V(1,M),1,CS,SN)
  550       CONTINUE
         GO TO 650
C
C        SPLIT AT NEGLIGIBLE S(L).
C
  560    CONTINUE
            F = REAL(E(L-1))
            E(L-1) = (0.0E0,0.0E0)
            DO 570 K = L, M
               T1 = REAL(S(K))
               CALL SROTG(T1,F,CS,SN)
               S(K) = CMPLX(T1,0.0E0)
               F = -SN*REAL(E(K))
               E(K) = CS*E(K)
               IF (WANTU) CALL CSROT(N,U(1,K),1,U(1,L-1),1,CS,SN)
  570       CONTINUE
         GO TO 650
C
C        PERFORM ONE QR STEP.
C
  580    CONTINUE
C
C           CALCULATE THE SHIFT.
C
            SCALE = AMAX1(CABS(S(M)),CABS(S(M-1)),CABS(E(M-1)),
     *                    CABS(S(L)),CABS(E(L)))
            SM = REAL(S(M))/SCALE
            SMM1 = REAL(S(M-1))/SCALE
            EMM1 = REAL(E(M-1))/SCALE
            SL = REAL(S(L))/SCALE
            EL = REAL(E(L))/SCALE
            B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0
            C = (SM*EMM1)**2
            SHIFT = 0.0E0
            IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 590
               SHIFT = SQRT(B**2+C)
               IF (B .LT. 0.0E0) SHIFT = -SHIFT
               SHIFT = C/(B + SHIFT)
  590       CONTINUE
            F = (SL + SM)*(SL - SM) - SHIFT
            G = SL*EL
C
C           CHASE ZEROS.
C
            MM1 = M - 1
            DO 600 K = L, MM1
               CALL SROTG(F,G,CS,SN)
               IF (K .NE. L) E(K-1) = CMPLX(F,0.0E0)
               F = CS*REAL(S(K)) + SN*REAL(E(K))
               E(K) = CS*E(K) - SN*S(K)
               G = SN*REAL(S(K+1))
               S(K+1) = CS*S(K+1)
               IF (WANTV) CALL CSROT(P,V(1,K),1,V(1,K+1),1,CS,SN)
               CALL SROTG(F,G,CS,SN)
               S(K) = CMPLX(F,0.0E0)
               F = CS*REAL(E(K)) + SN*REAL(S(K+1))
               S(K+1) = -SN*E(K) + CS*S(K+1)
               G = SN*REAL(E(K+1))
               E(K+1) = CS*E(K+1)
               IF (WANTU .AND. K .LT. N)
     *            CALL CSROT(N,U(1,K),1,U(1,K+1),1,CS,SN)
  600       CONTINUE
            E(M-1) = CMPLX(F,0.0E0)
            ITER = ITER + 1
         GO TO 650
C
C        CONVERGENCE.
C
  610    CONTINUE
C
C           MAKE THE SINGULAR VALUE  POSITIVE
C
            IF (REAL(S(L)) .GE. 0.0E0) GO TO 620
               S(L) = -S(L)
               IF (WANTV) CALL CSCAL(P,(-1.0E0,0.0E0),V(1,L),1)
  620       CONTINUE
C
C           ORDER THE SINGULAR VALUE.
C
  630       IF (L .EQ. MM) GO TO 640
C           ...EXIT
               IF (REAL(S(L)) .GE. REAL(S(L+1))) GO TO 640
               T = S(L)
               S(L) = S(L+1)
               S(L+1) = T
               IF (WANTV .AND. L .LT. P)
     *            CALL CSWAP(P,V(1,L),1,V(1,L+1),1)
               IF (WANTU .AND. L .LT. N)
     *            CALL CSWAP(N,U(1,L),1,U(1,L+1),1)
               L = L + 1
            GO TO 630
  640       CONTINUE
            ITER = 0
            M = M - 1
  650    CONTINUE
      GO TO 400
  660 CONTINUE
      RETURN
      END
      FUNCTION DET(A,KA,N,X)
C     -------------------
C     EVALUATION OF THE DETERMINANT OF A-XI WHERE A IS AN NXN MATRIX,
C     X IS A SCALAR, AND I IS THE NXN IDENTITY MATRIX.
C     -------------------
C     KA IS THE ROW DIMENSION OF A IN THE CALLING PROGRAM. IT IS
C     ASSUMED THAT KA IS GREATER THAN OR EQUAL TO N.
C     -------------------
      DIMENSION A(KA,N)
      IF (N .GE. 2) GO TO 10
      DET = A(1,1)-X
      RETURN
C
C              REPLACE A WITH A-XI
C
   10 IF (X .EQ. 0.0) GO TO 20
      DO 11 K=1,N
   11 A(K,K) = A(K,K)-X
C
C                INITIALIZATION
C
   20 DET = 1.0
      NM1 = N-1
      DO 52 K=1,NM1
      KP1 = K+1
C
C       SEARCH FOR THE K-TH PIVOT ELEMENT
C
      S = ABS(A(K,K))
      L = K
      DO 30 I=KP1,N
      C = ABS(A(I,K))
      IF (S .GE. C) GO TO 30
      S = C
      L = I
   30 CONTINUE
      PIVOT = A(L,K)
C
C         UPDATE THE CALCULATION OF DET
C
      DET = DET*PIVOT
      IF (DET .EQ. 0.0) RETURN
      IF (K .EQ. L) GO TO 50
      DET = -DET
C
C          INTERCHANGING ROWS K AND L
C
      DO 40 J=K,N
      C = A(K,J)
      A(K,J) = A(L,J)
   40 A(L,J) = C
C
C        REDUCTION OF THE NON-PIVOT ROWS
C
   50 DO 51 I=KP1,N
      C = A(I,K)/PIVOT
      DO 51 J=KP1,N
   51 A(I,J) = A(I,J)-C*A(K,J)
   52 CONTINUE
C
C         FINAL DETERMINANT CALCULATION
C
      DET = DET*A(N,N)
      RETURN
      END
      DOUBLE PRECISION FUNCTION DPDET(A,KA,N,X)
C     -------------------
C     EVALUATION OF THE DETERMINANT OF A-XI WHERE A IS AN NXN MATRIX,
C     X IS A SCALAR, AND I IS THE NXN IDENTITY MATRIX.
C     -------------------
C     KA IS THE ROW DIMENSION OF A IN THE CALLING PROGRAM. IT IS
C     ASSUMED THAT KA IS GREATER THAN OR EQUAL TO N.
C     -------------------
      DOUBLE PRECISION A(KA,N),X
      DOUBLE PRECISION PIVOT,S,C
      IF (N .GE. 2) GO TO 10
      DPDET = A(1,1) - X
      RETURN
C
C              REPLACE A WITH A-XI
C
   10 IF (X .EQ. 0.D0) GO TO 20
      DO 11 K=1,N
   11 A(K,K) = A(K,K) - X
C
C                INITIALIZATION
C
   20 DPDET = 1.D0
      NM1 = N - 1
      DO 52 K=1,NM1
      KP1 = K + 1
C
C       SEARCH FOR THE K-TH PIVOT ELEMENT
C
      S = DABS(A(K,K))
      L = K
      DO 30 I=KP1,N
      C = DABS(A(I,K))
      IF (S .GE. C) GO TO 30
      S = C
      L = I
   30 CONTINUE
      PIVOT = A(L,K)
C
C         UPDATE THE CALCULATION OF DET
C
      DPDET = DPDET*PIVOT
      IF (DPDET .EQ. 0.D0) RETURN
      IF (K .EQ. L) GO TO 50
      DPDET = -DPDET
C
C          INTERCHANGING ROWS K AND L
C
      DO 40 J=K,N
      C = A(K,J)
      A(K,J) = A(L,J)
   40 A(L,J) = C
C
C        REDUCTION OF THE NON-PIVOT ROWS
C
   50 DO 51 I=KP1,N
      C = A(I,K)/PIVOT
      DO 51 J=KP1,N
   51 A(I,J) = A(I,J) - C*A(K,J)
   52 CONTINUE
C
C         FINAL DETERMINANT CALCULATION
C
      DPDET = DPDET*A(N,N)
      RETURN
      END
      COMPLEX FUNCTION CDET(A,KA,N,X)
C     -------------------
C     EVALUATION OF THE DETERMINANT OF A-XI WHERE A IS AN NXN MATRIX,
C     X IS A SCALAR, AND I IS THE NXN IDENTITY MATRIX.
C     -------------------
C     KA IS THE ROW DIMENSION OF A IN THE CALLING PROGRAM. IT IS
C     ASSUMED THAT KA IS GREATER THAN OR EQUAL TO N.
C     -------------------
      COMPLEX A(KA,N),X
      COMPLEX PIVOT,T,ZERO
      REAL S,C
      DATA ZERO/(0.0,0.0)/
C
      IF (N .GE. 2) GO TO 10
      CDET = A(1,1)-X
      RETURN
C
C              REPLACE A WITH A-XI
C
   10 IF (X .EQ. ZERO) GO TO 20
      DO 11 K=1,N
   11 A(K,K) = A(K,K)-X
C
C                INITIALIZATION
C
   20 CDET = (1.0,0.0)
      NM1 = N-1
      DO 52 K=1,NM1
      KP1 = K+1
C
C       SEARCH FOR THE K-TH PIVOT ELEMENT
C
      S = ABS(REAL(A(K,K))) + ABS(AIMAG(A(K,K)))
      L = K
      DO 30 I=KP1,N
      C = ABS(REAL(A(I,K))) + ABS(AIMAG(A(I,K)))
      IF (S .GE. C) GO TO 30
      S = C
      L = I
   30 CONTINUE
      PIVOT = A(L,K)
C
C         UPDATE THE CALCULATION OF CDET
C
      CDET = CDET*PIVOT
      IF (CDET .EQ. ZERO) RETURN
      IF (K .EQ. L) GO TO 50
      CDET = -CDET
C
C          INTERCHANGING ROWS K AND L
C
      DO 40 J=K,N
      T = A(K,J)
      A(K,J) = A(L,J)
   40 A(L,J) = T
C
C        REDUCTION OF THE NON-PIVOT ROWS
C
   50 DO 51 I=KP1,N
      T = A(I,K)/PIVOT
      DO 51 J=KP1,N
   51 A(I,J) = A(I,J)-T*A(K,J)
   52 CONTINUE
C
C         FINAL DETERMINANT CALCULATION
C
      CDET = CDET*A(N,N)
      RETURN
      END
      SUBROUTINE ABSLV (MO,M,N,A,NA,B,NB,C,NC,WK,IERR)
      REAL A(NA,M), B(NB,N), C(NC,N), WK(*)
C ----------------------------------------------------------------------
C     ABSLV SOLVES THE REAL MATRIX EQUATION AX + XB = C. A IS REDUCED
C     TO LOWER SCHUR FORM, B IS REDUCED TO UPPER SCHUR FORM, AND THE
C     TRANSFORMED SYSTEM IS SOLVED BY BACK SUBSTITUTION.
C ----------------------------------------------------------------------
C        MO IS AN INPUT ARGUMENT WHICH SPECIFIES IF THE ROUTINE IS
C     BEING CALLED FOR THE FIRST TIME. ON AN INITIAL CALL MO = 0 AND
C     WE HAVE THE FOLLOWING SETUP.
C
C        A(NA,M)
C           A IS A MATRIX OF ORDER M. IT IS ASSUMED THAT
C           NA .GE. M .GE. 1.
C
C        B(NB,N)
C           B IS A MATRIX OF ORDER N. IT IS ASSUMED THAT
C           NB .GE. N .GE. 1.
C
C        C(NC,N)
C           C IS A MATRIX HAVING M ROWS AND N COLUMNS.
C           IT IS ASSUMED THAT NC .GE. M.
C
C        WK(---)
C           WK IS AN ARRAY OF DIMENSION M**2  + N**2 + 2K
C           WHERE K = MAX(M,N). WK IS A GENERAL STORAGE
C           AREA FOR THE ROUTINE.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN
C     THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING VALUES...
C
C        IERR =  0  THE SOLUTION WAS OBTAINED AND STORED IN C.
C        IERR =  1  THE EQUATIONS ARE INCONSISTENT FOR A AND B.
C                   THE PROBLEM CANNOT BE SOLVED.
C        IERR = -1  A COULD NOT BE REDUCED TO LOWER SCHUR FORM.
C                   THE PROBLEM CANNOT BE SOLVED.
C        IERR = -2  B COULD NOT BE REDUCED TO UPPER SCHUR FORM.
C                   THE PROBLEM CANNOT BE SOLVED.
C
C     WHEN IERR = 0, A CONTAINS THE LOWER SCHUR FORM OF THE MATRIX A,
C     B CONTAINS THE UPPER SCHUR FORM OF THE MATRIX B, AND WK CONTAINS
C     THE ORTHONAL MATRICES INVOLVED IN THE SCHUR DECOMPOSITIONS OF
C     A AND B. THIS INFORMATION CAN BE REUSED TO SOLVE A NEW SET OF
C     EQUATIONS AX + XB = C WITHOUT HAVING TO REDECOMPOSE A AND B.
C     THE FOLLOWING OPTIONS ARE AVAILABLE...
C
C        MO = 1      NEW MATRICES A AND C ARE GIVEN. THE DATA FOR B
C                    IS REUSED IN SOLVING THE NEW SET OF EQUATIONS.
C
C        MO = 2      NEW MATRICES B AND C ARE GIVEN. THE DATA FOR A
C                    IS REUSED IN SOLVING THE NEW SET OF EQUATIONS.
C
C     MO .NE. 0,1,2  A NEW MATRIX C IS GIVEN. THE DATA FOR A AND B
C                    IS REUSED IN SOLVING THE NEW SET OF EQUATIONS.
C
C     WHEN ABSLV IS RECALLED, IT IS ASSUMED THAT M, N, AND WK HAVE
C     NOT BEEN MODIFIED.
C ----------------------------------------------------------------------
C     THIS SUBROUTINE IS A MODIFICATION BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C     OF THE SUBROUTINE AXPXB WRITTEN BY
C        R.H. BARTELS AND G.W.STEWART
C        UNIVERSITY OF TEXAS AT AUSTIN.
C
C     REFERENCE. BARTELS, R.H. AND STEWART, G.W., ALGORITHM 432,
C        SOLUTION OF THE MATRIX EQUATION AX + XB = C, COMM. ACM
C        15 (1972), PP. 820-826.
C ----------------------------------------------------------------------
      IU = 1
      IV = M*M + 1
      IW = N*N + IV
      CALL ABSLV1 (MO,M,N,A,NA,WK(IU),M,B,NB,WK(IV),N,
     *                C,NC,WK(IW),IERR)
      RETURN
      END
      SUBROUTINE ABSLV1 (MO,M,N,A,NA,U,NU,B,NB,V,NV,C,NC,WK,IERR)
C ----------------------------------------------------------------------
C     ABSLV1 SOLVES THE REAL MATRIX EQUATION AX + XB = C. A IS REDUCED
C     TO LOWER SCHUR FORM, B IS REDUCED TO UPPER SCHUR FORM, AND THE
C     TRANSFORMED SYSTEM IS SOLVED BY BACK SUBSTITUTION.
C ----------------------------------------------------------------------
      REAL A(NA,M), B(NB,N), C(NC,N)
      REAL U(NU,M), V(NV,N), TEMP, WK(*)
C
C     IF REQUIRED, REDUCE A TO LOWER REAL SCHUR FORM
C
      IF (MO .NE. 0 .AND. MO .NE. 1) GO TO 35
      DO 11 I = 1,M
         DO 10 J = I,M
            TEMP = A(I,J)
            A(I,J) = A(J,I)
            A(J,I) = TEMP
   10    CONTINUE
   11 CONTINUE
      CALL ORTHES (NA,M,1,M,A,WK)
      CALL ORTRN1 (M,1,M,A,NA,U,NU,WK)
C
      IF (M .EQ. 1) GO TO 20
      CALL SCHUR (M,1,M,A,NA,U,NU,WK(1),WK(M+1),IERR)
      IF (IERR .NE. 0) GO TO 200
C
   20 DO 31 I = 1,M
         DO 30 J = I,M
            TEMP = A(I,J)
            A(I,J) = A(J,I)
            A(J,I) = TEMP
   30    CONTINUE
   31 CONTINUE
C
C     IF REQUIRED, REDUCE B TO UPPER REAL SCHUR FORM
C
   35 IF (MO .NE. 0 .AND. MO .NE. 2) GO TO 45
      CALL ORTHES (NB,N,1,N,B,WK)
      CALL ORTRN1 (N,1,N,B,NB,V,NV,WK)
C
      IF (N .EQ. 1) GO TO 45
      CALL SCHUR (N,1,N,B,NB,V,NV,WK(1),WK(N+1),IERR)
      IF (IERR .NE. 0) GO TO 210
C
C     TRANSFORM C
C
   45 DO 61 J = 1,N
         DO 51 I = 1,M
            WK(I) = 0.0
            DO 50 K = 1,M
               WK(I) = WK(I) + U(K,I)*C(K,J)
   50       CONTINUE
   51    CONTINUE
         DO 60 I = 1,M
            C(I,J) = WK(I)
   60    CONTINUE
   61 CONTINUE
C
      DO 81 I = 1,M
         DO 71 J = 1,N
            WK(J) = 0.0
            DO 70 K = 1,N
               WK(J) = WK(J) + C(I,K)*V(K,J)
   70       CONTINUE
   71    CONTINUE
         DO 80 J = 1,N
            C(I,J) = WK(J)
   80    CONTINUE
   81 CONTINUE
C
C     SOLVE THE TRANSFORMED SYSTEM
C
      CALL SHRSLV (A,B,C,M,N,NA,NB,NC,IERR)
      IF (IERR .NE. 0) GO TO 220
C
C     TRANSFORM C BACK TO THE SOLUTION
C
      DO 101 J = 1,N
         DO 91 I = 1,M
            WK(I) = 0.0
            DO 90 K = 1,M
               WK(I) = WK(I) + U(I,K)*C(K,J)
   90       CONTINUE
   91    CONTINUE
         DO 100 I = 1,M
            C(I,J) = WK(I)
  100    CONTINUE
  101 CONTINUE
C
      DO 121 I = 1,M
         DO 111 J = 1,N
            WK(J) = 0.0
            DO 110 K = 1,N
               WK(J) = WK(J) + C(I,K)*V(J,K)
  110       CONTINUE
  111    CONTINUE
         DO 120 J = 1,N
            C(I,J) = WK(J)
  120    CONTINUE
  121 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = -1
      RETURN
  210 IERR = -2
      RETURN
  220 IERR = 1
      RETURN
      END
      SUBROUTINE SCHUR (N, LOW, IGH, H, NH, Z, NZ, WR, WI, IERR)
C ----------------------------------------------------------------------
C     IT IS ASSUMED THAT H IS AN UPPER HESSENBERG MATRIX. SCHUR
C     OBTAINS AN ORTHOGONAL MATRIX Q FOR WHICH TRANSPOSE(Q)*H*Q
C     IS IN SCHUR FORM. THE EIGENVALUES OF H ARE ALSO COMPUTED.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N, (BALANC IS AN EISPACK SUBROUTINE).
C
C        H CONTAINS THE UPPER HESSENBERG MATRIX,
C
C        NH IS THE FIRST DIMENSION OF H,
C
C        Z CONTAINS A MATRIX OF ORDER N,
C
C        NZ IS THE FIRST DIMENSION OF Z.
C
C     ON OUTPUT-
C
C        H CONTAINS THE TRANSFORMED MATRIX IN UPPER SCHUR FORM,
C
C        Z CONTAINS THE MATRIX Z*Q WHERE Q IS THE ORTHOGONAL
C          MATRIX WHICH REDUCES H TO UPPER SCHUR FORM,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  THE EIGENVALUES
C          ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C          OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C          HAVING THE POSITIVE IMAGINARY PART FIRST.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N.
C
C        IERR IS SET TO
C          0          FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C -----------------
C     WRITTEN BY JACK DONGARRA
C          ARGONNE NATIONAL LABORATORY
C          MAY 1961
C     MODIFIED BY A.H. MORRIS (NSWC)
C ----------------------------------------------------------------------
C     THIS SUBROUTINE IS A MODIFICATION OF THE EISPACK SUBROUTINE
C     HQR2,  WHICH IS BASED ON THE ALGOL PROCEDURE HQR BY PETERS
C     AND WILKINSON, NUM. MATH. 16 (1970), PP.181-204.
C ----------------------------------------------------------------------
      INTEGER I, J, K, L, M, N, EN, LL, MM, NA, NH, NZ, IGH, ITS, LOW,
     *        MP2, ENM2, IERR
      REAL H(NH,N), WR(N), WI(N), Z(NZ,N)
      REAL P, Q, R, S, T, W, X, Y, ZZ, NORM, S1, S2
      LOGICAL NOTLAS
C     REAL SQRT, ABS
C     INTEGER MIN0
C
      IERR = 0
      NORM = 0.0
      K = 1
C     ********** STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM **********
      DO 20 I = 1,N
C
        DO 10 J = K,N
          NORM = NORM + ABS(H(I,J))
   10   CONTINUE
C
        K = I
        IF (I .GE. LOW .AND. I .LE. IGH) GO TO 20
        WR(I) = H(I,I)
        WI(I) = 0.0
   20 CONTINUE
C
      EN = IGH
      T = 0.0
C     ********** SEARCH FOR NEXT EIGENVALUES **********
   30 IF (EN .LT. LOW) GO TO 300
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********
   40 DO 50 LL = LOW,EN
        L = EN + LOW - LL
        IF (L .EQ. LOW) GO TO 60
        S = ABS(H(L-1,L-1)) + ABS(H(L,L))
        IF (S .EQ. 0.0) S = NORM
        S1 = S
        S2 = S1 + ABS(H(L,L-1))
        IF (S1 .EQ. S2) GO TO 60
   50 CONTINUE
C     ********** FORM SHIFT **********
   60 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 220
      Y = H(NA,NA)
      W = H(EN,NA)*H(NA,EN)
      IF (L .EQ .NA) GO TO 230
      IF (ITS .EQ. 30) GO TO 290
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 80
C     ********** FORM EXCEPTIONAL SHIFT **********
      T = T + X
C
      DO 70 I = LOW,EN
        H(I,I) = H(I,I) - X
   70 CONTINUE
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = 0.75*S
      Y = X
      W = -0.4375*S*S
   80 ITS = ITS + 1
C     ********** LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- **********
      DO 90 MM = L,ENM2
        M = ENM2 + L - MM
        ZZ = H(M,M)
        R = X - ZZ
        S = Y - ZZ
        P = (R*S-W)/H(M+1,M) + H(M,M+1)
        Q = H(M+1,M+1) - ZZ - R - S
        R = H(M+2,M+1)
        S = ABS(P) + ABS(Q) + ABS(R)
        P = P/S
        Q = Q/S
        R = R/S
        IF (M .EQ. L) GO TO 100
        S1 = ABS(P)*(ABS(H(M-1,M-1))+ABS(ZZ)+ABS(H(M+1,M+1)))
        S2 = S1 + ABS(H(M,M-1))*(ABS(Q) + ABS(R))
        IF (S1 .EQ. S2) GO TO 100
   90 CONTINUE
C
  100 MP2 = M + 2
C
      DO 110 I = MP2,EN
        H(I,I-2) = 0.0
        IF (I .EQ. MP2) GO TO 110
        H(I,I-3) = 0.0
  110 CONTINUE
C     ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN **********
      DO 210 K = M,NA
        NOTLAS = K.NE.NA
        IF (K .EQ. M) GO TO 120
        P = H(K,K-1)
        Q = H(K+1,K-1)
        R = 0.0
        IF (NOTLAS) R = H(K+2,K-1)
        X = ABS(P) + ABS(Q) + ABS(R)
        IF (X .EQ. 0.0) GO TO 210
        P = P/X
        Q = Q/X
        R = R/X
  120   S = SQRT(P*P + Q*Q + R*R)
        IF (P .LT. 0.0) S = -S
        IF (K .EQ. M) GO TO 130
        H(K,K-1) = -S*X
        GO TO 140
  130   IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  140   P = P + S
        X = P/S
        Y = Q/S
        ZZ = R/S
        Q = Q/P
        R = R/P
C     ********** ROW MODIFICATION **********
        DO 160 J = K,N
          P = H(K,J) + Q*H(K+1,J)
          IF (.NOT.NOTLAS) GO TO 150
          P = P + R*H(K+2,J)
          H(K+2,J) = H(K+2,J) - P*ZZ
  150     H(K+1,J) = H(K+1,J) - P*Y
          H(K,J) = H(K,J) - P*X
  160   CONTINUE
C
        J = MIN0(EN,K+3)
C     ********** COLUMN MODIFICATION **********
        DO 180 I = 1,J
          P = X*H(I,K) + Y*H(I,K+1)
          IF (.NOT.NOTLAS) GO TO 170
          P = P + ZZ*H(I,K+2)
          H(I,K+2) = H(I,K+2) - P*R
  170     H(I,K+1) = H(I,K+1) - P*Q
          H(I,K) = H(I,K) - P
  180   CONTINUE
C     ********** ACCUMULATE TRANSFORMATIONS **********
        DO 200 I = LOW,IGH
          P = X*Z(I,K) + Y*Z(I,K+1)
          IF (.NOT.NOTLAS) GO TO 190
          P = P + ZZ*Z(I,K+2)
          Z(I,K+2) = Z(I,K+2) - P*R
  190     Z(I,K+1) = Z(I,K+1) - P*Q
          Z(I,K) = Z(I,K) - P
  200   CONTINUE
C
  210 CONTINUE
C
      GO TO 40
C     ********** ONE ROOT FOUND **********
  220 H(EN,EN) = X + T
      WR(EN) = H(EN,EN)
      WI(EN) = 0.0
      EN = NA
      GO TO 30
C     ********** TWO ROOTS FOUND **********
  230 P = (Y - X)/2.0
      Q = P*P + W
      ZZ = SQRT(ABS(Q))
      H(EN,EN) = X + T
      X = H(EN,EN)
      H(NA,NA) = Y + T
      IF (Q .LT. 0.0) GO TO 270
C     ********** REAL PAIR **********
      IF (P .LT. 0.0) ZZ = -ZZ
      ZZ = P + ZZ
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.0) WR(EN) = X - W/ZZ
      WI(NA) = 0.0
      WI(EN) = 0.0
      X = H(EN,NA)
      S = ABS(X) + ABS(ZZ)
      P = X/S
      Q = ZZ/S
      R = SQRT(P*P + Q*Q)
      P = P/R
      Q = Q/R
C     ********** ROW MODIFICATION **********
      DO 240 J = NA,N
        ZZ = H(NA,J)
        H(NA,J) = Q*ZZ + P*H(EN,J)
        H(EN,J) = Q*H(EN,J) - P*ZZ
  240 CONTINUE
C     ********** COLUMN MODIFICATION **********
      DO 250 I = 1,EN
        ZZ = H(I,NA)
        H(I,NA) = Q*ZZ + P*H(I,EN)
        H(I,EN) = Q*H(I,EN) - P*ZZ
  250 CONTINUE
C     ********** ACCUMULATE TRANSFORMATIONS **********
      DO 260 I = LOW,IGH
        ZZ = Z(I,NA)
        Z(I,NA) = Q*ZZ + P*Z(I,EN)
        Z(I,EN) = Q*Z(I,EN) - P*ZZ
  260 CONTINUE
C
      GO TO 280
C     ********** COMPLEX PAIR **********
  270 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  280 EN = ENM2
      GO TO 30
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
  290 IERR = EN
      RETURN
  300 DO 320 I = 1,N
        IP1 = I + 1
        IF (ABS(WI(I)) .NE. 0.0) IP1 = IP1 + 1
        IF (IP1 .GT. N) GO TO 320
        DO 310 J = IP1,N
          H(J,I) = 0.0
  310   CONTINUE
  320 CONTINUE
      RETURN
      END
      SUBROUTINE SHRSLV (A,B,C,M,N,NA,NB,NC,IERR)
C     ------------------------------------------------------------------
C     SHRSLV SOLVES THE MATRIX EQUATION AX + XB = C WHERE
C     A IS IN LOWER SCHUR FORM AND B IN UPPER SCHUR FORM.
C     ------------------------------------------------------------------
      INTEGER M,N,NA,NB,NC,IERR
      REAL A(NA,M), B(NB,N), C(NC,N)
      REAL SUM, P(4), T(4,4)
      INTEGER DK,DL,I,IB,J,JA,K,KM1,KK,L,LM1,LL
C
      L = 1
   10    LM1 = L - 1
         DL = 1
         IF (L .EQ. N) GO TO 15
         IF (B(L+1,L) .NE. 0.0) DL = 2
   15    LL = L + DL - 1
         IF (L .EQ. 1) GO TO 30
C
         DO 22 J = L,LL
            DO 21 I = 1,M
            SUM = C(I,J)
               DO 20 IB = 1,LM1
   20          SUM = SUM - C(I,IB)*B(IB,J)
   21       C(I,J) = SUM
   22    CONTINUE
C
   30    K = 1
   40       KM1 = K - 1
            DK = 1
            IF (K .EQ. M) GO TO 45
            IF (A(K,K+1) .NE. 0.0) DK = 2
   45       KK = K + DK - 1
            IF (K .EQ. 1) GO TO 60
C
            DO 52 I = K,KK
               DO 51 J = L,LL
               SUM = C(I,J)
                  DO 50 JA = 1,KM1
   50             SUM = SUM - A(I,JA)*C(JA,J)
   51          C(I,J) = SUM
   52       CONTINUE
C
   60       IF (DL .EQ. 2) GO TO 80
            IF (DK .EQ. 2) GO TO 70
            T(1,1) = A(K,K) + B(L,L)
            IF (T(1,1) .EQ. 0.0) GO TO 200
            C(K,L) = C(K,L)/T(1,1)
            IERR = 0
            GO TO 100
C
   70       T(1,1) = A(K,K) + B(L,L)
            T(1,2) = A(K,KK)
            T(2,1) = A(KK,K)
            T(2,2) = A(KK,KK) + B(L,L)
            P(1) = C(K,L)
            P(2) = C(KK,L)
            CALL SLV (2, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(KK,L) = P(2)
            GO TO 100
C
   80       IF (DK .EQ. 2) GO TO 90
            T(1,1) = A(K,K) + B(L,L)
            T(1,2) = B(LL,L)
            T(2,1) = B(L,LL)
            T(2,2) = A(K,K) + B(LL,LL)
            P(1) = C(K,L)
            P(2) = C(K,LL)
            CALL SLV (2, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(K,LL) = P(2)
            GO TO 100
C
   90       T(1,1) = A(K,K) + B(L,L)
            T(1,2) = A(K,KK)
            T(1,3) = B(LL,L)
            T(1,4) = 0.0
            T(2,1) = A(KK,K)
            T(2,2) = A(KK,KK) + B(L,L)
            T(2,3) = 0.0
            T(2,4) = T(1,3)
            T(3,1) = B(L,LL)
            T(3,2) = 0.0
            T(3,3) = A(K,K) + B(LL,LL)
            T(3,4) = T(1,2)
            T(4,1) = 0.0
            T(4,2) = T(3,1)
            T(4,3) = T(2,1)
            T(4,4) = A(KK,KK) + B(LL,LL)
            P(1) = C(K,L)
            P(2) = C(KK,L)
            P(3) = C(K,LL)
            P(4) = C(KK,LL)
            CALL SLV (4, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(KK,L) = P(2)
            C(K,LL) = P(3)
            C(KK,LL) = P(4)
C
  100    K = K + DK
         IF (K .LE. M) GO TO 40
      L = L + DL
      IF (L .LE. N) GO TO 10
      RETURN
C
C     ERROR RETURN
C
  200 IERR = 1
      RETURN
      END
      SUBROUTINE DABSLV (MO,M,N,A,NA,B,NB,C,NC,WK,IERR)
      DOUBLE PRECISION A(NA,M), B(NB,N), C(NC,N), WK(*)
C ----------------------------------------------------------------------
C     DABSLV SOLVES THE REAL MATRIX EQUATION AX + XB = C. A IS REDUCED
C     TO LOWER SCHUR FORM, B IS REDUCED TO UPPER SCHUR FORM, AND THE
C     TRANSFORMED SYSTEM IS SOLVED BY BACK SUBSTITUTION.
C ----------------------------------------------------------------------
C        MO IS AN INPUT ARGUMENT WHICH SPECIFIES IF THE ROUTINE IS
C     BEING CALLED FOR THE FIRST TIME. ON AN INITIAL CALL MO = 0 AND
C     WE HAVE THE FOLLOWING SETUP.
C
C        A(NA,M)
C           A IS A MATRIX OF ORDER M. IT IS ASSUMED THAT
C           NA .GE. M .GE. 1.
C
C        B(NB,N)
C           B IS A MATRIX OF ORDER N. IT IS ASSUMED THAT
C           NB .GE. N .GE. 1.
C
C        C(NC,N)
C           C IS A MATRIX HAVING M ROWS AND N COLUMNS.
C           IT IS ASSUMED THAT NC .GE. M.
C
C        WK(---)
C           WK IS AN ARRAY OF DIMENSION M**2  + N**2 + 2K
C           WHERE K = MAX(M,N). WK IS A GENERAL STORAGE
C           AREA FOR THE ROUTINE.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN
C     THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING VALUES...
C
C        IERR =  0  THE SOLUTION WAS OBTAINED AND STORED IN C.
C        IERR =  1  THE EQUATIONS ARE INCONSISTENT FOR A AND B.
C                   THE PROBLEM CANNOT BE SOLVED.
C        IERR = -1  A COULD NOT BE REDUCED TO LOWER SCHUR FORM.
C                   THE PROBLEM CANNOT BE SOLVED.
C        IERR = -2  B COULD NOT BE REDUCED TO UPPER SCHUR FORM.
C                   THE PROBLEM CANNOT BE SOLVED.
C
C     WHEN IERR = 0, A CONTAINS THE LOWER SCHUR FORM OF THE MATRIX A,
C     B CONTAINS THE UPPER SCHUR FORM OF THE MATRIX B, AND WK CONTAINS
C     THE ORTHONAL MATRICES INVOLVED IN THE SCHUR DECOMPOSITIONS OF
C     A AND B. THIS INFORMATION CAN BE REUSED TO SOLVE A NEW SET OF
C     EQUATIONS AX + XB = C WITHOUT HAVING TO REDECOMPOSE A AND B.
C     THE FOLLOWING OPTIONS ARE AVAILABLE...
C
C        MO = 1      NEW MATRICES A AND C ARE GIVEN. THE DATA FOR B
C                    IS REUSED IN SOLVING THE NEW SET OF EQUATIONS.
C
C        MO = 2      NEW MATRICES B AND C ARE GIVEN. THE DATA FOR A
C                    IS REUSED IN SOLVING THE NEW SET OF EQUATIONS.
C
C     MO .NE. 0,1,2  A NEW MATRIX C IS GIVEN. THE DATA FOR A AND B
C                    IS REUSED IN SOLVING THE NEW SET OF EQUATIONS.
C
C     WHEN DABSLV IS RECALLED, IT IS ASSUMED THAT M, N, AND WK HAVE
C     NOT BEEN MODIFIED.
C ----------------------------------------------------------------------
C     THIS SUBROUTINE IS A MODIFICATION BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C     OF THE SUBROUTINE AXPXB WRITTEN BY
C        R.H. BARTELS AND G.W.STEWART
C        UNIVERSITY OF TEXAS AT AUSTIN.
C
C     REFERENCE. BARTELS, R.H. AND STEWART, G.W., ALGORITHM 432,
C        SOLUTION OF THE MATRIX EQUATION AX + XB = C, COMM. ACM
C        15 (1972), PP. 820-826.
C ----------------------------------------------------------------------
      IU = 1
      IV = M*M + 1
      IW = N*N + IV
      CALL DABSV1 (MO,M,N,A,NA,WK(IU),M,B,NB,WK(IV),N,
     *                C,NC,WK(IW),IERR)
      RETURN
      END
      SUBROUTINE DABSV1 (MO,M,N,A,NA,U,NU,B,NB,V,NV,C,NC,WK,IERR)
C ----------------------------------------------------------------------
C     DABSV1 SOLVES THE REAL MATRIX EQUATION AX + XB = C. A IS REDUCED
C     TO LOWER SCHUR FORM, B IS REDUCED TO UPPER SCHUR FORM, AND THE
C     TRANSFORMED SYSTEM IS SOLVED BY BACK SUBSTITUTION.
C ----------------------------------------------------------------------
      DOUBLE PRECISION A(NA,M), B(NB,N), C(NC,N)
      DOUBLE PRECISION U(NU,M), V(NV,N), TEMP, WK(*)
C
C     IF REQUIRED, REDUCE A TO LOWER REAL SCHUR FORM
C
      IF (MO .NE. 0 .AND. MO .NE. 1) GO TO 35
      DO 11 I = 1,M
         DO 10 J = I,M
            TEMP = A(I,J)
            A(I,J) = A(J,I)
            A(J,I) = TEMP
   10    CONTINUE
   11 CONTINUE
      CALL DORTH (NA,M,1,M,A,WK)
      CALL DRTRN1 (M,1,M,A,NA,U,NU,WK)
C
      IF (M .EQ. 1) GO TO 20
      CALL DSCHUR (M,1,M,A,NA,U,NU,WK(1),WK(M+1),IERR)
      IF (IERR .NE. 0) GO TO 200
C
   20 DO 31 I = 1,M
         DO 30 J = I,M
            TEMP = A(I,J)
            A(I,J) = A(J,I)
            A(J,I) = TEMP
   30    CONTINUE
   31 CONTINUE
C
C     IF REQUIRED, REDUCE B TO UPPER REAL SCHUR FORM
C
   35 IF (MO .NE. 0 .AND. MO .NE. 2) GO TO 45
      CALL DORTH (NB,N,1,N,B,WK)
      CALL DRTRN1 (N,1,N,B,NB,V,NV,WK)
C
      IF (N .EQ. 1) GO TO 45
      CALL DSCHUR (N,1,N,B,NB,V,NV,WK(1),WK(N+1),IERR)
      IF (IERR .NE. 0) GO TO 210
C
C     TRANSFORM C
C
   45 DO 61 J = 1,N
         DO 51 I = 1,M
            WK(I) = 0.D0
            DO 50 K = 1,M
               WK(I) = WK(I) + U(K,I)*C(K,J)
   50       CONTINUE
   51    CONTINUE
         DO 60 I = 1,M
            C(I,J) = WK(I)
   60    CONTINUE
   61 CONTINUE
C
      DO 81 I = 1,M
         DO 71 J = 1,N
            WK(J) = 0.D0
            DO 70 K = 1,N
               WK(J) = WK(J) + C(I,K)*V(K,J)
   70       CONTINUE
   71    CONTINUE
         DO 80 J = 1,N
            C(I,J) = WK(J)
   80    CONTINUE
   81 CONTINUE
C
C     SOLVE THE TRANSFORMED SYSTEM
C
      CALL DSHSLV (A,B,C,M,N,NA,NB,NC,IERR)
      IF (IERR .NE. 0) GO TO 220
C
C     TRANSFORM C BACK TO THE SOLUTION
C
      DO 101 J = 1,N
         DO 91 I = 1,M
            WK(I) = 0.D0
            DO 90 K = 1,M
               WK(I) = WK(I) + U(I,K)*C(K,J)
   90       CONTINUE
   91    CONTINUE
         DO 100 I = 1,M
            C(I,J) = WK(I)
  100    CONTINUE
  101 CONTINUE
C
      DO 121 I = 1,M
         DO 111 J = 1,N
            WK(J) = 0.D0
            DO 110 K = 1,N
               WK(J) = WK(J) + C(I,K)*V(J,K)
  110       CONTINUE
  111    CONTINUE
         DO 120 J = 1,N
            C(I,J) = WK(J)
  120    CONTINUE
  121 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = -1
      RETURN
  210 IERR = -2
      RETURN
  220 IERR = 1
      RETURN
      END
      SUBROUTINE DSCHUR (N, LOW, IGH, H, NH, Z, NZ, WR, WI, IERR)
C ----------------------------------------------------------------------
C     IT IS ASSUMED THAT H IS AN UPPER HESSENBERG MATRIX. DSCHUR
C     OBTAINS AN ORTHOGONAL MATRIX Q FOR WHICH  TRANSPOSE(Q)*H*Q
C     IS IN SCHUR FORM. THE EIGENVALUES OF H ARE ALSO COMPUTED.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE DBAL.  IF  DBAL  HAS NOT BEEN USED, SET
C          LOW = 1, IGH = N.
C
C        H CONTAINS THE UPPER HESSENBERG MATRIX,
C
C        NH IS THE FIRST DIMENSION OF H,
C
C        Z CONTAINS A MATRIX OF ORDER N,
C
C        NZ IS THE FIRST DIMENSION OF Z.
C
C     ON OUTPUT-
C
C        H CONTAINS THE TRANSFORMED MATRIX IN UPPER SCHUR FORM,
C
C        Z CONTAINS THE MATRIX Z*Q WHERE Q IS THE ORTHOGONAL
C          MATRIX WHICH REDUCES H TO UPPER SCHUR FORM,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  THE EIGENVALUES
C          ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C          OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C          HAVING THE POSITIVE IMAGINARY PART FIRST.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N.
C
C        IERR IS SET TO
C          0          FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 50 ITERATIONS.
C
C -----------------
C     WRITTEN BY JACK DONGARRA
C          ARGONNE NATIONAL LABORATORY
C          MAY 1961
C     MODIFIED BY A.H. MORRIS (NSWC)
C ----------------------------------------------------------------------
C     THIS SUBROUTINE IS A MODIFICATION OF THE EISPACK SUBROUTINE
C     HQR2,  WHICH IS BASED ON THE ALGOL PROCEDURE HQR BY PETERS
C     AND WILKINSON, NUM. MATH. 16 (1970), PP.181-204.
C ----------------------------------------------------------------------
      INTEGER I, J, K, L, M, N, EN, LL, MM, NA, NH, NZ, IGH, ITS, LOW,
     *        MP2, ENM2, IERR
      DOUBLE PRECISION H(NH,N), WR(N), WI(N), Z(NZ,N)
      DOUBLE PRECISION P, Q, R, S, T, W, X, Y, ZZ, NORM, S1, S2
      LOGICAL NOTLAS
C     DOUBLE PRECISION DSQRT, DABS
C     INTEGER MIN0
C
      IERR = 0
      NORM = 0.D0
      K = 1
C     ********** STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM **********
      DO 20 I = 1,N
C
        DO 10 J = K,N
          NORM = NORM + DABS(H(I,J))
   10   CONTINUE
C
        K = I
        IF (I .GE. LOW .AND. I .LE. IGH) GO TO 20
        WR(I) = H(I,I)
        WI(I) = 0.D0
   20 CONTINUE
C
      EN = IGH
      T = 0.D0
C     ********** SEARCH FOR NEXT EIGENVALUES **********
   30 IF (EN .LT. LOW) GO TO 300
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********
   40 DO 50 LL = LOW,EN
        L = EN + LOW - LL
        IF (L .EQ. LOW) GO TO 60
        S = DABS(H(L-1,L-1)) + DABS(H(L,L))
        IF (S .EQ. 0.D0) S = NORM
        S1 = S
        S2 = S1 + DABS(H(L,L-1))
        IF (S1 .EQ. S2) GO TO 60
   50 CONTINUE
C     ********** FORM SHIFT **********
   60 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 220
      Y = H(NA,NA)
      W = H(EN,NA)*H(NA,EN)
      IF (L .EQ .NA) GO TO 230
      IF (ITS .EQ. 50) GO TO 290
      IF (ITS .NE. 10 .AND. ITS .NE. 20 .AND. ITS .NE. 30) GO TO 80
C     ********** FORM EXCEPTIONAL SHIFT **********
      T = T + X
C
      DO 70 I = LOW,EN
        H(I,I) = H(I,I) - X
   70 CONTINUE
C
      S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
      X = 0.75D0*S
      Y = X
      W = -0.4375D0*S*S
   80 ITS = ITS + 1
C     ********** LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- **********
      DO 90 MM = L,ENM2
        M = ENM2 + L - MM
        ZZ = H(M,M)
        R = X - ZZ
        S = Y - ZZ
        P = (R*S-W)/H(M+1,M) + H(M,M+1)
        Q = H(M+1,M+1) - ZZ - R - S
        R = H(M+2,M+1)
        S = DABS(P) + DABS(Q) + DABS(R)
        P = P/S
        Q = Q/S
        R = R/S
        IF (M .EQ. L) GO TO 100
        S1 = DABS(P)*(DABS(H(M-1,M-1))+DABS(ZZ)+DABS(H(M+1,M+1)))
        S2 = S1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R))
        IF (S1 .EQ. S2) GO TO 100
   90 CONTINUE
C
  100 MP2 = M + 2
C
      DO 110 I = MP2,EN
        H(I,I-2) = 0.D0
        IF (I .EQ. MP2) GO TO 110
        H(I,I-3) = 0.D0
  110 CONTINUE
C     ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN **********
      DO 210 K = M,NA
        NOTLAS = K.NE.NA
        IF (K .EQ. M) GO TO 120
        P = H(K,K-1)
        Q = H(K+1,K-1)
        R = 0.D0
        IF (NOTLAS) R = H(K+2,K-1)
        X = DABS(P) + DABS(Q) + DABS(R)
        IF (X .EQ. 0.D0) GO TO 210
        P = P/X
        Q = Q/X
        R = R/X
  120   S = DSQRT(P*P + Q*Q + R*R)
        IF (P .LT. 0.D0) S = -S
        IF (K .EQ. M) GO TO 130
        H(K,K-1) = -S*X
        GO TO 140
  130   IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  140   P = P + S
        X = P/S
        Y = Q/S
        ZZ = R/S
        Q = Q/P
        R = R/P
C     ********** ROW MODIFICATION **********
        DO 160 J = K,N
          P = H(K,J) + Q*H(K+1,J)
          IF (.NOT.NOTLAS) GO TO 150
          P = P + R*H(K+2,J)
          H(K+2,J) = H(K+2,J) - P*ZZ
  150     H(K+1,J) = H(K+1,J) - P*Y
          H(K,J) = H(K,J) - P*X
  160   CONTINUE
C
        J = MIN0(EN,K+3)
C     ********** COLUMN MODIFICATION **********
        DO 180 I = 1,J
          P = X*H(I,K) + Y*H(I,K+1)
          IF (.NOT.NOTLAS) GO TO 170
          P = P + ZZ*H(I,K+2)
          H(I,K+2) = H(I,K+2) - P*R
  170     H(I,K+1) = H(I,K+1) - P*Q
          H(I,K) = H(I,K) - P
  180   CONTINUE
C     ********** ACCUMULATE TRANSFORMATIONS **********
        DO 200 I = LOW,IGH
          P = X*Z(I,K) + Y*Z(I,K+1)
          IF (.NOT.NOTLAS) GO TO 190
          P = P + ZZ*Z(I,K+2)
          Z(I,K+2) = Z(I,K+2) - P*R
  190     Z(I,K+1) = Z(I,K+1) - P*Q
          Z(I,K) = Z(I,K) - P
  200   CONTINUE
C
  210 CONTINUE
C
      GO TO 40
C     ********** ONE ROOT FOUND **********
  220 H(EN,EN) = X + T
      WR(EN) = H(EN,EN)
      WI(EN) = 0.D0
      EN = NA
      GO TO 30
C     ********** TWO ROOTS FOUND **********
  230 P = (Y - X)/2.D0
      Q = P*P + W
      ZZ = DSQRT(DABS(Q))
      H(EN,EN) = X + T
      X = H(EN,EN)
      H(NA,NA) = Y + T
      IF (Q .LT. 0.D0) GO TO 270
C     ********** REAL PAIR **********
      IF (P .LT. 0.D0) ZZ = -ZZ
      ZZ = P + ZZ
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.D0) WR(EN) = X - W/ZZ
      WI(NA) = 0.D0
      WI(EN) = 0.D0
      X = H(EN,NA)
      S = DABS(X) + DABS(ZZ)
      P = X/S
      Q = ZZ/S
      R = DSQRT(P*P + Q*Q)
      P = P/R
      Q = Q/R
C     ********** ROW MODIFICATION **********
      DO 240 J = NA,N
        ZZ = H(NA,J)
        H(NA,J) = Q*ZZ + P*H(EN,J)
        H(EN,J) = Q*H(EN,J) - P*ZZ
  240 CONTINUE
C     ********** COLUMN MODIFICATION **********
      DO 250 I = 1,EN
        ZZ = H(I,NA)
        H(I,NA) = Q*ZZ + P*H(I,EN)
        H(I,EN) = Q*H(I,EN) - P*ZZ
  250 CONTINUE
C     ********** ACCUMULATE TRANSFORMATIONS **********
      DO 260 I = LOW,IGH
        ZZ = Z(I,NA)
        Z(I,NA) = Q*ZZ + P*Z(I,EN)
        Z(I,EN) = Q*Z(I,EN) - P*ZZ
  260 CONTINUE
C
      GO TO 280
C     ********** COMPLEX PAIR **********
  270 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  280 EN = ENM2
      GO TO 30
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 50 ITERATIONS **********
  290 IERR = EN
      RETURN
  300 DO 320 I = 1,N
        IP1 = I + 1
        IF (DABS(WI(I)) .NE. 0.D0) IP1 = IP1 + 1
        IF (IP1 .GT. N) GO TO 320
        DO 310 J = IP1,N
          H(J,I) = 0.D0
  310   CONTINUE
  320 CONTINUE
      RETURN
      END
      SUBROUTINE DSHSLV (A,B,C,M,N,NA,NB,NC,IERR)
C     ------------------------------------------------------------------
C     DSHSLV SOLVES THE MATRIX EQUATION AX + XB = C WHERE
C     A IS IN LOWER SCHUR FORM AND B IN UPPER SCHUR FORM.
C     ------------------------------------------------------------------
      INTEGER M,N,NA,NB,NC,IERR
      DOUBLE PRECISION A(NA,M), B(NB,N), C(NC,N)
      DOUBLE PRECISION SUM, P(4), T(4,4)
      INTEGER DK,DL,I,IB,J,JA,K,KM1,KK,L,LM1,LL
C
      L = 1
   10    LM1 = L - 1
         DL = 1
         IF (L .EQ. N) GO TO 15
         IF (B(L+1,L) .NE. 0.D0) DL = 2
   15    LL = L + DL - 1
         IF (L .EQ. 1) GO TO 30
C
         DO 22 J = L,LL
            DO 21 I = 1,M
            SUM = C(I,J)
               DO 20 IB = 1,LM1
   20          SUM = SUM - C(I,IB)*B(IB,J)
   21       C(I,J) = SUM
   22    CONTINUE
C
   30    K = 1
   40       KM1 = K - 1
            DK = 1
            IF (K .EQ. M) GO TO 45
            IF (A(K,K+1) .NE. 0.D0) DK = 2
   45       KK = K + DK - 1
            IF (K .EQ. 1) GO TO 60
C
            DO 52 I = K,KK
               DO 51 J = L,LL
               SUM = C(I,J)
                  DO 50 JA = 1,KM1
   50             SUM = SUM - A(I,JA)*C(JA,J)
   51          C(I,J) = SUM
   52       CONTINUE
C
   60       IF (DL .EQ. 2) GO TO 80
            IF (DK .EQ. 2) GO TO 70
            T(1,1) = A(K,K) + B(L,L)
            IF (T(1,1) .EQ. 0.D0) GO TO 200
            C(K,L) = C(K,L)/T(1,1)
            IERR = 0
            GO TO 100
C
   70       T(1,1) = A(K,K) + B(L,L)
            T(1,2) = A(K,KK)
            T(2,1) = A(KK,K)
            T(2,2) = A(KK,KK) + B(L,L)
            P(1) = C(K,L)
            P(2) = C(KK,L)
            CALL DPSLV (2, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(KK,L) = P(2)
            GO TO 100
C
   80       IF (DK .EQ. 2) GO TO 90
            T(1,1) = A(K,K) + B(L,L)
            T(1,2) = B(LL,L)
            T(2,1) = B(L,LL)
            T(2,2) = A(K,K) + B(LL,LL)
            P(1) = C(K,L)
            P(2) = C(K,LL)
            CALL DPSLV (2, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(K,LL) = P(2)
            GO TO 100
C
   90       T(1,1) = A(K,K) + B(L,L)
            T(1,2) = A(K,KK)
            T(1,3) = B(LL,L)
            T(1,4) = 0.D0
            T(2,1) = A(KK,K)
            T(2,2) = A(KK,KK) + B(L,L)
            T(2,3) = 0.D0
            T(2,4) = T(1,3)
            T(3,1) = B(L,LL)
            T(3,2) = 0.D0
            T(3,3) = A(K,K) + B(LL,LL)
            T(3,4) = T(1,2)
            T(4,1) = 0.D0
            T(4,2) = T(3,1)
            T(4,3) = T(2,1)
            T(4,4) = A(KK,KK) + B(LL,LL)
            P(1) = C(K,L)
            P(2) = C(KK,L)
            P(3) = C(K,LL)
            P(4) = C(KK,LL)
            CALL DPSLV (4, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(KK,L) = P(2)
            C(K,LL) = P(3)
            C(KK,LL) = P(4)
C
  100    K = K + DK
         IF (K .LE. M) GO TO 40
      L = L + DL
      IF (L .LE. N) GO TO 10
      RETURN
C
C     ERROR RETURN
C
  200 IERR = 1
      RETURN
      END
      SUBROUTINE TASLV (MO,N,A,NA,C,NC,WK,IERR)
      REAL A(NA,N), C(NC,N), WK(*)
C ----------------------------------------------------------------------
C     TASLV SOLVES THE REAL MATRIX EQUATION TRANSPOSE(A)*X + X*A = C
C     WHERE C IS A SYMMETRIC MATRIX. A IS REDUCED TO UPPER SCHUR FORM
C     AND THE TRANSFORMED SYSTEM IS SOLVED.
C ----------------------------------------------------------------------
C        MO IS AN INPUT ARGUMENT WHICH SPECIFIES IF THE ROUTINE IS
C     BEING CALLED FOR THE FIRST TIME. ON AN INITIAL CALL MO = 0 AND
C     WE HAVE THE FOLLOWING SETUP.
C
C        A(NA,N)
C           A IS A MATRIX OF ORDER N. IT IS ASSUMED THAT
C           NA .GE. N .GE. 1.
C
C        C(NC,N)
C           C IS A SYMMETRIC MATRIX OF ORDER N. IT IS
C           ASSUMED THAT NC .GE. N.
C
C        WK(---)
C           WK IS AN ARRAY OF DIMENSION N**2 + 2N THAT
C           IS A GENERAL STORAGE AREA FOR THE ROUTINE.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN
C     THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING VALUES...
C
C        IERR =  0  THE SOLUTION WAS OBTAINED AND STORED IN C.
C        IERR =  1  THE EQUATIONS ARE INCONSISTENT FOR A. THE
C                   PROBLEM CANNOT BE SOLVED.
C        IERR = -1  A COULD NOT BE REDUCEDTO UPPER SCHUR FORM.
C                   THE PROBLEM CANNOT BE SOLVED.
C
C     WHEN IERR = 0, A CONTAINS THE UPPER SCHUR FORM OF THE MATRIX
C     A AND WK CONTAINS THE ORTHOGONAL MATRIX INVOLVED IN THE SCHUR
C     DECOMPOSITION OF A. THIS INFORMATION CAN BE REUSED TO SOLVE A
C     NEW SET OF EQUATIONS TRANSPOSE(A)*X + X*A = C WITHOUT HAVING
C     TO REDECOMPOSE A. IN THIS CASE, THE INPUT ARGUMENT MO MAY BE
C     SET TO ANY NONZERO VALUE. WHEN MO .NE. 0, IT IS ASSUMED THAT
C     ONLY C HAS BEEN MODIFIED. ON OUTPUT THE SOLUTION FOR THE NEW
C     SET OF EQUATIONS IS STORED IN C.
C ----------------------------------------------------------------------
C     THIS SUBROUTINE IS A MODIFICATION BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C     OF THE SUBROUTINE ATXPXA WRITTEN BY
C        R.H. BARTELS AND G.W. STEWART
C        UNIVERSITY OF TEXAS AT AUSTIN.
C
C     REFERENCE. BARTELS, R.H. AND STEWART, G.W., ALGORITHM 432,
C        SOLUTION OF THE MATRIX EQUATION AX + XB = C, COMM. ACM
C        15 (1972), PP. 820-826.
C ----------------------------------------------------------------------
      IW = N*N + 1
      CALL TASLV1 (MO,N,A,NA,WK(1),N,C,NC,WK(IW),IERR)
      RETURN
      END
      SUBROUTINE TASLV1 (MO,N,A,NA,U,NU,C,NC,WK,IERR)
C ----------------------------------------------------------------------
C     TASLV1 SOLVES THE REAL MATRIX EQUATION TRANSPOSE(A)*X + X*A = C
C     WHERE C IS A SYMMETRIC MATRIX. A IS REDUCED TO UPPER SCHUR FORM
C     AND THE TRANSFORMED SYSTEM IS SOLVED.
C ----------------------------------------------------------------------
      REAL A(NA,N), U(NU,N), C(NC,N), WK(*)
C
C    IF REQUIRED, REDUCE A TO UPPER REAL SCHUR FORM
C
      IF (MO .NE. 0) GO TO 10
      CALL ORTHES (NA,N,1,N,A,WK)
      CALL ORTRN1 (N,1,N,A,NA,U,NU,WK)
      CALL SCHUR (N,1,N,A,NA,U,NU,WK(1),WK(N+1),IERR)
      IF (IERR .NE. 0) GO TO 200
C
C     TRANSFORM C
C
   10 DO 20 I = 1,N
         C(I,I) = C(I,I)/2.0
   20 CONTINUE
C
      DO 41 I = 1,N
         DO 31 J = 1,N
            WK(J) = 0.0
            DO 30 K = I,N
               WK(J) = WK(J) + C(I,K)*U(K,J)
   30       CONTINUE
   31    CONTINUE
         DO 40 J = 1,N
            C(I,J) = WK(J)
   40    CONTINUE
   41 CONTINUE
C
      DO 61 J = 1,N
         DO 51 I = 1,N
            WK(I) = 0.0
            DO 50 K = 1,N
               WK(I) = WK(I) + U(K,I)*C(K,J)
   50       CONTINUE
   51    CONTINUE
         DO 60 I = 1,N
            C(I,J) = WK(I)
   60    CONTINUE
   61 CONTINUE
C
      DO 71 I = 1,N
         DO 70 J = I,N
            C(I,J) = C(I,J) + C(J,I)
            C(J,I) = C(I,J)
   70    CONTINUE
   71 CONTINUE
C
C     SOLVE THE TRANSFORMED SYSTEM
C
      CALL SYMSLV (A,C,N,NA,NC,IERR)
      IF (IERR .NE. 0) GO TO 210
C
C     TRANSFORM C BACK TO THE SOLUTION
C
      DO 80 I = 1,N
         C(I,I) = C(I,I)/2.0
   80 CONTINUE
C
      DO 101 I = 1,N
         DO 91 J = 1,N
            WK(J) = 0.0
            DO 90 K = I,N
               WK(J) = WK(J) + C(I,K)*U(J,K)
   90       CONTINUE
   91    CONTINUE
         DO 100 J = 1,N
            C(I,J) = WK(J)
  100    CONTINUE
  101 CONTINUE
C
      DO 121 J = 1,N
         DO 111 I = 1,N
            WK(I) = 0.0
            DO 110 K = 1,N
               WK(I) = WK(I) + U(I,K)*C(K,J)
  110       CONTINUE
  111    CONTINUE
         DO 120 I = 1,N
            C(I,J) = WK(I)
  120    CONTINUE
  121 CONTINUE
C
      DO 131 I = 1,N
         DO 130 J = I,N
            C(I,J) = C(I,J) + C(J,I)
            C(J,I) = C(I,J)
  130    CONTINUE
  131 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = -1
      RETURN
  210 IERR = 1
      RETURN
      END
      SUBROUTINE SYMSLV (A,C,N,NA,NC,IERR)
C ----------------------------------------------------------------------
C     SYMSLV SOLVES THE MATRIX EQUATION TRANSPOSE(A)*X + X*A = C
C     WHERE A IS IN UPPER SCHUR FORM AND C IS SYMMETRIC.
C ----------------------------------------------------------------------
      INTEGER N,NA,NC,IERR
      REAL A(NA,N), C(NC,N), SUM, P(4), T(4,4)
      INTEGER DK,DL,I,IA,J,K,KK,KM1,L,LL,LDL
C
      L = 1
   10    DL = 1
         IF (L .EQ. N) GO TO 20
         IF (A(L+1,L) .NE. 0.0) DL = 2
   20    LL = L + DL - 1
C
         K = L
   30       KM1 = K - 1
            DK = 1
            IF (K .EQ. N) GO TO 35
            IF (A(K+1,K) .NE. 0.0) DK = 2
   35       KK = K + DK - 1
            IF (K .EQ. L) GO TO 45
C
            DO 42 I = K,KK
               DO 41 J = L,LL
               SUM = C(I,J)
                  DO 40 IA = L,KM1
   40             SUM = SUM - A(IA,I)*C(IA,J)
   41          C(I,J) = SUM
   42       CONTINUE
C
   45       IF (DL .EQ. 2) GO TO 60
            IF (DK .EQ. 2 ) GO TO 50
            T(1,1) = A(K,K) + A(L,L)
            IF (T(1,1) .EQ. 0.0) GO TO 200
            C(K,L) = C(K,L)/T(1,1)
            IERR = 0
            GO TO 90
C
   50       T(1,1) = A(K,K) + A(L,L)
            T(1,2) = A(KK,K)
            T(2,1) = A(K,KK)
            T(2,2) = A(KK,KK) + A(L,L)
            P(1) = C(K,L)
            P(2) = C(KK,L)
            CALL SLV (2, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(KK,L) = P(2)
            GO TO 90
C
   60       IF (DK .EQ. 2) GO TO 70
            T(1,1) = A(K,K) + A(L,L)
            T(1,2) = A(LL,L)
            T(2,1) = A(L,LL)
            T(2,2) = A(K,K) + A(LL,LL)
            P(1) = C(K,L)
            P(2) = C(K,LL)
            CALL SLV (2, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(K,LL) = P(2)
            GO TO 90
C
   70       IF (K .NE. L) GO TO 80
            T(1,1) = A(L,L)
            T(1,2) = A(LL,L)
            T(1,3) = 0.0
            T(2,1) = A(L,LL)
            T(2,2) = A(L,L) + A(LL,LL)
            T(2,3) = T(1,2)
            T(3,1) = 0.0
            T(3,2) = T(2,1)
            T(3,3) = A(LL,LL)
            P(1) = C(L,L)/2.0
            P(2) = C(LL,L)
            P(3) = C(LL,LL)/2.0
            CALL SLV (3, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(L,L) = P(1)
            C(LL,L) = P(2)
            C(L,LL) = P(2)
            C(LL,LL) = P(3)
            GO TO 90
C
   80       T(1,1) = A(K,K) + A(L,L)
            T(1,2) = A(KK,K)
            T(1,3) = A(LL,L)
            T(1,4) = 0.0
            T(2,1) = A(K,KK)
            T(2,2) = A(KK,KK) + A(L,L)
            T(2,3) = 0.0
            T(2,4) = T(1,3)
            T(3,1) = A(L,LL)
            T(3,2) = 0.0
            T(3,3) = A(K,K) + A(LL,LL)
            T(3,4) = T(1,2)
            T(4,1) = 0.0
            T(4,2) = T(3,1)
            T(4,3) = T(2,1)
            T(4,4) = A(KK,KK) + A(LL,LL)
            P(1) = C(K,L)
            P(2) = C(KK,L)
            P(3) = C(K,LL)
            P(4) = C(KK,LL)
            CALL SLV (4, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(KK,L) = P(2)
            C(K,LL) = P(3)
            C(KK,LL) = P(4)
C
   90    K = K + DK
         IF (K .LE. N) GO TO 30
      LDL = L + DL
      IF (LDL .GT. N) RETURN
C
      DO 121 J = LDL,N
         DO 100 I = L,LL
            C(I,J) = C(J,I)
  100    CONTINUE
         DO 120 I = J,N
            DO 110 K = L,LL
  110       C(I,J) = C(I,J) - C(I,K)*A(K,J) - A(K,I)*C(K,J)
  120    C(J,I) = C(I,J)
  121 CONTINUE
      L = LDL
      GO TO 10
C
C     ERROR RETURN
C
  200 IERR = 1
      RETURN
      END
      SUBROUTINE DTASLV (MO,N,A,NA,C,NC,WK,IERR)
      DOUBLE PRECISION A(NA,N), C(NC,N), WK(*)
C ----------------------------------------------------------------------
C     DTASLV SOLVES THE REAL MATRIX EQUATION TRANSPOSE(A)*X + X*A = C
C     WHERE C IS A SYMMETRIC MATRIX. A IS REDUCED TO UPPER SCHUR FORM
C     AND THE TRANSFORMED SYSTEM IS SOLVED.
C ----------------------------------------------------------------------
C        MO IS AN INPUT ARGUMENT WHICH SPECIFIES IF THE ROUTINE IS
C     BEING CALLED FOR THE FIRST TIME. ON AN INITIAL CALL MO = 0 AND
C     WE HAVE THE FOLLOWING SETUP.
C
C        A(NA,N)
C           A IS A MATRIX OF ORDER N. IT IS ASSUMED THAT
C           NA .GE. N .GE. 1.
C
C        C(NC,N)
C           C IS A SYMMETRIC MATRIX OF ORDER N. IT IS
C           ASSUMED THAT NC .GE. N.
C
C        WK(---)
C           WK IS AN ARRAY OF DIMENSION N**2 + 2N THAT
C           IS A GENERAL STORAGE AREA FOR THE ROUTINE.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN
C     THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING VALUES...
C
C        IERR =  0  THE SOLUTION WAS OBTAINED AND STORED IN C.
C        IERR =  1  THE EQUATIONS ARE INCONSISTENT FOR A. THE
C                   PROBLEM CANNOT BE SOLVED.
C        IERR = -1  A COULD NOT BE REDUCEDTO UPPER SCHUR FORM.
C                   THE PROBLEM CANNOT BE SOLVED.
C
C     WHEN IERR = 0, A CONTAINS THE UPPER SCHUR FORM OF THE MATRIX
C     A AND WK CONTAINS THE ORTHOGONAL MATRIX INVOLVED IN THE SCHUR
C     DECOMPOSITION OF A. THIS INFORMATION CAN BE REUSED TO SOLVE A
C     NEW SET OF EQUATIONS TRANSPOSE(A)*X + X*A = C WITHOUT HAVING
C     TO REDECOMPOSE A. IN THIS CASE, THE INPUT ARGUMENT MO MAY BE
C     SET TO ANY NONZERO VALUE. WHEN MO .NE. 0, IT IS ASSUMED THAT
C     ONLY C HAS BEEN MODIFIED. ON OUTPUT THE SOLUTION FOR THE NEW
C     SET OF EQUATIONS IS STORED IN C.
C ----------------------------------------------------------------------
C     THIS SUBROUTINE IS A MODIFICATION BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C     OF THE SUBROUTINE ATXPXA WRITTEN BY
C        R.H. BARTELS AND G.W. STEWART
C        UNIVERSITY OF TEXAS AT AUSTIN.
C
C     REFERENCE. BARTELS, R.H. AND STEWART, G.W., ALGORITHM 432,
C        SOLUTION OF THE MATRIX EQUATION AX + XB = C, COMM. ACM
C        15 (1972), PP. 820-826.
C ----------------------------------------------------------------------
      IW = N*N + 1
      CALL DTASV1 (MO,N,A,NA,WK(1),N,C,NC,WK(IW),IERR)
      RETURN
      END
      SUBROUTINE DTASV1 (MO,N,A,NA,U,NU,C,NC,WK,IERR)
C ----------------------------------------------------------------------
C     DTASV1 SOLVES THE REAL MATRIX EQUATION TRANSPOSE(A)*X + X*A = C
C     WHERE C IS A SYMMETRIC MATRIX. A IS REDUCED TO UPPER SCHUR FORM
C     AND THE TRANSFORMED SYSTEM IS SOLVED.
C ----------------------------------------------------------------------
      DOUBLE PRECISION A(NA,N), U(NU,N), C(NC,N), WK(*)
C
C    IF REQUIRED, REDUCE A TO UPPER REAL SCHUR FORM
C
      IF (MO .NE. 0) GO TO 10
      CALL DORTH (NA,N,1,N,A,WK)
      CALL DRTRN1 (N,1,N,A,NA,U,NU,WK)
      CALL DSCHUR (N,1,N,A,NA,U,NU,WK(1),WK(N+1),IERR)
      IF (IERR .NE. 0) GO TO 200
C
C     TRANSFORM C
C
   10 DO 20 I = 1,N
         C(I,I) = C(I,I)/2.D0
   20 CONTINUE
C
      DO 41 I = 1,N
         DO 31 J = 1,N
            WK(J) = 0.D0
            DO 30 K = I,N
               WK(J) = WK(J) + C(I,K)*U(K,J)
   30       CONTINUE
   31    CONTINUE
         DO 40 J = 1,N
            C(I,J) = WK(J)
   40    CONTINUE
   41 CONTINUE
C
      DO 61 J = 1,N
         DO 51 I = 1,N
            WK(I) = 0.D0
            DO 50 K = 1,N
               WK(I) = WK(I) + U(K,I)*C(K,J)
   50       CONTINUE
   51    CONTINUE
         DO 60 I = 1,N
            C(I,J) = WK(I)
   60    CONTINUE
   61 CONTINUE
C
      DO 71 I = 1,N
         DO 70 J = I,N
            C(I,J) = C(I,J) + C(J,I)
            C(J,I) = C(I,J)
   70    CONTINUE
   71 CONTINUE
C
C     SOLVE THE TRANSFORMED SYSTEM
C
      CALL DSYMSV (A,C,N,NA,NC,IERR)
      IF (IERR .NE. 0) GO TO 210
C
C     TRANSFORM C BACK TO THE SOLUTION
C
      DO 80 I = 1,N
         C(I,I) = C(I,I)/2.D0
   80 CONTINUE
C
      DO 101 I = 1,N
         DO 91 J = 1,N
            WK(J) = 0.D0
            DO 90 K = I,N
               WK(J) = WK(J) + C(I,K)*U(J,K)
   90       CONTINUE
   91    CONTINUE
         DO 100 J = 1,N
            C(I,J) = WK(J)
  100    CONTINUE
  101 CONTINUE
C
      DO 121 J = 1,N
         DO 111 I = 1,N
            WK(I) = 0.D0
            DO 110 K = 1,N
               WK(I) = WK(I) + U(I,K)*C(K,J)
  110       CONTINUE
  111    CONTINUE
         DO 120 I = 1,N
            C(I,J) = WK(I)
  120    CONTINUE
  121 CONTINUE
C
      DO 131 I = 1,N
         DO 130 J = I,N
            C(I,J) = C(I,J) + C(J,I)
            C(J,I) = C(I,J)
  130    CONTINUE
  131 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = -1
      RETURN
  210 IERR = 1
      RETURN
      END
      SUBROUTINE DSYMSV (A,C,N,NA,NC,IERR)
C ----------------------------------------------------------------------
C     DSYMSV SOLVES THE MATRIX EQUATION TRANSPOSE(A)*X + X*A = C
C     WHERE A IS IN UPPER SCHUR FORM AND C IS SYMMETRIC.
C ----------------------------------------------------------------------
      INTEGER N,NA,NC,IERR
      DOUBLE PRECISION A(NA,N), C(NC,N), SUM, P(4), T(4,4)
      INTEGER DK,DL,I,IA,J,K,KK,KM1,L,LL,LDL
C
      L = 1
   10    DL = 1
         IF (L .EQ. N) GO TO 20
         IF (A(L+1,L) .NE. 0.D0) DL = 2
   20    LL = L + DL - 1
C
         K = L
   30       KM1 = K - 1
            DK = 1
            IF (K .EQ. N) GO TO 35
            IF (A(K+1,K) .NE. 0.D0) DK = 2
   35       KK = K + DK - 1
            IF (K .EQ. L) GO TO 45
C
            DO 42 I = K,KK
               DO 41 J = L,LL
               SUM = C(I,J)
                  DO 40 IA = L,KM1
   40             SUM = SUM - A(IA,I)*C(IA,J)
   41          C(I,J) = SUM
   42       CONTINUE
C
   45       IF (DL .EQ. 2) GO TO 60
            IF (DK .EQ. 2 ) GO TO 50
            T(1,1) = A(K,K) + A(L,L)
            IF (T(1,1) .EQ. 0.D0) GO TO 200
            C(K,L) = C(K,L)/T(1,1)
            IERR = 0
            GO TO 90
C
   50       T(1,1) = A(K,K) + A(L,L)
            T(1,2) = A(KK,K)
            T(2,1) = A(K,KK)
            T(2,2) = A(KK,KK) + A(L,L)
            P(1) = C(K,L)
            P(2) = C(KK,L)
            CALL DPSLV (2, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(KK,L) = P(2)
            GO TO 90
C
   60       IF (DK .EQ. 2) GO TO 70
            T(1,1) = A(K,K) + A(L,L)
            T(1,2) = A(LL,L)
            T(2,1) = A(L,LL)
            T(2,2) = A(K,K) + A(LL,LL)
            P(1) = C(K,L)
            P(2) = C(K,LL)
            CALL DPSLV (2, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(K,LL) = P(2)
            GO TO 90
C
   70       IF (K .NE. L) GO TO 80
            T(1,1) = A(L,L)
            T(1,2) = A(LL,L)
            T(1,3) = 0.D0
            T(2,1) = A(L,LL)
            T(2,2) = A(L,L) + A(LL,LL)
            T(2,3) = T(1,2)
            T(3,1) = 0.D0
            T(3,2) = T(2,1)
            T(3,3) = A(LL,LL)
            P(1) = C(L,L)/2.D0
            P(2) = C(LL,L)
            P(3) = C(LL,LL)/2.D0
            CALL DPSLV (3, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(L,L) = P(1)
            C(LL,L) = P(2)
            C(L,LL) = P(2)
            C(LL,LL) = P(3)
            GO TO 90
C
   80       T(1,1) = A(K,K) + A(L,L)
            T(1,2) = A(KK,K)
            T(1,3) = A(LL,L)
            T(1,4) = 0.D0
            T(2,1) = A(K,KK)
            T(2,2) = A(KK,KK) + A(L,L)
            T(2,3) = 0.D0
            T(2,4) = T(1,3)
            T(3,1) = A(L,LL)
            T(3,2) = 0.D0
            T(3,3) = A(K,K) + A(LL,LL)
            T(3,4) = T(1,2)
            T(4,1) = 0.D0
            T(4,2) = T(3,1)
            T(4,3) = T(2,1)
            T(4,4) = A(KK,KK) + A(LL,LL)
            P(1) = C(K,L)
            P(2) = C(KK,L)
            P(3) = C(K,LL)
            P(4) = C(KK,LL)
            CALL DPSLV (4, 1, T, 4, P, 4, IERR)
            IF (IERR .NE. 0) GO TO 200
            C(K,L) = P(1)
            C(KK,L) = P(2)
            C(K,LL) = P(3)
            C(KK,LL) = P(4)
C
   90    K = K + DK
         IF (K .LE. N) GO TO 30
      LDL = L + DL
      IF (LDL .GT. N) RETURN
C
      DO 121 J = LDL,N
         DO 100 I = L,LL
            C(I,J) = C(J,I)
  100    CONTINUE
         DO 120 I = J,N
            DO 110 K = L,LL
  110       C(I,J) = C(I,J) - C(I,K)*A(K,J) - A(K,I)*C(K,J)
  120    C(J,I) = C(I,J)
  121 CONTINUE
      L = LDL
      GO TO 10
C
C     ERROR RETURN
C
  200 IERR = 1
      RETURN
      END
      SUBROUTINE SQUINT(NM, N, A, B, C, IGUESS, S, WORK, NW, TOL,
     * MAXITS, IERR)
C
C
C     SUBROUTINE SQUINT BREAKS DOWN THE WORK ARRAY  WORK  INTO
C     SMALLER PIECES.  THE ACTUAL SOLUTION TO AX**2 + BX + C = 0 IS
C     DONE IN SUBROUTINE SQUIN2.  THIS SUBROUTINE MERELY RELIEVES
C     THE USER FROM A LONG CALLING SEQUENCE.
C
C
C     ON ENTRY,
C
C     NM     IS THE LEADING DIMENSION OF ALL THE MATRICES
C            IN THE CALLING PROGRAM.
C
C     N      IS THE ORDER OF THE MATRICES A, B AND C.
C
C     A      IS THE MATRIX COEFFICIENT OF X**2.
C
C     B      IS THE MATRIX COEFFICIENT OF X.
C
C     C      IS THE CONSTANT MATRIX.
C
C     IGUESS IS AN INTEGER. IF IGUESS.NE.0, THE USER SUPPLIES AN
C            INITIAL GUESS AT A SOLVENT.  THIS GUESS IS STORED IN
C            ARRAY S.  IF IGUESS.EQ.0, THE SUBROUTINE PROVIDES ITS
C            OWN INITIAL GUESS.
C
C     S      CONTAINS THE USERS INITIAL GUESS AT A SOLVENT, IF IGUESS
C            HAS BEEN SET TO A NONZERO QUANTITY.  OTHERWISE THE INPUT
C            CONTENTS IN S ARE IGNORED.
C
C     WORK   IS A WORK VECTOR.  IT MUST BE DIMENSIONED AT LEAST
C            (7N**2 + N), WHERE N IS THE ORDER OF A, B, C AND S.
C
C     NW     IS THE DIMENSION OF THE ARRAY WORK IN THE CALLING
C            PROGRAM.
C
C     TOL    IS A USER-SUPPLIED ACCURACY TOLERANCE.  SETTING TOL = 0.0
C            CAUSES ITERATION TO PROCEED UNTIL FULL MACHINE PRECISION
C            IS ATTAINED.  OTHERWISE, EXECUTION TERMINATES WHEN
C            NORM(AS**2+BS+C).LT.TOL.
C
C     MAXITS IS AN INTEGER.  IF MAXITS.NE.0, THE USER SPECIFIES THE
C            MOST INTERATIONS THE ALGORITHM IS TO TAKE.  IF MAXITS.
C            .LE.0, IT IS RESET TO 30.
C
C
C     ON RETURN,
C
C     A,B,C  ARE DESTROYED.
C
C     IGUESS CONTAINS THE NUMBER OF ITERATIONS PERFORMED TO
C            COMPUTE S.
C
C     S      CONTAINS THE RIGHT SOLVENT.
C
C     WORK(1) IS A COMPLEX NUMBER WITH REAL PART EQUAL TO THE NORM
C            OF AS**2+BS+C.
C
C     IERR   IS AN INTEGER ERROR RETURN.
C
C            IERR = 0 FOR A NORMAL RETURN.
C
C            IERR = 1 INDICATES FAILURE OF SQUINT TO CONVERGE TO
C                     A SOLVENT IN THE MAXIMUM NUMBER OF ITERATIONS.
C
C            IERR = 2 INDICATES FAILURE IN THE UPPER REDUCTION IN
C                     CQZIT.
C
C            IERR = 3 INDICATES FAILURE IN THE LOWER REDUCTION IN
C                     CQZIT.
C
C            IERR = 10 + N  INDICATES AN ERROR RETURN FROM TRISLV
C                     ON ITERATION N, DESIGNATING INCONSISTENCY OF
C                     THE TRIANGULAR SYSTEM.
C
C            IERR = 999 INDICATES IMPROPER DIMENSIONING.  THE
C                     CONDITIONS  NM.GE.N.GT.0   AND
C                     NW.GE.(7*N*N + N) MUST HOLD.
C
      INTEGER NM, N, IGUESS, NW, MAXITS, IERR, I1, I2, I3, I4, I5, I6,
     * I7
      COMPLEX WORK(NW)
      COMPLEX A(NM,N), B(NM,N), C(NM,N), S(NM,N)
      REAL TOL
      I1 = N*N + 1
      I2 = N*N + I1
      I3 = N*N + I2
      I4 = N*N + I3
      I5 = N*N + I4
      I6 = N*N + I5
      I7 = N*N + I6
      CALL SQUIN2(NM, N, A, B, C, IGUESS, S, WORK(1), WORK(I1),
     * WORK(I2), WORK(I3), WORK(I4), WORK(I5), WORK(I6), WORK(I7), NW,
     * TOL, MAXITS, IERR)
      RETURN
      END
      SUBROUTINE SQUIN2(NM, N, A, B, C, IGUESS, S, L, U, V, Z, R, XOLD,
     * EYE, TEMP, NW, TOL, MAXITS, IERR)
C
C     SUBROUTINE SQUIN2 FINDS A RIGHT SOLVENT OF THE MATRIX
C     EQUATION AX**2 + BX + C = 0.
C
C     ON ENTRY,
C
C     NM     IS THE LEADING DIMENSION OF ALL THE MATRICES IN
C            THE CALLING PROGRAM.
C
C     N      IS THE ORDER OF THE MATRICES A, B AND C.
C
C     A      IS THE MATRIX COEFFICIENT OF X**2.
C
C     B      IS THE MATRIX COEFFICIENT OF X.
C
C     C      IS THE CONSTANT MATRIX.
C
C     IGUESS IS AN INTEGER SET IN THE CALL TO SQUINT.
C
C     S      IS A MATRIX SET IN THE CALL TO SQUINT.
C
C     NW, TOL, AND MAXITS ARE INTEGER AND REAL PARAMETERS SET IN
C            THE CALL TO SQUINT.
C
C
C     THE FOLLOWING ARE INTERNAL VARIABLES ...
C
C
C     L      IS A MATRIX CONTAINING THE ITERATE X(I) FOR
C            REDUCTION TO LOWER TRIANGULAR FORM.
C
C     U      IS A MATRIX CONTAINING AX(I) + B FOR REDUCTION
C            TO UPPER TRIANGULAR FORM.
C
C     V      IS A MATRIX CONTAINING A FOR REDUCTION TO UPPER
C            TRIANGULAR FORM.
C
C     Z,R    ARE MATRICES CONTAINING THE HISTORY OF THE
C            TRANSFORMATIONS IN THE REDUCTIONS.
C
C     XOLD   IS A MATRIX HOLDING THE CURRENT ITERATE X(I).
C
C     EYE    CONTAINS AN IDENTITY MATRIX FOR THE LOWER REDUCTION
C            STEP.
C
C     TEMP   IS A WORK VECTOR.
C
C
C     ON RETURN,
C
C     A, B, C, IGUESS, S AND IERR HAVE THE SAME PROPERTIES AS
C            DESCRIBED IN THE RETURN FROM SUBROUTINE SQUINT.
C
C     L(1,1) IS A COMPLEX NUMBER WITH REAL PART EQUAL TO THE NORM
C            OF AS**2+BS+C.
C
C
      INTEGER NM, N, IGUESS, NW, MAXITS, IERR
      INTEGER ITS, MATS, I, J, K
      COMPLEX A(NM,N), B(NM,N), C(NM,N), S(NM,N), L(NM,N), U(NM,N)
      COMPLEX V(NM,N), Z(NM,N), R(NM,N), XOLD(NM,N), EYE(NM,N), TEMP(N)
      REAL ANORM, ANI, BNORM, BNI, CNORM, CNI, XNORM, XNI
      REAL FXNORM, FXNI, GNORM, TNORM, T, TOL
C     REAL SQRT, CABS, FLOAT
C     COMPLEX CMPLX, CONJG
      K = 7*N*N + N
      IF (NW.LT.K) GO TO 460
      IF (NM.LT.N) GO TO 460
      IF (N.LE.0) GO TO 460
      IF (MAXITS.LE.0) MAXITS = 30
C     ********** INITIALIZE ARRAYS **********
      DO 20 I=1,N
        DO 10 J=1,N
          L(I,J) = CMPLX(0.0,0.0)
          U(I,J) = CMPLX(0.0,0.0)
          V(I,J) = CMPLX(0.0,0.0)
          Z(I,J) = CMPLX(0.0,0.0)
          XOLD(I,J) = CMPLX(0.0,0.0)
          EYE(I,J) = CMPLX(0.0,0.0)
   10   CONTINUE
        TEMP(I) = CMPLX(0.0,0.0)
   20 CONTINUE
C     ********** SET INITIAL GUESS(ES) **********
      ANORM = 0.0
      BNORM = 0.0
      CNORM = 0.0
      DO 40 I=1,N
        ANI = 0.0
        BNI = 0.0
        CNI = 0.0
        DO 30 J=1,N
          ANI = ANI + CABS(A(I,J))
          BNI = BNI + CABS(B(I,J))
          CNI = CNI + CABS(C(I,J))
   30   CONTINUE
        IF (ANI.GT.ANORM) ANORM = ANI
        IF (BNI.GT.BNORM) BNORM = BNI
        IF (CNI.GT.CNORM) CNORM = CNI
   40 CONTINUE
      GNORM = (BNORM+SQRT(BNORM**2+4.0*ANORM*CNORM))/(2.0*ANORM)
      IF (IGUESS.EQ.0) GO TO 70
      DO 60 I=1,N
        DO 50 J=1,N
          XOLD(I,J) = S(I,J)
   50   CONTINUE
   60 CONTINUE
      GO TO 100
C
   70 DO 90 I=1,N
        DO 80 J=1,N
          XOLD(I,J) = CMPLX(0.0,0.0)
   80   CONTINUE
        XOLD(I,I) = CMPLX(GNORM,0.0)
   90 CONTINUE
C
  100 DO 360 ITS=1,MAXITS
        IF (ITS.NE.31) GO TO 130
        DO 120 I=1,N
          DO 110 J=1,N
            XOLD(I,J) = CMPLX(0.0,0.0)
  110     CONTINUE
          XOLD(I,I) = CMPLX(0.0,GNORM)
  120   CONTINUE
C
  130   IF (ITS.NE.61) GO TO 160
        DO 150 I=1,N
          DO 140 J=1,N
            XOLD(I,J) = C(I,J)
  140     CONTINUE
  150   CONTINUE
C        ********** SET UP U AND RIGHT HAND SIDE **********
  160   CALL CMPROD(N, N, N, A, NM, XOLD, NM, U, NM, U)
        DO 180 I=1,N
          DO 170 J=1,N
            U(I,J) = U(I,J) + B(I,J)
  170     CONTINUE
  180   CONTINUE
        CALL CMPROD(N, N, N, U, NM, XOLD, NM, S, NM, S)
        DO 200 I=1,N
          DO 190 J=1,N
            S(I,J) = S(I,J) + C(I,J)
  190     CONTINUE
  200   CONTINUE
C        ********** CHECK FOR CONVERGENCE **********
        XNORM = 0.0
        FXNORM = 0.0
        DO 220 I=1,N
          XNI = 0.0
          FXNI = 0.0
          DO 210 J=1,N
            XNI = XNI + CABS(XOLD(I,J))
            FXNI = FXNI + CABS(S(I,J))
  210     CONTINUE
          IF (XNI.GT.XNORM) XNORM = XNI
          IF (FXNI.GT.FXNORM) FXNORM = FXNI
  220   CONTINUE
        IF (TOL.LE.0.0) GO TO 230
        IF (FXNORM.LT.TOL) GO TO 370
  230   TNORM = 8.0*FLOAT(N)*ANORM*XNORM**2 + 5.0*FLOAT(N)*BNORM*XNORM
     *   + CNORM
        T = 1.0 + FXNORM/TNORM
        IF (T.EQ.1.0) GO TO 370
        IF (ITS.GE.MAXITS) GO TO 400
C        ********** UPPER TRIANGULARIZATION **********
        IF (ITS.NE.1) GO TO 240
        MATS = 1
        CALL CQZHES(NM, N, U, A, MATS, Z, S, B, C)
  240   DO 260 I=1,N
          DO 250 J=1,N
            V(I,J) = A(I,J)
            L(I,J) = CONJG(XOLD(J,I))
            EYE(I,J) = CMPLX(0.0,0.0)
  250     CONTINUE
          EYE(I,I) = CMPLX(1.0,0.0)
  260   CONTINUE
        IF (ITS.EQ.1) GO TO 270
        MATS = 2
        CALL CQZHES(NM, N, U, V, MATS, Z, S, B, C)
  270   CALL CQZIT(NM, N, U, V, 0.0, MATS, Z, S, IERR)
        IF (IERR.NE.0) GO TO 430
C        ********** LOWER TRIANGULARIZATION **********
        MATS = 3
        CALL CQZHES(NM, N, L, EYE, MATS, R, S, B, C)
        CALL CQZIT(NM, N, L, EYE, 0.0, MATS, R, S, IERR)
        IF (IERR.NE.0) GO TO 440
        CALL CTRANS(NM, N, L)
C        ********** UPDATE S WITH R **********
        DO 310 I=1,N
          DO 280 J=1,N
            TEMP(J) = S(I,J)
            S(I,J) = CMPLX(0.0,0.0)
  280     CONTINUE
          DO 300 J=1,N
            DO 290 K=1,N
              S(I,J) = S(I,J) + TEMP(K)*R(K,J)
  290       CONTINUE
  300     CONTINUE
  310   CONTINUE
        DO 330 J=1,N
          DO 320 I=1,N
            L(I,J) = L(I,J)*EYE(J,J)
  320     CONTINUE
          EYE(J,J) = CMPLX(1.0,0.0)
  330   CONTINUE
C        ********** BACKSOLVE THE TRANSFORMED SYSTEM **********
        CALL TRISLV(NM, N, U, V, L, S, TEMP, IERR)
        IF (IERR.NE.0) GO TO 450
C        ********** TRANSLATE BACK TO THE SOLUTION **********
        CALL CMPROD(N, N, N, Z, NM, S, NM, L, NM, L)
        CALL CTRANS(NM, N, R)
        CALL CMPROD(N, N, N, L, NM, R, NM, S, NM, S)
        DO 350 I=1,N
          DO 340 J=1,N
            XOLD(I,J) = XOLD(I,J) - S(I,J)
  340     CONTINUE
  350   CONTINUE
  360 CONTINUE
C     ********** CONVERGENCE **********
  370 IGUESS = ITS - 1
      L(1,1) = CMPLX(FXNORM,0.0)
      DO 390 I=1,N
        DO 380 J=1,N
          S(I,J) = XOLD(I,J)
  380   CONTINUE
  390 CONTINUE
      IERR = 0
      RETURN
C     ********** ERROR RETURNS **********
  400 IERR = 1
      L(1,1) = CMPLX(FXNORM,0.0)
      DO 420 I=1,N
        DO 410 J=1,N
          S(I,J) = XOLD(I,J)
  410   CONTINUE
  420 CONTINUE
      RETURN
  430 IERR = 2
      RETURN
  440 IERR = 3
      RETURN
  450 IERR = ITS + 10
      RETURN
  460 IERR = 999
      RETURN
      END
      SUBROUTINE CQZHES(NM, N, A, B, MATS, Z, F, G, H)
C
C
C     SUBROUTINE CQZHES IS A MODIFICATION OF THE EISPACK SUBROUTINE
C     QZHES.  ALL OPERATIONS ARE PERFORMED IN COMPLEX ARITHMETIC,
C     AND THE LEFT TRANSFORMATIONS MAY ALSO BE APPLIED TO AUXILIARY
C     MATRICES F, G AND H.
C
C
C     ON ENTRY,
C
C     NM   IS THE LEADING DIMENSION OF THE MATRICES A AND B IN
C          THE MAIN PROGRAM.
C
C     N    IS THE ORDER OF THE MATRICES A AND B.
C
C     A    CONTAINS THE MATRIX TO BE REDUCED TO UPPER HESSENBERG
C          FORM.
C
C     B    CONTAINS THE MATRIX TO BE REDUCED TO UPPER TRAINGULAR
C          FORM.
C
C     MATS IS AN INTEGER INPUT VARIABLE.
C
C          IF MATS = 0, THE ACCUMULATION OF THE TRANSFORMATIONS
C             IS NOT DESIRED.
C
C          IF MATS = ANY OTHER NUMBER BUT 0, THE TRANSFORMATIONS
C             ARE ACCUMULATED.
C
C          IF MATS = 1, THE AUXILIARY MATRICES G AND H ARE UPDATED
C             WITH THE UNITARY MATRIX Q.
C
C          IF MATS = 2, MATRIX B IS ASSUMED UPPER TRIANGULAR.
C
C          IF MATS = 3, THE AUXILIARY MATRIX F IS NOT UPDATED
C             WITH THE UNITARY MATRIX Q.
C
C     F, G AND H ARE AUXILIARY MATRICES.
C
C
C     ON RETURN,
C
C     A    IS UPPER HESSENBERG.
C
C     B    IS UPPER TRIANGULAR.
C
C     Z    CONTAINS THE HISTORY OF THE TRANSFORMATIONS, IF DESIRED.
C
C     F, G AND H ARE UPDATED, IF DESIRED.
C
C
      INTEGER I, J, K, L, N, LB, L1, NM, NK1, NM1, NM2
      COMPLEX A(NM,N), B(NM,N), Z(NM,N)
      COMPLEX RR, T, U1, U2, V1, V2, RHO
      COMPLEX F(NM,N), TF, G(NM,N), TG, H(NM,N), TH
      REAL R, S
      INTEGER MATS
C     REAL SQRT, CABS
C     COMPLEX CMPLX, CONJG
      IF (MATS.EQ.0) GO TO 30
      DO 20 I=1,N
        DO 10 J=1,N
          Z(I,J) = CMPLX(0.0,0.0)
   10   CONTINUE
        Z(I,I) = CMPLX(1.0,0.0)
   20 CONTINUE
C     ********** REDUCE B TO UPPER TRIANGULAR FORM **********
   30 IF (N.LE.1) GO TO 260
      NM1 = N - 1
      IF (MATS.EQ.2) GO TO 140
      DO 130 L=1,NM1
        L1 = L + 1
        S = 0.0
        DO 40 I=L1,N
          S = S + CABS(B(I,L))
   40   CONTINUE
        IF (S.EQ.0.0) GO TO 130
        S = S + CABS(B(L,L))
        R = 0.0
        DO 50 I=L,N
          B(I,L) = B(I,L)/CMPLX(S,0.0)
          R = R + CABS(B(I,L))**2
   50   CONTINUE
        R = SQRT(R)
        RR = CMPLX(R,0.0)
        IF (CABS(B(L,L)).NE.0.0) RR = (B(L,L)/CABS(B(L,L)))*RR
        B(L,L) = B(L,L) + RR
        RHO = CONJG(RR)*B(L,L)
        DO 80 J=L1,N
          T = CMPLX(0.0,0.0)
          DO 60 I=L,N
            T = T + CONJG(B(I,L))*B(I,J)
   60     CONTINUE
          T = -T/RHO
          DO 70 I=L,N
            B(I,J) = B(I,J) + T*B(I,L)
   70     CONTINUE
   80   CONTINUE
        DO 110 J=1,N
          T = CMPLX(0.0,0.0)
          TF = CMPLX(0.0,0.0)
          TG = CMPLX(0.0,0.0)
          TH = CMPLX(0.0,0.0)
          DO 90 I=L,N
            T = T + CONJG(B(I,L))*A(I,J)
            IF (MATS.EQ.3) GO TO 90
            TF = TF + CONJG(B(I,L))*F(I,J)
            IF (MATS.NE.1) GO TO 90
            TG = TG + CONJG(B(I,L))*G(I,J)
            TH = TH + CONJG(B(I,L))*H(I,J)
   90     CONTINUE
          T = -T/RHO
          TF = -TF/RHO
          TG = -TG/RHO
          TH = -TH/RHO
          DO 100 I=L,N
            A(I,J) = A(I,J) + T*B(I,L)
            IF (MATS.EQ.3) GO TO 100
            F(I,J) = F(I,J) + TF*B(I,L)
            IF (MATS.NE.1) GO TO 100
            G(I,J) = G(I,J) + TG*B(I,L)
            H(I,J) = H(I,J) + TH*B(I,L)
  100     CONTINUE
  110   CONTINUE
        B(L,L) = -CMPLX(S,0.0)*RR
        DO 120 I=L1,N
          B(I,L) = CMPLX(0.0,0.0)
  120   CONTINUE
  130 CONTINUE
C     ********** REDUCE A TO UPPER HESSENBERG FORM, WHILE
C                KEEPING B TRIANGULAR **********
  140 IF (N.EQ.2) GO TO 260
      NM2 = N - 2
      DO 250 K=1,NM2
        NK1 = NM1 - K
        DO 240 LB=1,NK1
          L = N - LB
          L1 = L + 1
C     ********** ZERO A(L+1,K) **********
          S = CABS(A(L,K)) + CABS(A(L1,K))
          IF (S.EQ.0.0) GO TO 240
          U1 = A(L,K)/CMPLX(S,0.0)
          U2 = A(L1,K)/CMPLX(S,0.0)
          R = SQRT(CABS(U1)**2+CABS(U2)**2)
          RR = CMPLX(R,0.0)
          IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR
          V1 = -(U1+RR)/RR
          V2 = -U2/RR
          U2 = V2/V1
          DO 150 J=K,N
            T = A(L,J) + CONJG(U2)*A(L1,J)
            A(L,J) = A(L,J) + T*V1
            A(L1,J) = A(L1,J) + T*V2
  150     CONTINUE
          A(L1,K) = CMPLX(0.0,0.0)
          DO 160 J=L,N
            T = B(L,J) + CONJG(U2)*B(L1,J)
            B(L,J) = B(L,J) + T*V1
            B(L1,J) = B(L1,J) + T*V2
  160     CONTINUE
          IF (MATS.EQ.3) GO TO 180
          DO 170 J=1,N
            TF = F(L,J) + CONJG(U2)*F(L1,J)
            F(L,J) = F(L,J) + TF*V1
            F(L1,J) = F(L1,J) + TF*V2
  170     CONTINUE
  180     IF (MATS.NE.1) GO TO 200
          DO 190 J=1,N
            TG = G(L,J) + CONJG(U2) + G(L1,J)
            TH = H(L,J) + CONJG(U2) + H(L1,J)
            G(L,J) = G(L,J) + TG*V1
            H(L,J) = H(L,J) + TH*V1
            G(L1,J) = G(L1,J) + TG*V2
            H(L1,J) = H(L1,J) + TH*V2
  190     CONTINUE
C     ********** ZERO B(L+1,L) **********
  200     S = CABS(B(L1,L1)) + CABS(B(L1,L))
          IF (S.EQ.0.0) GO TO 240
          U1 = B(L1,L1)/CMPLX(S,0.0)
          U2 = B(L1,L)/CMPLX(S,0.0)
          R = SQRT(CABS(U1)**2+CABS(U2)**2)
          RR = CMPLX(R,0.0)
          IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR
          V1 = -(U1+RR)/RR
          V2 = -U2/RR
          U2 = V2/V1
          DO 210 I=1,L1
            T = B(I,L1) + CONJG(U2)*B(I,L)
            B(I,L1) = B(I,L1) + T*V1
            B(I,L) = B(I,L) + T*V2
  210     CONTINUE
          B(L1,L) = CMPLX(0.0,0.0)
          DO 220 I=1,N
            T = A(I,L1) + CONJG(U2)*A(I,L)
            A(I,L1) = A(I,L1) + T*V1
            A(I,L) = A(I,L) + T*V2
  220     CONTINUE
          IF (MATS.EQ.0) GO TO 240
          DO 230 I=1,N
            T = Z(I,L1) + CONJG(U2)*Z(I,L)
            Z(I,L1) = Z(I,L1) + T*V1
            Z(I,L) = Z(I,L) + T*V2
  230     CONTINUE
  240   CONTINUE
  250 CONTINUE
  260 RETURN
      END
      SUBROUTINE CQZIT(NM, N, A, B, EPS1, MATS, Z, F, IERR)
C
C
C     SUBROUTINE CQZIT IS A MODIFICATION OF THE EISPACK SUBROUTINE
C     QZIT.  ALL OPERATIONS ARE PERFORMED IN COMPLEX ARITHMETIC,
C     AND THE LEFT TRANSFORMATIONS MAY ALSO BE APPLIED TO AN AUXILIARY
C     MATRIX F.
C
C
C     ON ENTRY,
C
C     NM   IS THE LEADING DIMENSION OF THE MATRICES A AND B IN
C          THE MAIN PROGRAM.
C
C     N    IS THE ORDER OF THE MATRICES A AND B.
C
C     A    CONTAINS AN UPPER HESSENBERG MATRIX FROM CQZHES.
C
C     B    CONTAINS AN UPPER TRIANGULAR MATRIX FROM CQZHES.
C
C     EPS1 IS A REAL NUMBER DEFINING THE TOLERANCE USED TO DETERMINE
C          NEGLIGIBLE ELEMENTS OF A AND B IN THE COURSE OF THE ALG-
C          ORITHM.  AN ELEMENT OF EITHER MATRIX WILL BE CONSIDERED
C          NEGLIGIBLE AND RESET TO ZERO IF IT IS NOT LARGER THAN THE
C          PRODUCT OF EPS1 AND THE NORM OF THE MATRIX.  IF EPS1.LE.0,
C          RELATIVE MACHINE PRECISION WILL BE COMPUTED AND
C          USED INSTEAD.
C
C     MATS IS AN INTEGER INPUT VARIABLE.  IT IS SET PRIOR
C          TO THE CALL TO CQZHES.
C
C     F    CONTAINS AN AUXILIARY MATRIX.
C
C
C     ON RETURN,
C
C     A    IS UPPER TRIANGULAR.
C
C     B    IS UPPER TRIANGULAR.
C
C     Z    CONTAINS THE HISTORY OF THE TRANSFORMATIONS, IF DESIRED.
C
C     F    CONTAINS THE AUXILIARY MATRIX, UPDATED IF DESIRED.
C
C     IERR IS AN INTEGER ERROR RETURN WHICH INDICATES FAILURE
C          OF THE QZ ALGORITHM TO REDUCE A SUBDIAGONAL ELEMENT
C          TO ZERO AFTER 50 ITERATIONS.
C
      INTEGER I, J, K, L, N, EN, JJ, K1, K2, LD, LL, L1, NA, NM, ISH,
     * ITS, KM1, LM1
      INTEGER ENM2, IERR, LOR1, ENORN
      COMPLEX A(NM,N), B(NM,N), Z(NM,N)
      COMPLEX A11, A21, A33, A34, A43, A44, B11, B22, B33, B34, B44
      COMPLEX A1, A2, U1, U2, V1, V2, T, RR, SH, SS
      COMPLEX F(NM,N), TF
      REAL EPS1, EPSA, EPSB, ANORM, BNORM, ANI, BNI, SRELPR, R, S
      INTEGER MATS
      REAL SPMPAR
C     INTEGER MAX0, MIN0
C     REAL SQRT, CABS
C     COMPLEX CMPLX, CONJG, CSQRT
      IERR = 0
C     ********** COMPUTE EPSA, EPSB **********
      ANORM = 0.0
      BNORM = 0.0
      DO 20 I=1,N
        ANI = 0.0
        IF (I.NE.1) ANI = CABS(A(I,I-1))
        BNI = 0.0
        DO 10 J=I,N
          ANI = ANI + CABS(A(I,J))
          BNI = BNI + CABS(B(I,J))
   10   CONTINUE
        IF (ANI.GT.ANORM) ANORM = ANI
        IF (BNI.GT.BNORM) BNORM = BNI
   20 CONTINUE
      IF (ANORM.EQ.0.0) ANORM = 1.0
      IF (BNORM.EQ.0.0) BNORM = 1.0
      SRELPR = EPS1
      IF (SRELPR.GT.0.0) GO TO 40
C
C     ***** WHEN EPS1 = 0 THEN SET SRELPR TO BE THE SMALLEST
C           NUMBER FOR WHICH 1 + SRELPR .GT. 1 *****
C
      SRELPR = SPMPAR(1)
C
   40 EPSA = SRELPR*ANORM
      EPSB = SRELPR*BNORM
C     ********** REDUCE A TO TRIANGULAR FORM, WHILE
C                KEEPING B TRIANGULAR **********
      LOR1 = 1
      ENORN = N
      EN = N
C     ********** BEGIN QZ STEP **********
   50 IF (EN.LE.1) GO TO 220
      IF (MATS.EQ.0) ENORN = EN
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
   60 ISH = 1
C     ********** CHECK FOR CONVERGENCE OR REDUCIBILITY **********
      DO 70 LL=1,EN
        LM1 = EN - LL
        L = LM1 + 1
        IF (L.EQ.1) GO TO 90
        IF (CABS(A(L,LM1)).LE.EPSA) GO TO 80
   70 CONTINUE
   80 A(L,LM1) = CMPLX(0.0,0.0)
      IF (L.LT.NA) GO TO 90
C     ********** 1-BY-1 BLOCK ISOLATED **********
      EN = LM1
      GO TO 50
C     ********** CHECK FOR SMALL TOP OF B **********
   90 LD = L
      L1 = L + 1
      B11 = B(L,L)
      IF (CABS(B11).GT.EPSB) GO TO 120
      B(L,L) = CMPLX(0.0,0.0)
      S = CABS(A(L,L)) + CABS(A(L1,L))
      U1 = A(L,L)/CMPLX(S,0.0)
      U2 = A(L1,L)/CMPLX(S,0.0)
      R = SQRT(CABS(U1)**2+CABS(U2)**2)
      RR = CMPLX(R,0.0)
      IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR
      V1 = -(U1+RR)/RR
      V2 = -U2/RR
      U2 = V2/V1
      DO 110 J=L,ENORN
        T = A(L,J) + CONJG(U2)*A(L1,J)
        A(L,J) = A(L,J) + T*V1
        A(L1,J) = A(L1,J) + T*V2
        T = B(L,J) + CONJG(U2)*B(L1,J)
        B(L,J) = B(L,J) + T*V1
        B(L1,J) = B(L1,J) + T*V2
        IF (MATS.EQ.3) GO TO 110
        DO 100 JJ=1,N
          TF = F(L,JJ) + CONJG(U2)*F(L1,JJ)
          F(L,JJ) = F(L,JJ) + TF*V1
          F(L1,JJ) = F(L1,JJ) + TF*V2
  100   CONTINUE
  110 CONTINUE
      IF (L.NE.1) A(L,LM1) = -A(L,LM1)
      LM1 = L
      L = L1
      GO TO 80
  120 A11 = A(L,L)/B11
      A21 = A(L1,L)/B11
C     ********** ITERATION STRATEGY **********
      IF (ITS.EQ.50) GO TO 210
C     ********** DETERMINE SHIFT **********
      B22 = B(L1,L1)
      IF (CABS(B22).LT.EPSB) B22 = CMPLX(EPSB,0.0)
      B33 = B(NA,NA)
      IF (CABS(B33).LT.EPSB) B33 = CMPLX(EPSB,0.0)
      B44 = B(EN,EN)
      IF (CABS(B44).LT.EPSB) B44 = CMPLX(EPSB,0.0)
      A33 = A(NA,NA)/B33
      A34 = A(NA,EN)/B44
      A43 = A(EN,NA)/B33
      A44 = A(EN,EN)/B44
      B34 = B(NA,EN)/B44
      T = CMPLX(0.5,0.0)*(A43*B34-A33-A44)
      RR = T*T + A34*A43 - A33*A44
C     ********** DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A **********
      RR = CSQRT(RR)
      SH = -T + RR
      SS = -T - RR
      IF (CABS(SS-A44).LT.CABS(SH-A44)) SH = SS
      A1 = A11 - SH
      A2 = A21
      IF (L.NE.LD) A(L,LM1) = -A(L,LM1)
      IF (ITS.NE.10) GO TO 130
      A1 = CMPLX(1.0,0.0)
      A2 = CMPLX(1.1605,0.0)
  130 ITS = ITS + 1
      IF (MATS.EQ.0) LOR1 = LD
C     ********** MAIN LOOP **********
      DO 200 K=L,NA
        K1 = K + 1
        K2 = K + 2
        KM1 = MAX0(K-1,L)
        LL = MIN0(EN,K1+ISH)
C     ********** ZERO A(K+1,K-1) **********
        IF (K.EQ.L) GO TO 140
        A1 = A(K,KM1)
        A2 = A(K1,KM1)
  140   S = CABS(A1) + CABS(A2)
        IF (S.EQ.0.0) GO TO 60
        U1 = A1/CMPLX(S,0.0)
        U2 = A2/CMPLX(S,0.0)
        R = SQRT(CABS(U1)**2+CABS(U2)**2)
        RR = CMPLX(R,0.0)
        IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR
        V1 = -(U1+RR)/RR
        V2 = -U2/RR
        U2 = V2/V1
        DO 150 J=KM1,ENORN
          T = A(K,J) + CONJG(U2)*A(K1,J)
          A(K,J) = A(K,J) + T*V1
          A(K1,J) = A(K1,J) + T*V2
          T = B(K,J) + CONJG(U2)*B(K1,J)
          B(K,J) = B(K,J) + T*V1
          B(K1,J) = B(K1,J) + T*V2
  150   CONTINUE
        IF (K.NE.L) A(K1,KM1) = CMPLX(0.0,0.0)
        IF (MATS.EQ.3) GO TO 170
        DO 160 J=1,N
          TF = F(K,J) + CONJG(U2)*F(K1,J)
          F(K,J) = F(K,J) + TF*V1
          F(K1,J) = F(K1,J) + TF*V2
  160   CONTINUE
C     ********** ZERO B(K+1,K) **********
  170   S = CABS(B(K1,K1)) + CABS(B(K1,K))
        IF (S.EQ.0.0) GO TO 200
        U1 = B(K1,K1)/CMPLX(S,0.0)
        U2 = B(K1,K)/CMPLX(S,0.0)
        R = SQRT(CABS(U1)**2+CABS(U2)**2)
        RR = CMPLX(R,0.0)
        IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR
        V1 = -(U1+RR)/RR
        V2 = -U2/RR
        U2 = V2/V1
        DO 180 I=LOR1,LL
          T = A(I,K1) + CONJG(U2)*A(I,K)
          A(I,K1) = A(I,K1) + T*V1
          A(I,K) = A(I,K) + T*V2
          T = B(I,K1) + CONJG(U2)*B(I,K)
          B(I,K1) = B(I,K1) + T*V1
          B(I,K) = B(I,K) + T*V2
  180   CONTINUE
        B(K1,K) = CMPLX(0.0,0.0)
        IF (MATS.EQ.0) GO TO 200
        DO 190 I=1,N
          T = Z(I,K1) + CONJG(U2)*Z(I,K)
          Z(I,K1) = Z(I,K1) + T*V1
          Z(I,K) = Z(I,K) + T*V2
  190   CONTINUE
  200 CONTINUE
C     ********** END QZ STEP **********
      GO TO 60
C     ********** SET ERROR -- NEITHER BOTTOM SUBDIAGONAL ELEMENT
C                HAS BECOME NEGLIGIBLE AFTER 50 ITERATIONS **********
  210 IERR = EN
C     ********** SAVE EPSB FOR USE BY CQZVEC **********
  220 IF (N.GT.1) B(N,1) = CMPLX(EPSB,0.0)
      RETURN
      END
      SUBROUTINE TRISLV(NM, N, U, V, L, F, TEMP, IERR)
C
C
C     SUBROUTINE TRISLV BACKSOLVES A SYSTEM OF THE FORM
C     UY + VYL = F, WHERE U AND V ARE UPPER TRIANGULAR, AND
C     L IS LOWER TRIANGULAR.
C
C
C     ON ENTRY,
C
C     NM   IS THE LEADING DIMENSION OF THE MATRICES U, V, L AND F IN
C          THE MAIN PROGRAM.
C
C     N    IS THE ORDER OF THE MATRICES U, V, L AND F.
C
C     U    CONTAINS AN UPPER TRIANGULAR MATRIX.  IT IS THE LEFT
C          COEFFICIENT OF Y IN THE FIRST TERM IN UY + VYL.
C
C     V    CONTAINS AN UPPER TRIANGULAR MATRIX.  IT IS THE LEFT
C          COEFFICIENT OF Y IN THE SECOND TERM OF UY + VYL.
C
C     L    CONTAINS A LOWER TRIANGULAR MATRIX.  IT IS THE RIGHT
C          COEFFICIENT OF Y IN THE SECOND TERM OF UY + VYL.
C
C     F    CONTAINS THE RIGHT HAND SIDE OF UY + VYL = F.
C
C     TEMP CONTAINS A WORK VECTOR OF LENGTH AT LEAST N.
C
C     ON RETURN,
C
C     F    CONTAINS THE SOLUTION Y.
C
C     IERR IS AN ERROR RETURN DESIGNATING INCONSISTENCY OF THE
C          ORIGINAL SYSTEM.
C          IERR.EQ.0 FOR A NORMAL RETURN.
C          IERR.EQ.1 IF THE TRIANGULAR SYSTEM IS INCONSISTENT.
C
C
      INTEGER I, IERR, J, JP1, K, KK, KM1, M, N, NM, NM1
      COMPLEX U(NM,N), V(NM,N), L(NM,N), F(NM,N)
      COMPLEX TEMP(N)
      COMPLEX DENOM, SUM
      REAL S, T
C     REAL CABS
C     COMPLEX CMPLX
      IERR = 0
      NM1 = N - 1
      DO 120 KK=1,N
C        ********** BACKSUBSTITUTE FOR ROW K. **********
        K = N - KK + 1
        IF (CABS(F(K,N)).NE.0.0) GO TO 10
        F(K,N) = CMPLX(0.0,0.0)
        GO TO 30
   10   DENOM = U(K,K) + V(K,K)*L(N,N)
        S = CABS(DENOM)
        T = 1.0 + S/CABS(F(K,N))
        IF (T.GT.1.0) GO TO 20
        IERR = 1
        RETURN
   20   F(K,N) = F(K,N)/DENOM
        IF (N.EQ.1) RETURN
   30   DO 70 I=1,NM1
          J = N - I
          JP1 = J + 1
          SUM = CMPLX(0.0,0.0)
          DO 40 M=JP1,N
            SUM = SUM + F(K,M)*L(M,J)
   40     CONTINUE
          SUM = F(K,J) - V(K,K)*SUM
          IF (CABS(SUM).NE.0.0) GO TO 50
          F(K,J) = CMPLX(0.0,0.0)
          GO TO 70
   50     DENOM = U(K,K) + V(K,K)*L(J,J)
          S = CABS(DENOM)
          T = 1.0 + S/CABS(SUM)
          IF (T.GT.1.0) GO TO 60
          IERR = 1
          RETURN
   60     F(K,J) = SUM/DENOM
   70   CONTINUE
C        ********** FORM TEMP = YK-TRANS*L. **********
        IF (K.EQ.1) RETURN
        KM1 = K - 1
        DO 90 I=1,N
          TEMP(I) = CMPLX(0.0,0.0)
          DO 80 J=1,N
            TEMP(I) = TEMP(I) + F(K,J)*L(J,I)
   80     CONTINUE
   90   CONTINUE
C        ********** PREPARE F' WHICH IS (K-1) BY N. **********
        DO 110 I=1,KM1
          DO 100 J=1,N
            F(I,J) = F(I,J) - U(I,K)*F(K,J) - V(I,K)*TEMP(J)
  100     CONTINUE
  110   CONTINUE
  120 CONTINUE
      RETURN
      END
      SUBROUTINE MEXP (A, KA, N, Z, KZ, WK, IERR)
      REAL A(KA,N),Z(KZ,N),WK(N,*),C(8)
C ----------------------------------------------------------------------
C     MEXP COMPUTES EXP(A) AND STORES IT IN Z WHERE A IS A MATRIX
C     OF ORDER N. A IS DESTROYED BY THE ROUTINE.
C
C     WK IS AN ARRAY OF DIMENSION (N,N+8). WK IS A WORK SPACE
C     FOR THE ROUTINE.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C        IERR = 0  EXP(A) WAS SUCCESSFULLY COMPUTED.
C        IERR = 1  THE NORM OF A IS TOO LARGE.
C        IERR = 2  THE PADE DENOMINATOR MATRIX IS
C                  SINGULAR.
C
C     WRITTEN BY ALFRED H. MORRIS
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN VIRGINIA
C     ---------------
C     COEFFICIENTS FOR (8,8) PADE TABLE ENTRY
C     ---------------
      DATA C(1)/.500000000000000E+00/, C(2)/.116666666666667E+00/,
     *     C(3)/.166666666666667E-01/, C(4)/.160256410256410E-02/,
     *     C(5)/.106837606837607E-03/, C(6)/.485625485625486E-05/,
     *     C(7)/.138750138750139E-06/, C(8)/.192708526041859E-08/
C ----------------------------------------------------------------------
      IERR = 0
      IF (N .GT. 1) GO TO 10
         Z(1,1) = EXP(A(1,1))
         RETURN
C
C       BALANCE A AND SELECT THE SMALLER OF THE 1-NORM
C              AND INFINITY-NORM OF THE RESULT
C
   10 CALL BALANC (KA,N,A,LOW,IGH,WK(1,N+8))
      ANORM = 0.0
      ANORM1 = 0.0
      DO 12 J = 1,N
      S = 0.0
      S1 = 0.0
         DO 11 I = 1,N
         S = S + ABS(A(J,I))
   11    S1 = S1 + ABS(A(I,J))
      ANORM = AMAX1(S,ANORM)
   12 ANORM1 = AMAX1(S1,ANORM1)
C
      ANORM = AMIN1(ANORM,ANORM1)
      S = ANORM + 0.1
      IF (S .EQ. ANORM) GO TO 200
C
C              SELECT THE NORMALIZATION FACTOR
C
      M = 0
      IF (ANORM .LE. 1.0)  GO TO 40
      FACTOR = 1.0
   20 M = M + 1
      FACTOR = 2.0*FACTOR
      IF (ANORM .GT. FACTOR) GO TO 20
C
C                NORMALIZE THE MATRIX A
C
      DO 31 J = 1,N
         DO 30 I = 1,N
   30    A(I,J) = A(I,J)/FACTOR
   31 CONTINUE
C
   40 NP1 = N + 1
      NP6 = N + 6
      DO 100 J = 1,N
C
C     COMPUTE THE J-TH COLUMN OF FIRST EIGHT POWERS OF A
C
         DO 51 I = 1,N
         S = 0.0
            DO 50 L = 1,N
   50       S = S + A(I,L)*A(L,J)
   51    WK(I,NP1) = S
C
         DO 70 K = NP1,NP6
         KP1 = K + 1
            DO 61 I = 1,N
            S = 0.0
               DO 60 L = 1,N
   60          S = S + A(I,L)*WK(L,K)
   61       WK(I,KP1) = S
   70    CONTINUE
C
C     COMPUTE THE J-TH COLUMN OF THE NUMERATOR AND DENOMINATOR
C                  OF THE PADE APPROXIMATION
C
         DO 90 I = 1,N
         P = 0.0
         Q = 0.0
         K = 8
         L = N + 7
            DO 80 LL = 1,7
            S = C(K)*WK(I,L)
            P = S + P
            Q = S - Q
            K = K - 1
   80       L = L - 1
         S = C(1)*A(I,J)
         Z(I,J) = P + S
         WK(I,J) = Q - S
         IF (I .NE. J) GO TO 90
            Z(I,J) = Z(I,J) + 1.0
            WK(I,J) = WK(I,J) + 1.0
   90    CONTINUE
  100 CONTINUE
C
C        CALCULATE EXP(A) BY SOLVING  WK * EXP(A) = Z
C
      CALL SLV (N, N, WK, N, Z, KZ, IERR)
      IF (IERR .NE. 0) GO TO 210
      IF (M .EQ. 0)  GO TO 150
C
C          TAKE OUT THE EFFECT OF THE NORMALIZATION
C                   OPERATION ON EXP(A)
C
      DO 140 K = 1,M
         DO 121 J = 1,N
            DO 120 I = 1,N
            S = 0.0
               DO 110 L = 1,N
  110          S = S + Z(I,L)*Z(L,J)
  120       WK(I,J) = S
  121    CONTINUE
C
         DO 131 J = 1,N
            DO 130 I = 1,N
  130       Z(I,J) = WK(I,J)
  131    CONTINUE
  140 CONTINUE
C
C            TAKE OUT THE EFFECT OF THE BALANCING
C                   OPERATION ON EXP(A)
C
  150 CALL BALINV (KZ,N,Z,LOW,IGH,WK(1,N+8))
      RETURN
C
C                     ERROR RETURN
C
  200 IERR = 1
      RETURN
  210 IERR = 2
      RETURN
      END
      SUBROUTINE DMEXP (A, KA, N, Z, KZ, WK, IERR)
      DOUBLE PRECISION A(KA,N),Z(KZ,N),WK(N,*)
      DOUBLE PRECISION ANORM,ANORM1,C(12),FACTOR,P,Q,S,S1
C ----------------------------------------------------------------------
C     DMEXP COMPUTES EXP(A) AND STORES IT IN Z WHERE A IS A MATRIX
C     OF ORDER N. A IS DESTROYED BY THE ROUTINE.
C
C     WK IS AN ARRAY OF DIMENSION (N,N+12). WK IS A WORK SPACE
C     FOR THE ROUTINE.
C
C     IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
C        IERR = 0  EXP(A) WAS SUCCESSFULLY COMPUTED.
C        IERR = 1  THE NORM OF A IS TOO LARGE.
C        IERR = 2  THE PADE DENOMINATOR MATRIX IS
C                  SINGULAR.
C
C     WRITTEN BY ALFRED H. MORRIS
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN VIRGINIA
C     ---------------
C     COEFFICIENTS FOR (12,12) PADE TABLE ENTRY
C     ---------------
      DATA C(1) /.500000000000000000000000000000D+00/,
     *     C(2) /.119565217391304347826086956522D+00/,
     *     C(3) /.181159420289855072463768115942D-01/,
     *     C(4) /.194099378881987577639751552795D-02/,
     *     C(5) /.155279503105590062111801242236D-03/,
     *     C(6) /.953470633104500381388253241800D-05/,
     *     C(7) /.454033634811666848280120591333D-06/,
     *     C(8) /.166924130445465753044161982108D-07/,
     *     C(9) /.463678140126293758456005505855D-09/
      DATA C(10)/.927356280252587516912011011710D-11/,
     *     C(11)/.120435880552284093105455975547D-12/,
     *     C(12)/.772024875335154442983692150941D-15/
C ----------------------------------------------------------------------
      IERR = 0
      IF (N .GT. 1) GO TO 10
         Z(1,1) = DEXP(A(1,1))
         RETURN
C
C       BALANCE A AND SELECT THE SMALLER OF THE 1-NORM
C              AND INFINITY-NORM OF THE RESULT
C
   10 CALL DBAL (KA,N,A,LOW,IGH,WK(1,N+12))
      ANORM = 0.D0
      ANORM1 = 0.D0
      DO 12 J = 1,N
      S = 0.D0
      S1 = 0.D0
         DO 11 I = 1,N
         S = S + DABS(A(J,I))
   11    S1 = S1 + DABS(A(I,J))
      ANORM = DMAX1(S,ANORM)
   12 ANORM1 = DMAX1(S1,ANORM1)
C
      ANORM = DMIN1(ANORM,ANORM1)
      S = ANORM + 0.1D0
      IF (S .EQ. ANORM) GO TO 200
C
C              SELECT THE NORMALIZATION FACTOR
C
      M = 0
      IF (ANORM .LE. 1.D0)  GO TO 40
      FACTOR = 1.D0
   20 M = M + 1
      FACTOR = 2.D0*FACTOR
      IF (ANORM .GT. FACTOR) GO TO 20
C
C                NORMALIZE THE MATRIX A
C
      DO 31 J = 1,N
         DO 30 I = 1,N
   30    A(I,J) = A(I,J)/FACTOR
   31 CONTINUE
C
   40 NP1 = N + 1
      NP10 = N + 10
      DO 100 J = 1,N
C
C     COMPUTE THE J-TH COLUMN OF THE FIRST 12 POWERS OF A
C
         DO 51 I = 1,N
         S = 0.D0
            DO 50 L = 1,N
   50       S = S + A(I,L)*A(L,J)
   51    WK(I,NP1) = S
C
         DO 70 K = NP1,NP10
         KP1 = K + 1
            DO 61 I = 1,N
            S = 0.D0
               DO 60 L = 1,N
   60          S = S + A(I,L)*WK(L,K)
   61       WK(I,KP1) = S
   70    CONTINUE
C
C     COMPUTE THE J-TH COLUMN OF THE NUMERATOR AND DENOMINATOR
C                  OF THE PADE APPROXIMATION
C
         DO 90 I = 1,N
         P = 0.D0
         Q = 0.D0
         K = 12
         L = N + 11
            DO 80 LL = 1,11
            S = C(K)*WK(I,L)
            P = S + P
            Q = S - Q
            K = K - 1
   80       L = L - 1
         S = C(1)*A(I,J)
         Z(I,J) = P + S
         WK(I,J) = Q - S
         IF (I .NE. J) GO TO 90
            Z(I,J) = Z(I,J) + 1.D0
            WK(I,J) = WK(I,J) + 1.D0
   90    CONTINUE
  100 CONTINUE
C
C        CALCULATE EXP(A) BY SOLVING  WK * EXP(A) = Z
C
      CALL DPSLV (N, N, WK, N, Z, KZ, IERR)
      IF (IERR .NE. 0) GO TO 210
      IF (M .EQ. 0)  GO TO 150
C
C          TAKE OUT THE EFFECT OF THE NORMALIZATION
C                   OPERATION ON EXP(A)
C
      DO 140 K = 1,M
         DO 121 J = 1,N
            DO 120 I = 1,N
            S = 0.D0
               DO 110 L = 1,N
  110          S = S + Z(I,L)*Z(L,J)
  120       WK(I,J) = S
  121    CONTINUE
C
         DO 131 J = 1,N
            DO 130 I = 1,N
  130       Z(I,J) = WK(I,J)
  131    CONTINUE
  140 CONTINUE
C
C            TAKE OUT THE EFFECT OF THE BALANCING
C                   OPERATION ON EXP(A)
C
  150 CALL DBALNV (KZ,N,Z,LOW,IGH,WK(1,N+12))
      RETURN
C
C                     ERROR RETURN
C
  200 IERR = 1
      RETURN
  210 IERR = 2
      RETURN
      END
      SUBROUTINE LE (ROWK,N,B,C,D,IP,IERR)
C     ******************************************************************
C     SOLUTION OF LINEAR EQUATIONS WITH REDUCED STORAGE
C     ******************************************************************
      REAL B(N),C(N),D(*)
      INTEGER IP(*)
      EXTERNAL ROWK
      DATA ZERO/0.0/
C
C     SET THE NECESSARY CONSTANTS
C
      IERR = 0
      NP1 = N + 1
      MAX = N*N/4 + N + 3
      K = 1
      IFLAG = -1
C
C     GET THE FIRST COLUMN OF THE TRANSPOSED SYSTEM
C
      CALL ROWK(N,1,C)
      BK = B(1)
C
      IF (N .GT. 1) GO TO 10
      IF (C(1) .EQ. ZERO) GO TO 200
      C(1) = BK/C(1)
      RETURN
C
C     FIND THE PIVOT FOR COLUMN 1
C
   10 M = 1
      DO 20 I = 2,N
      IF (ABS(C(M)) .LT. ABS(C(I))) M = I
   20 CONTINUE
C
      IP(1) = M
      C1 = C(M)
      C(M) = C(1)
      C(1) = C1
      IF (C(1) .EQ. ZERO) GO TO 200
C
C     FIND THE FIRST ELEMENTARY MATRIX AND STORE IT IN D
C
      DO 30 I = 2,N
   30 D(I-1) = -C(I)/C(1)
      D(N) = BK/C(1)
C
C     K LOOP - EACH K FOR A NEW COLUMN OF THE TRANSPOSED SYSTEM
C
      DO 120 K = 2,N
      KP1 = K + 1
      KM1 = K - 1
C
C       GET COLUMN K
C
      CALL ROWK(N,K,C)
      DO 40 J = 1,KM1
      M = IP(J)
      CJ = C(J)
      C(J) = C(M)
   40 C(M) = CJ
      BK = B(K)
C
      IFLAG = -IFLAG
      LCOL = NP1 - K
      LCOLP1 = LCOL + 1
      LASTM1 = 1
      LAST = MAX - N + K
      IF (K .EQ. 2) GO TO 50
C
      LASTM1 = MAX - N + KM1
      IF (IFLAG .LT. 0) LAST = LAST - N + K - 2
      IF (IFLAG .GT. 0) LASTM1 = LASTM1 - N + K - 3
C
C     J LOOP - EFFECT OF COLUMNS 1 TO K-1 OF L-INVERSE
C
   50 DO 61 J = 1,KM1
      CJ = C(J)
      IJ = (J-1)*LCOLP1
      IF (J .EQ. KM1) IJ = LASTM1 - 1
C
C     I LOOP - EFFECT OF L-INVERSE ON ROWS K TO N+1
C
      DO 60 I = K,N
      IJ = IJ + 1
   60 C(I) = C(I) + D(IJ)*CJ
   61 BK = BK - D(IJ+1)*CJ
C
C       K=N CASE
C
      M = K
      IF (K .LT. N) GO TO 70
      IF (C(K) .EQ. ZERO) GO TO 200
      D(LAST) = BK/C(K)
      GO TO 90
C
C     FIND THE PIVOT
C
   70 DO 71 I = KP1,N
      IF (ABS(C(M)) .LT. ABS(C(I))) M = I
   71 CONTINUE
C
      IP(K) = M
      CK = C(M)
      C(M) = C(K)
      C(K) = CK
      IF (C(K) .EQ. ZERO) GO TO 200
C
C     FIND THE K-TH ELEMENTARY MATRIX
C
      IK = LAST
      DO 80 I = KP1,N
      D(IK) = -C(I)/C(K)
   80 IK = IK + 1
      D(IK) = BK/C(K)
C
C     FORM THE PRODUCT OF THE ELEMENTARY MATRICES
C
   90 DO 110 J = 1,KM1
      KJOLD = J*LCOLP1 + K - NP1
      MJOLD = KJOLD + M - K
      IJ = (J-1)*LCOL
      IJOLD = IJ + J
      IF (J .NE. KM1) GO TO 100
C
      KJOLD = LASTM1
      MJOLD = LASTM1 + M - K
      IJOLD = LASTM1
C
  100 IK = LAST - 1
      DKJ = D(MJOLD)
      D(MJOLD) = D(KJOLD)
      DO 110 I = KP1,NP1
      IJ = IJ + 1
      IJOLD = IJOLD + 1
      IK = IK + 1
      D(IJ) = D(IJOLD) + D(IK)*DKJ
  110 CONTINUE
  120 CONTINUE
C
      LAST = MAX
      IF (IFLAG .LT. 0) LAST = MAX - 2
      D(N) = D(LAST)
C
C     INSERT THE SOLUTION IN C
C
      DO 130 I = 1,N
  130 C(I) = D(I)
C
      NM1 = N - 1
      DO 140 I = 1,NM1
      K = N - I
      M = IP(K)
      CK = C(K)
      C(K) = C(M)
  140 C(M) = CK
      RETURN
C
C     THE SYSTEM IS SINGULAR
C
  200 IERR = K
      RETURN
      END
      SUBROUTINE DPLE (ROWK,N,B,C,D,IP,IERR)
C     ******************************************************************
C     SOLUTION OF LINEAR EQUATIONS WITH REDUCED STORAGE
C     ******************************************************************
      DOUBLE PRECISION B(N),C(N),D(*)
      INTEGER IP(*)
      DOUBLE PRECISION BK,CJ,CK,C1,DKJ,ZERO
      EXTERNAL ROWK
      DATA ZERO/0.D0/
C
C     SET THE NECESSARY CONSTANTS
C
      IERR = 0
      NP1 = N + 1
      MAX = N*N/4 + N + 3
      K = 1
      IFLAG = -1
C
C     GET THE FIRST COLUMN OF THE TRANSPOSED SYSTEM
C
      CALL ROWK(N,1,C)
      BK = B(1)
C
      IF (N .GT. 1) GO TO 10
      IF (C(1) .EQ. ZERO) GO TO 200
      C(1) = BK/C(1)
      RETURN
C
C     FIND THE PIVOT FOR COLUMN 1
C
   10 M = 1
      DO 20 I = 2,N
      IF (DABS(C(M)) .LT. DABS(C(I))) M = I
   20 CONTINUE
C
      IP(1) = M
      C1 = C(M)
      C(M) = C(1)
      C(1) = C1
      IF (C(1) .EQ. ZERO) GO TO 200
C
C     FIND THE FIRST ELEMENTARY MATRIX AND STORE IT IN D
C
      DO 30 I = 2,N
   30 D(I-1) = -C(I)/C(1)
      D(N) = BK/C(1)
C
C     K LOOP - EACH K FOR A NEW COLUMN OF THE TRANSPOSED SYSTEM
C
      DO 120 K = 2,N
      KP1 = K + 1
      KM1 = K - 1
C
C       GET COLUMN K
C
      CALL ROWK(N,K,C)
      DO 40 J = 1,KM1
      M = IP(J)
      CJ = C(J)
      C(J) = C(M)
   40 C(M) = CJ
      BK = B(K)
C
      IFLAG = -IFLAG
      LCOL = NP1 - K
      LCOLP1 = LCOL + 1
      LASTM1 = 1
      LAST = MAX - N + K
      IF (K .EQ. 2) GO TO 50
C
      LASTM1 = MAX - N + KM1
      IF (IFLAG .LT. 0) LAST = LAST - N + K - 2
      IF (IFLAG .GT. 0) LASTM1 = LASTM1 - N + K - 3
C
C     J LOOP - EFFECT OF COLUMNS 1 TO K-1 OF L-INVERSE
C
   50 DO 61 J = 1,KM1
      CJ = C(J)
      IJ = (J-1)*LCOLP1
      IF (J .EQ. KM1) IJ = LASTM1 - 1
C
C     I LOOP - EFFECT OF L-INVERSE ON ROWS K TO N+1
C
      DO 60 I = K,N
      IJ = IJ + 1
   60 C(I) = C(I) + D(IJ)*CJ
   61 BK = BK - D(IJ+1)*CJ
C
C       K=N CASE
C
      M = K
      IF (K .LT. N) GO TO 70
      IF (C(K) .EQ. ZERO) GO TO 200
      D(LAST) = BK/C(K)
      GO TO 90
C
C     FIND THE PIVOT
C
   70 DO 71 I = KP1,N
      IF (DABS(C(M)) .LT. DABS(C(I))) M = I
   71 CONTINUE
C
      IP(K) = M
      CK = C(M)
      C(M) = C(K)
      C(K) = CK
      IF (C(K) .EQ. ZERO) GO TO 200
C
C     FIND THE K-TH ELEMENTARY MATRIX
C
      IK = LAST
      DO 80 I = KP1,N
      D(IK) = -C(I)/C(K)
   80 IK = IK + 1
      D(IK) = BK/C(K)
C
C     FORM THE PRODUCT OF THE ELEMENTARY MATRICES
C
   90 DO 110 J = 1,KM1
      KJOLD = J*LCOLP1 + K - NP1
      MJOLD = KJOLD + M - K
      IJ = (J-1)*LCOL
      IJOLD = IJ + J
      IF (J .NE. KM1) GO TO 100
C
      KJOLD = LASTM1
      MJOLD = LASTM1 + M - K
      IJOLD = LASTM1
C
  100 IK = LAST - 1
      DKJ = D(MJOLD)
      D(MJOLD) = D(KJOLD)
      DO 110 I = KP1,NP1
      IJ = IJ + 1
      IJOLD = IJOLD + 1
      IK = IK + 1
      D(IJ) = D(IJOLD) + D(IK)*DKJ
  110 CONTINUE
  120 CONTINUE
C
      LAST = MAX
      IF (IFLAG .LT. 0) LAST = MAX - 2
      D(N) = D(LAST)
C
C     INSERT THE SOLUTION IN C
C
      DO 130 I = 1,N
  130 C(I) = D(I)
C
      NM1 = N - 1
      DO 140 I = 1,NM1
      K = N - I
      M = IP(K)
      CK = C(K)
      C(K) = C(M)
  140 C(M) = CK
      RETURN
C
C     THE SYSTEM IS SINGULAR
C
  200 IERR = K
      RETURN
      END
      SUBROUTINE CLE (ROWK,N,B,C,D,IP,IERR)
C     ******************************************************************
C     SOLUTION OF COMPLEX LINEAR EQUATIONS WITH REDUCED STORAGE
C     ******************************************************************
      COMPLEX B(N),C(N),D(*)
      INTEGER IP(*)
      COMPLEX BK,CJ,CK,C1,DKJ,ZERO
      EXTERNAL ROWK
      DATA ZERO/(0.0,0.0)/
C
C     SET THE NECESSARY CONSTANTS
C
      IERR = 0
      NP1 = N + 1
      MAX = N*N/4 + N + 3
      K = 1
      IFLAG = -1
C
C     GET THE FIRST COLUMN OF THE TRANSPOSED SYSTEM
C
      CALL ROWK(N,1,C)
      BK = B(1)
C
      IF (N .GT. 1) GO TO 10
      IF (C(1) .EQ. ZERO) GO TO 200
      C(1) = BK/C(1)
      RETURN
C
C     FIND THE PIVOT FOR COLUMN 1
C
   10 M = 1
      S = ABS(REAL(C(1))) + ABS(AIMAG(C(1)))
      DO 20 I = 2,N
      SI = ABS(REAL(C(I))) + ABS(AIMAG(C(I)))
      IF (SI .LE. S) GO TO 20
      M = I
      S = SI
   20 CONTINUE
C
      IP(1) = M
      C1 = C(M)
      C(M) = C(1)
      C(1) = C1
      IF (C(1) .EQ. ZERO) GO TO 200
C
C     FIND THE FIRST ELEMENTARY MATRIX AND STORE IT IN D
C
      DO 30 I = 2,N
   30 D(I-1) = -C(I)/C(1)
      D(N) = BK/C(1)
C
C     K LOOP - EACH K FOR A NEW COLUMN OF THE TRANSPOSED SYSTEM
C
      DO 120 K = 2,N
      KP1 = K + 1
      KM1 = K - 1
C
C       GET COLUMN K
C
      CALL ROWK(N,K,C)
      DO 40 J = 1,KM1
      M = IP(J)
      CJ = C(J)
      C(J) = C(M)
   40 C(M) = CJ
      BK = B(K)
C
      IFLAG = -IFLAG
      LCOL = NP1 - K
      LCOLP1 = LCOL + 1
      LASTM1 = 1
      LAST = MAX - N + K
      IF (K .EQ. 2) GO TO 50
C
      LASTM1 = MAX - N + KM1
      IF (IFLAG .LT. 0) LAST = LAST - N + K - 2
      IF (IFLAG .GT. 0) LASTM1 = LASTM1 - N + K - 3
C
C     J LOOP - EFFECT OF COLUMNS 1 TO K-1 OF L-INVERSE
C
   50 DO 61 J = 1,KM1
      CJ = C(J)
      IJ = (J-1)*LCOLP1
      IF (J .EQ. KM1) IJ = LASTM1 - 1
C
C     I LOOP - EFFECT OF L-INVERSE ON ROWS K TO N+1
C
      DO 60 I = K,N
      IJ = IJ + 1
   60 C(I) = C(I) + D(IJ)*CJ
   61 BK = BK - D(IJ+1)*CJ
C
C       K=N CASE
C
      M = K
      IF (K .LT. N) GO TO 70
      IF (C(K) .EQ. ZERO) GO TO 200
      D(LAST) = BK/C(K)
      GO TO 90
C
C     FIND THE PIVOT
C
   70 S = ABS(REAL(C(K))) + ABS(AIMAG(C(K)))
      DO 71 I = KP1,N
      SI = ABS(REAL(C(I))) + ABS(AIMAG(C(I)))
      IF (SI .LE. S) GO TO 71
      M = I
      S = SI
   71 CONTINUE
C
      IP(K) = M
      CK = C(M)
      C(M) = C(K)
      C(K) = CK
      IF (C(K) .EQ. ZERO) GO TO 200
C
C     FIND THE K-TH ELEMENTARY MATRIX
C
      IK = LAST
      DO 80 I = KP1,N
      D(IK) = -C(I)/C(K)
   80 IK = IK + 1
      D(IK) = BK/C(K)
C
C     FORM THE PRODUCT OF THE ELEMENTARY MATRICES
C
   90 DO 110 J = 1,KM1
      KJOLD = J*LCOLP1 + K - NP1
      MJOLD = KJOLD + M - K
      IJ = (J-1)*LCOL
      IJOLD = IJ + J
      IF (J .NE. KM1) GO TO 100
C
      KJOLD = LASTM1
      MJOLD = LASTM1 + M - K
      IJOLD = LASTM1
C
  100 IK = LAST - 1
      DKJ = D(MJOLD)
      D(MJOLD) = D(KJOLD)
      DO 110 I = KP1,NP1
      IJ = IJ + 1
      IJOLD = IJOLD + 1
      IK = IK + 1
      D(IJ) = D(IJOLD) + D(IK)*DKJ
  110 CONTINUE
  120 CONTINUE
C
      LAST = MAX
      IF (IFLAG .LT. 0) LAST = MAX - 2
      D(N) = D(LAST)
C
C     INSERT THE SOLUTION IN C
C
      DO 130 I = 1,N
  130 C(I) = D(I)
C
      NM1 = N - 1
      DO 140 I = 1,NM1
      K = N - I
      M = IP(K)
      CK = C(K)
      C(K) = C(M)
  140 C(M) = CK
      RETURN
C
C     THE SYSTEM IS SINGULAR
C
  200 IERR = K
      RETURN
      END
      SUBROUTINE CVBR (B,KB,M,N,ML,MU,A,KA)
C-----------------------------------------------------------------------
C           CONVERSION OF REAL MATRICES FROM BANDED TO
C                         STANDARD FORM
C-----------------------------------------------------------------------
      REAL A(KA,N), B(KB,*)
C
C     STORE THE NONZERO DATA OF THE FIRST ML ROWS
C
      IF (ML .EQ. 0) GO TO 20
      DO 11 I = 1,ML
         JMAX = MIN0(N,I + MU)
         K = ML + 1 - I
         DO 10 J = 1,JMAX
            K = K + 1
   10       A(I,J) = B(I,K)
   11 CONTINUE
C
C     STORE THE REMAINING NONZERO DATA
C
   20 IMIN = ML + 1
      IMAX = MIN0(M,ML + N)
      L = 0
      DO 22 I = IMIN,IMAX
         JMIN = I - ML
         JMAX = MIN0(N,I + MU)
         J = JMAX
         DO 21 JJ = JMIN,JMAX
            K = J - L
            A(I,J) = B(I,K)
   21       J = J - 1
         L = L + 1
   22 CONTINUE
C
C     INSERT ZEROS IN THE UPPER RIGHT CORNER
C
      JMIN = MU + 2
      IF (JMIN .GT. N) GO TO 40
      IMAX0 = 1
      DO 31 J = JMIN,N
         DO 30 I = 1,IMAX0
   30       A(I,J) = 0.0
         IMAX0 = MIN0(IMAX,IMAX0 + 1)
   31 CONTINUE
C
C     INSERT ZEROS IN THE LOWER LEFT CORNER
C
   40 IF (IMIN .EQ. IMAX) GO TO 50
      JMAX = IMAX - IMIN
      DO 42 J = 1,JMAX
         IMIN = IMIN + 1
         DO 41 I = IMIN,IMAX
   41       A(I,J) = 0.0
   42 CONTINUE
C
C     STORE ZEROS IN THE FINAL M-IMAX ROWS
C
   50 IF (IMAX .EQ. M) RETURN
      IMIN = IMAX + 1
      DO 52 J = 1,N
         DO 51 I = IMIN,M
   51       A(I,J) = 0.0
   52 CONTINUE
      RETURN
      END
      SUBROUTINE CVRB (A,KA,M,N,ML,MU,B,KB)
C-----------------------------------------------------------------------
C        CONVERSION OF REAL MATRICES FROM STANDARD TO BANDED
C                    FORM WHEN ML AND MU ARE GIVEN
C-----------------------------------------------------------------------
      REAL A(KA,N), B(KB,*)
C
C     STORE THE NONZERO DATA OF THE FIRST ML ROWS
C
      IF (ML .EQ. 0) GO TO 30
      L = ML
      DO 11 I = 1,ML
         JMAX = MIN0(N,I + MU)
         J = JMAX
         DO 10 JJ = 1,JMAX
            K = J + L
            B(I,K) = A(I,J)
   10       J = J - 1
         L = L - 1
   11 CONTINUE
C
C     INSERT ZEROS IN THE UPPER LEFT CORNER
C
      IMAX = ML
      DO 21 J = 1,ML
         DO 20 I = 1,IMAX
   20       B(I,J) = 0.0
         IMAX = IMAX - 1
   21 CONTINUE
C
C     STORE THE REMAINING NONZERO DATA
C
   30 IMIN = ML + 1
      IMAX = MIN0(M,ML + N)
      DO 32 I = IMIN,IMAX
         JMIN = I - ML
         JMAX = MIN0(N,I + MU)
         K = 0
         DO 31 J = JMIN,JMAX
            K = K + 1
   31       B(I,K) = A(I,J)
   32 CONTINUE
C
C     INSERT ZEROS IN THE LOWER RIGHT CORNER
C
      JMAX = ML + MU + 1
      IF (K .EQ. JMAX) GO TO 50
      JMIN = K + 1
      IMIN = IMAX
      DO 41 J = JMIN,JMAX
         DO 40 I = IMIN,IMAX
   40       B(I,J) = 0.0
         IMIN = IMIN - 1
   41 CONTINUE
C
C     STORE ZEROS IN THE FINAL M-IMAX ROWS
C
   50 IF (IMAX .EQ. M) RETURN
      IMIN = IMAX + 1
      DO 52 J = 1,JMAX
         DO 51 I = IMIN,M
   51       B(I,J) = 0.0
   52 CONTINUE
      RETURN
      END
      SUBROUTINE CVRB1 (A,KA,M,N,ML,MU,B,KB,NB,IERR)
C-----------------------------------------------------------------------
C           CONVERSION OF REAL MATRICES FROM STANDARD
C                        TO BANDED FORM
C-----------------------------------------------------------------------
      REAL A(KA,N), B(KB,NB)
C
C     COMPUTATION OF ML AND MU
C
      NM1 = N - 1
      IMIN = M
      IF (M .EQ. 1) GO TO 20
      DO 11 L = 2,M
         J = 1
         IMAX = MIN0(M,IMIN + NM1)
         DO 10 I = IMIN,IMAX
            IF (A(I,J) .NE. 0.0) GO TO 20
   10       J = J + 1
         IMIN = IMIN - 1
   11 CONTINUE
C
   20 MM1 = M - 1
      JMIN = N
      IF (N .EQ. 1) GO TO 30
      DO 22 L = 2,N
         I = 1
         JMAX = MIN0(N,JMIN + MM1)
         DO 21 J = JMIN,JMAX
            IF (A(I,J) .NE. 0.0) GO TO 30
   21       I = I + 1
         JMIN = JMIN - 1
   22 CONTINUE
C
   30 ML = IMIN - 1
      MU = JMIN - 1
      KMAX = ML + MU + 1
      IF (KMAX .GT. NB) GO TO 40
C
C     STORE THE MATRIX IN B
C
      IERR = 0
      CALL CVRB (A,KA,M,N,ML,MU,B,KB)
      RETURN
C
C     ERROR RETURN
C
   40 IERR = KMAX
      RETURN
      END
      SUBROUTINE CVBD (B,KB,M,N,ML,MU,A,KA)
C-----------------------------------------------------------------------
C        CONVERSION OF DOUBLE PRECISION MATRICES FROM BANDED
C                         TO STANDARD FORM
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), B(KB,*)
C
C     STORE THE NONZERO DATA OF THE FIRST ML ROWS
C
      IF (ML .EQ. 0) GO TO 20
      DO 11 I = 1,ML
         JMAX = MIN0(N,I + MU)
         K = ML + 1 - I
         DO 10 J = 1,JMAX
            K = K + 1
   10       A(I,J) = B(I,K)
   11 CONTINUE
C
C     STORE THE REMAINING NONZERO DATA
C
   20 IMIN = ML + 1
      IMAX = MIN0(M,ML + N)
      L = 0
      DO 22 I = IMIN,IMAX
         JMIN = I - ML
         JMAX = MIN0(N,I + MU)
         J = JMAX
         DO 21 JJ = JMIN,JMAX
            K = J - L
            A(I,J) = B(I,K)
   21       J = J - 1
         L = L + 1
   22 CONTINUE
C
C     INSERT ZEROS IN THE UPPER RIGHT CORNER
C
      JMIN = MU + 2
      IF (JMIN .GT. N) GO TO 40
      IMAX0 = 1
      DO 31 J = JMIN,N
         DO 30 I = 1,IMAX0
   30       A(I,J) = 0.D0
         IMAX0 = MIN0(IMAX,IMAX0 + 1)
   31 CONTINUE
C
C     INSERT ZEROS IN THE LOWER LEFT CORNER
C
   40 IF (IMIN .EQ. IMAX) GO TO 50
      JMAX = IMAX - IMIN
      DO 42 J = 1,JMAX
         IMIN = IMIN + 1
         DO 41 I = IMIN,IMAX
   41       A(I,J) = 0.D0
   42 CONTINUE
C
C     STORE ZEROS IN THE FINAL M-IMAX ROWS
C
   50 IF (IMAX .EQ. M) RETURN
      IMIN = IMAX + 1
      DO 52 J = 1,N
         DO 51 I = IMIN,M
   51       A(I,J) = 0.D0
   52 CONTINUE
      RETURN
      END
      SUBROUTINE CVDB (A,KA,M,N,ML,MU,B,KB)
C-----------------------------------------------------------------------
C        CONVERSION OF DOUBLE PRECISION MATRICES FROM STANDARD
C               TO BANDED FORM WHEN ML AND MU ARE GIVEN
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), B(KB,*)
C
C     STORE THE NONZERO DATA OF THE FIRST ML ROWS
C
      IF (ML .EQ. 0) GO TO 30
      L = ML
      DO 11 I = 1,ML
         JMAX = MIN0(N,I + MU)
         J = JMAX
         DO 10 JJ = 1,JMAX
            K = J + L
            B(I,K) = A(I,J)
   10       J = J - 1
         L = L - 1
   11 CONTINUE
C
C     INSERT ZEROS IN THE UPPER LEFT CORNER
C
      IMAX = ML
      DO 21 J = 1,ML
         DO 20 I = 1,IMAX
   20       B(I,J) = 0.D0
         IMAX = IMAX - 1
   21 CONTINUE
C
C     STORE THE REMAINING NONZERO DATA
C
   30 IMIN = ML + 1
      IMAX = MIN0(M,ML + N)
      DO 32 I = IMIN,IMAX
         JMIN = I - ML
         JMAX = MIN0(N,I + MU)
         K = 0
         DO 31 J = JMIN,JMAX
            K = K + 1
   31       B(I,K) = A(I,J)
   32 CONTINUE
C
C     INSERT ZEROS IN THE LOWER RIGHT CORNER
C
      JMAX = ML + MU + 1
      IF (K .EQ. JMAX) GO TO 50
      JMIN = K + 1
      IMIN = IMAX
      DO 41 J = JMIN,JMAX
         DO 40 I = IMIN,IMAX
   40       B(I,J) = 0.D0
         IMIN = IMIN - 1
   41 CONTINUE
C
C     STORE ZEROS IN THE FINAL M-IMAX ROWS
C
   50 IF (IMAX .EQ. M) RETURN
      IMIN = IMAX + 1
      DO 52 J = 1,JMAX
         DO 51 I = IMIN,M
   51       B(I,J) = 0.D0
   52 CONTINUE
      RETURN
      END
      SUBROUTINE CVDB1 (A,KA,M,N,ML,MU,B,KB,NB,IERR)
C-----------------------------------------------------------------------
C        CONVERSION OF DOUBLE PRECISION MATRICES FROM STANDARD
C                         TO BANDED FORM
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), B(KB,NB)
C
C     COMPUTATION OF ML AND MU
C
      NM1 = N - 1
      IMIN = M
      IF (M .EQ. 1) GO TO 20
      DO 11 L = 2,M
         J = 1
         IMAX = MIN0(M,IMIN + NM1)
         DO 10 I = IMIN,IMAX
            IF (A(I,J) .NE. 0.D0) GO TO 20
   10       J = J + 1
         IMIN = IMIN - 1
   11 CONTINUE
C
   20 MM1 = M - 1
      JMIN = N
      IF (N .EQ. 1) GO TO 30
      DO 22 L = 2,N
         I = 1
         JMAX = MIN0(N,JMIN + MM1)
         DO 21 J = JMIN,JMAX
            IF (A(I,J) .NE. 0.D0) GO TO 30
   21       I = I + 1
         JMIN = JMIN - 1
   22 CONTINUE
C
   30 ML = IMIN - 1
      MU = JMIN - 1
      KMAX = ML + MU + 1
      IF (KMAX .GT. NB) GO TO 40
C
C     STORE THE MATRIX IN B
C
      IERR = 0
      CALL CVDB (A,KA,M,N,ML,MU,B,KB)
      RETURN
C
C     ERROR RETURN
C
   40 IERR = KMAX
      RETURN
      END
      SUBROUTINE CVBC (B,KB,M,N,ML,MU,A,KA)
C-----------------------------------------------------------------------
C          CONVERSION OF COMPLEX MATRICES FROM BANDED TO
C                          STANDARD FORM
C-----------------------------------------------------------------------
      COMPLEX A(KA,N), B(KB,*)
C
C     STORE THE NONZERO DATA OF THE FIRST ML ROWS
C
      IF (ML .EQ. 0) GO TO 20
      DO 11 I = 1,ML
         JMAX = MIN0(N,I + MU)
         K = ML + 1 - I
         DO 10 J = 1,JMAX
            K = K + 1
   10       A(I,J) = B(I,K)
   11 CONTINUE
C
C     STORE THE REMAINING NONZERO DATA
C
   20 IMIN = ML + 1
      IMAX = MIN0(M,ML + N)
      L = 0
      DO 22 I = IMIN,IMAX
         JMIN = I - ML
         JMAX = MIN0(N,I + MU)
         J = JMAX
         DO 21 JJ = JMIN,JMAX
            K = J - L
            A(I,J) = B(I,K)
   21       J = J - 1
         L = L + 1
   22 CONTINUE
C
C     INSERT ZEROS IN THE UPPER RIGHT CORNER
C
      JMIN = MU + 2
      IF (JMIN .GT. N) GO TO 40
      IMAX0 = 1
      DO 31 J = JMIN,N
         DO 30 I = 1,IMAX0
   30       A(I,J) = (0.0,0.0)
         IMAX0 = MIN0(IMAX,IMAX0 + 1)
   31 CONTINUE
C
C     INSERT ZEROS IN THE LOWER LEFT CORNER
C
   40 IF (IMIN .EQ. IMAX) GO TO 50
      JMAX = IMAX - IMIN
      DO 42 J = 1,JMAX
         IMIN = IMIN + 1
         DO 41 I = IMIN,IMAX
   41       A(I,J) = (0.0,0.0)
   42 CONTINUE
C
C     STORE ZEROS IN THE FINAL M-IMAX ROWS
C
   50 IF (IMAX .EQ. M) RETURN
      IMIN = IMAX + 1
      DO 52 J = 1,N
         DO 51 I = IMIN,M
   51       A(I,J) = (0.0,0.0)
   52 CONTINUE
      RETURN
      END
      SUBROUTINE CVCB (A,KA,M,N,ML,MU,B,KB)
C-----------------------------------------------------------------------
C        CONVERSION OF COMPLEX MATRICES FROM STANDARD TO BANDED
C                    FORM WHEN ML AND MU ARE GIVEN
C-----------------------------------------------------------------------
      COMPLEX A(KA,N), B(KB,*)
C
C     STORE THE NONZERO DATA OF THE FIRST ML ROWS
C
      IF (ML .EQ. 0) GO TO 30
      L = ML
      DO 11 I = 1,ML
         JMAX = MIN0(N,I + MU)
         J = JMAX
         DO 10 JJ = 1,JMAX
            K = J + L
            B(I,K) = A(I,J)
   10       J = J - 1
         L = L - 1
   11 CONTINUE
C
C     INSERT ZEROS IN THE UPPER LEFT CORNER
C
      IMAX = ML
      DO 21 J = 1,ML
         DO 20 I = 1,IMAX
   20       B(I,J) = (0.0,0.0)
         IMAX = IMAX - 1
   21 CONTINUE
C
C     STORE THE REMAINING NONZERO DATA
C
   30 IMIN = ML + 1
      IMAX = MIN0(M,ML + N)
      DO 32 I = IMIN,IMAX
         JMIN = I - ML
         JMAX = MIN0(N,I + MU)
         K = 0
         DO 31 J = JMIN,JMAX
            K = K + 1
   31       B(I,K) = A(I,J)
   32 CONTINUE
C
C     INSERT ZEROS IN THE LOWER RIGHT CORNER
C
      JMAX = ML + MU + 1
      IF (K .EQ. JMAX) GO TO 50
      JMIN = K + 1
      IMIN = IMAX
      DO 41 J = JMIN,JMAX
         DO 40 I = IMIN,IMAX
   40       B(I,J) = (0.0,0.0)
         IMIN = IMIN - 1
   41 CONTINUE
C
C     STORE ZEROS IN THE FINAL M-IMAX ROWS
C
   50 IF (IMAX .EQ. M) RETURN
      IMIN = IMAX + 1
      DO 52 J = 1,JMAX
         DO 51 I = IMIN,M
   51       B(I,J) = (0.0,0.0)
   52 CONTINUE
      RETURN
      END
      SUBROUTINE CVCB1 (A,KA,M,N,ML,MU,B,KB,NB,IERR)
C-----------------------------------------------------------------------
C           CONVERSION OF COMPLEX MATRICES FROM STANDARD
C                          TO BANDED FORM
C-----------------------------------------------------------------------
      COMPLEX A(KA,N), B(KB,NB)
C
C     COMPUTATION OF ML AND MU
C
      NM1 = N - 1
      IMIN = M
      IF (M .EQ. 1) GO TO 20
      DO 11 L = 2,M
         J = 1
         IMAX = MIN0(M,IMIN + NM1)
         DO 10 I = IMIN,IMAX
            IF (A(I,J) .NE. (0.0,0.0)) GO TO 20
   10       J = J + 1
         IMIN = IMIN - 1
   11 CONTINUE
C
   20 MM1 = M - 1
      JMIN = N
      IF (N .EQ. 1) GO TO 30
      DO 22 L = 2,N
         I = 1
         JMAX = MIN0(N,JMIN + MM1)
         DO 21 J = JMIN,JMAX
            IF (A(I,J) .NE. (0.0,0.0)) GO TO 30
   21       I = I + 1
         JMIN = JMIN - 1
   22 CONTINUE
C
   30 ML = IMIN - 1
      MU = JMIN - 1
      KMAX = ML + MU + 1
      IF (KMAX .GT. NB) GO TO 40
C
C     STORE THE MATRIX IN B
C
      IERR = 0
      CALL CVCB (A,KA,M,N,ML,MU,B,KB)
      RETURN
C
C     ERROR RETURN
C
   40 IERR = KMAX
      RETURN
      END
      SUBROUTINE MCVBS (A,KA,M,N,ML,MU,B,IB,JB,NUM,IERR)
C-----------------------------------------------------------------------
C                CONVERSION OF REAL MATRICES FROM BANDED
C                            TO SPARSE FORM
C-----------------------------------------------------------------------
      REAL A(KA,*), B(*)
      INTEGER IB(*), JB(*)
C
      L = 1
      KMAX = ML + MU + 1
C
C     STORE THE NONZERO DATA OF THE FIRST ML ROWS
C
      J0 = ML
      IF (ML .EQ. 0) GO TO 20
      DO 11 I = 1,ML
         IB(I) = L
         KMIN = 1 + J0
         DO 10 K = KMIN,KMAX
            IF (A(I,K) .EQ. 0.0) GO TO 10
            IF (L .GT. NUM) GO TO 40
            B(L) = A(I,K)
            JB(L) = K - J0
            L = L + 1
   10    CONTINUE
         J0 = J0 - 1
   11 CONTINUE
C
C     STORE THE REMAINING NONZERO DATA
C
   20 IMIN = ML + 1
      IMAX = MIN0(M,ML + N)
      DO 22 I = IMIN,IMAX
         IB(I) = L
         DO 21 K = 1,KMAX
            IF (A(I,K) .EQ. 0.0) GO TO 21
            IF (L .GT. NUM) GO TO 40
            B(L) = A(I,K)
            JB(L) = K - J0
            L = L + 1
   21    CONTINUE
         J0 = J0 - 1
   22 CONTINUE
      IERR = 0
C
C     SET UP THE REMAINING M-IMAX ROWS
C
      IMIN = IMAX + 1
      MP1 = M + 1
      DO 30 I = IMIN,MP1
         IB(I) = L
   30 CONTINUE
      RETURN
C
C     ERROR RETURN
C
   40 IERR = I
      RETURN
      END
      SUBROUTINE DMCVBS (A,KA,M,N,ML,MU,B,IB,JB,NUM,IERR)
C-----------------------------------------------------------------------
C          CONVERSION OF DOUBLE PRECISION MATRICES FROM BANDED
C                            TO SPARSE FORM
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), B(*)
      INTEGER IB(*), JB(*)
C
      L = 1
      KMAX = ML + MU + 1
C
C     STORE THE NONZERO DATA OF THE FIRST ML ROWS
C
      J0 = ML
      IF (ML .EQ. 0) GO TO 20
      DO 11 I = 1,ML
         IB(I) = L
         KMIN = 1 + J0
         DO 10 K = KMIN,KMAX
            IF (A(I,K) .EQ. 0.D0) GO TO 10
            IF (L .GT. NUM) GO TO 40
            B(L) = A(I,K)
            JB(L) = K - J0
            L = L + 1
   10    CONTINUE
         J0 = J0 - 1
   11 CONTINUE
C
C     STORE THE REMAINING NONZERO DATA
C
   20 IMIN = ML + 1
      IMAX = MIN0(M,ML + N)
      DO 22 I = IMIN,IMAX
         IB(I) = L
         DO 21 K = 1,KMAX
            IF (A(I,K) .EQ. 0.D0) GO TO 21
            IF (L .GT. NUM) GO TO 40
            B(L) = A(I,K)
            JB(L) = K - J0
            L = L + 1
   21    CONTINUE
         J0 = J0 - 1
   22 CONTINUE
      IERR = 0
C
C     SET UP THE REMAINING M-IMAX ROWS
C
      IMIN = IMAX + 1
      MP1 = M + 1
      DO 30 I = IMIN,MP1
         IB(I) = L
   30 CONTINUE
      RETURN
C
C     ERROR RETURN
C
   40 IERR = I
      RETURN
      END
      SUBROUTINE CMCVBS (A,KA,M,N,ML,MU,B,IB,JB,NUM,IERR)
C-----------------------------------------------------------------------
C              CONVERSION OF COMPLEX MATRICES FROM BANDED
C                            TO SPARSE FORM
C-----------------------------------------------------------------------
      COMPLEX A(KA,*), B(*)
      INTEGER IB(*), JB(*)
C
      L = 1
      KMAX = ML + MU + 1
C
C     STORE THE NONZERO DATA OF THE FIRST ML ROWS
C
      J0 = ML
      IF (ML .EQ. 0) GO TO 20
      DO 11 I = 1,ML
         IB(I) = L
         KMIN = 1 + J0
         DO 10 K = KMIN,KMAX
            IF (A(I,K) .EQ. (0.0,0.0)) GO TO 10
            IF (L .GT. NUM) GO TO 40
            B(L) = A(I,K)
            JB(L) = K - J0
            L = L + 1
   10    CONTINUE
         J0 = J0 - 1
   11 CONTINUE
C
C     STORE THE REMAINING NONZERO DATA
C
   20 IMIN = ML + 1
      IMAX = MIN0(M,ML + N)
      DO 22 I = IMIN,IMAX
         IB(I) = L
         DO 21 K = 1,KMAX
            IF (A(I,K) .EQ. (0.0,0.0)) GO TO 21
            IF (L .GT. NUM) GO TO 40
            B(L) = A(I,K)
            JB(L) = K - J0
            L = L + 1
   21    CONTINUE
         J0 = J0 - 1
   22 CONTINUE
      IERR = 0
C
C     SET UP THE REMAINING M-IMAX ROWS
C
      IMIN = IMAX + 1
      MP1 = M + 1
      DO 30 I = IMIN,MP1
         IB(I) = L
   30 CONTINUE
      RETURN
C
C     ERROR RETURN
C
   40 IERR = I
      RETURN
      END
      SUBROUTINE MCVSB (A,IA,JA,M,N,B,KB,NB,ML,MU,IERR)
C-----------------------------------------------------------------------
C                CONVERSION OF REAL MATRICES FROM SPARSE
C                            TO BANDED FORM
C-----------------------------------------------------------------------
      REAL A(*), B(KB,NB)
      INTEGER IA(*), JA(*)
C
C     COMPUTATION OF ML AND MU
C
      ML = 0
      MU = 0
      DO 11 I = 1,M
         LMIN = IA(I)
         LMAX = IA(I + 1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            IF (A(L) .EQ. 0.0) GO TO 10
            K = JA(L) - I
            MU = MAX0(MU,K)
            ML = MAX0(ML,-K)
   10    CONTINUE
   11 CONTINUE
C
C     SET B = 0 IF B PROVIDES SUFFICIENT STORAGE
C
      KMAX = ML + MU + 1
      IF (KMAX .GT. NB) GO TO 40
C
      IERR = 0
      DO 21 K = 1,KMAX
         DO 20 I = 1,M
   20       B(I,K) = 0.0
   21 CONTINUE
C
C     STORE THE MATRIX IN B
C
      J0 = ML
      DO 31 I = 1,M
         LMIN = IA(I)
         LMAX = IA(I + 1) - 1
         IF (LMIN .GT. LMAX) GO TO 31
         DO 30 L = LMIN,LMAX
            IF (A(L) .EQ. 0.0) GO TO 30
            K = JA(L) + J0
            B(I,K) = A(L)
   30    CONTINUE
         J0 = J0 - 1
   31 CONTINUE
      RETURN
C
C     ERROR RETURN
C
   40 IERR = KMAX
      RETURN
      END
      SUBROUTINE DMCVSB (A,IA,JA,M,N,B,KB,NB,ML,MU,IERR)
C-----------------------------------------------------------------------
C          CONVERSION OF DOUBLE PRECISION MATRICES FROM SPARSE
C                            TO BANDED FORM
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(KB,NB)
      INTEGER IA(*), JA(*)
C
C     COMPUTATION OF ML AND MU
C
      ML = 0
      MU = 0
      DO 11 I = 1,M
         LMIN = IA(I)
         LMAX = IA(I + 1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            IF (A(L) .EQ. 0.D0) GO TO 10
            K = JA(L) - I
            MU = MAX0(MU,K)
            ML = MAX0(ML,-K)
   10    CONTINUE
   11 CONTINUE
C
C     SET B = 0 IF B PROVIDES SUFFICIENT STORAGE
C
      KMAX = ML + MU + 1
      IF (KMAX .GT. NB) GO TO 40
C
      IERR = 0
      DO 21 K = 1,KMAX
         DO 20 I = 1,M
   20       B(I,K) = 0.D0
   21 CONTINUE
C
C     STORE THE MATRIX IN B
C
      J0 = ML
      DO 31 I = 1,M
         LMIN = IA(I)
         LMAX = IA(I + 1) - 1
         IF (LMIN .GT. LMAX) GO TO 31
         DO 30 L = LMIN,LMAX
            IF (A(L) .EQ. 0.D0) GO TO 30
            K = JA(L) + J0
            B(I,K) = A(L)
   30    CONTINUE
         J0 = J0 - 1
   31 CONTINUE
      RETURN
C
C     ERROR RETURN
C
   40 IERR = KMAX
      RETURN
      END
      SUBROUTINE CMCVSB (A,IA,JA,M,N,B,KB,NB,ML,MU,IERR)
C-----------------------------------------------------------------------
C              CONVERSION OF COMPLEX MATRICES FROM SPARSE
C                            TO BANDED FORM
C-----------------------------------------------------------------------
      COMPLEX A(*), B(KB,NB)
      INTEGER IA(*), JA(*)
C
C     COMPUTATION OF ML AND MU
C
      ML = 0
      MU = 0
      DO 11 I = 1,M
         LMIN = IA(I)
         LMAX = IA(I + 1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            IF (A(L) .EQ. (0.0,0.0)) GO TO 10
            K = JA(L) - I
            MU = MAX0(MU,K)
            ML = MAX0(ML,-K)
   10    CONTINUE
   11 CONTINUE
C
C     SET B = 0 IF B PROVIDES SUFFICIENT STORAGE
C
      KMAX = ML + MU + 1
      IF (KMAX .GT. NB) GO TO 40
C
      IERR = 0
      DO 21 K = 1,KMAX
         DO 20 I = 1,M
   20       B(I,K) = (0.0,0.0)
   21 CONTINUE
C
C     STORE THE MATRIX IN B
C
      J0 = ML
      DO 31 I = 1,M
         LMIN = IA(I)
         LMAX = IA(I + 1) - 1
         IF (LMIN .GT. LMAX) GO TO 31
         DO 30 L = LMIN,LMAX
            IF (A(L) .EQ. (0.0,0.0)) GO TO 30
            K = JA(L) + J0
            B(I,K) = A(L)
   30    CONTINUE
         J0 = J0 - 1
   31 CONTINUE
      RETURN
C
C     ERROR RETURN
C
   40 IERR = KMAX
      RETURN
      END
      SUBROUTINE BCVRD (A, KA, M, N, ML, MU, B, KB)
C-----------------------------------------------------------------------
C        CONVERSION OF BANDED MATRICES FROM SINGLE TO DOUBLE
C                          PRECISION FORM
C-----------------------------------------------------------------------
      REAL A(KA,*)
      DOUBLE PRECISION B(KB,*)
C
      NUM = ML + MU + 1
      DO 20 J = 1,NUM
         DO 10 I = 1,M
            B(I,J) = A(I,J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE BCVDR (A, KA, M, N, ML, MU, B, KB)
C-----------------------------------------------------------------------
C        CONVERSION OF BANDED MATRICES FROM DOUBLE TO SINGLE
C                          PRECISION FORM
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*)
      REAL B(KB,*)
C
      NUM = ML + MU + 1
      DO 20 J = 1,NUM
         DO 10 I = 1,M
            B(I,J) = A(I,J)
   10    CONTINUE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE BREAL (A, KA, M, N, ML, MU, B, KB, L, NL, NU, IERR)
C-----------------------------------------------------------------------
C              REAL PART OF A BANDED COMPLEX MATRIX
C-----------------------------------------------------------------------
      COMPLEX A(KA,*)
      REAL B(KB,L)
C
C     COMPUTATION OF NL AND NU
C
      NL = ML
      IF (ML .EQ. 0) GO TO 30
      IMIN = ML + 1
      DO 20 J = 1,ML
         DO 10 I = IMIN,M
            IF (REAL(A(I,J)) .NE. 0.0) GO TO 30
   10    CONTINUE
         NL = NL - 1
         IMIN = IMIN - 1
   20 CONTINUE
C
   30 NU = MU
      IF (MU .EQ. 0) GO TO 60
      J = ML + MU + 1
      DO 50 K = 1,MU
         DO 40 I = 1,M
            IF (REAL(A(I,J)) .NE. 0.0) GO TO 60
   40    CONTINUE
         NU = NU - 1
         J = J - 1
   50 CONTINUE
C
C     STORE THE REAL PART OF A IN B
C
   60 NUM = NL + NU + 1
      IF (NUM .GT. L) GO TO 100
      IERR = 0
      K = ML - NL
      DO 80 J = 1,NUM
         K = K + 1
         DO 70 I = 1,M
            B(I,J) = REAL(A(I,K))
   70    CONTINUE
   80 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  100 IERR = NUM
      RETURN
      END
      SUBROUTINE BIMAG (A, KA, M, N, ML, MU, B, KB, L, NL, NU, IERR)
C-----------------------------------------------------------------------
C            IMAGINARY PART OF A BANDED COMPLEX MATRIX
C-----------------------------------------------------------------------
      COMPLEX A(KA,*)
      REAL B(KB,L)
C
C     COMPUTATION OF NL AND NU
C
      NL = ML
      IF (ML .EQ. 0) GO TO 30
      IMIN = ML + 1
      DO 20 J = 1,ML
         DO 10 I = IMIN,M
            IF (AIMAG(A(I,J)) .NE. 0.0) GO TO 30
   10    CONTINUE
         NL = NL - 1
         IMIN = IMIN - 1
   20 CONTINUE
C
   30 NU = MU
      IF (MU .EQ. 0) GO TO 60
      J = ML + MU + 1
      DO 50 K = 1,MU
         DO 40 I = 1,M
            IF (AIMAG(A(I,J)) .NE. 0.0) GO TO 60
   40    CONTINUE
         NU = NU - 1
         J = J - 1
   50 CONTINUE
C
C     STORE THE IMAGINARY PART OF A IN B
C
   60 NUM = NL + NU + 1
      IF (NUM .GT. L) GO TO 100
      IERR = 0
      K = ML - NL
      DO 80 J = 1,NUM
         K = K + 1
         DO 70 I = 1,M
            B(I,J) = AIMAG(A(I,K))
   70    CONTINUE
   80 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  100 IERR = NUM
      RETURN
      END
      SUBROUTINE BCVRC (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR)
C-----------------------------------------------------------------------
C        COMPUTE A + BI FOR THE BANDED REAL MATRICES A AND B
C-----------------------------------------------------------------------
      REAL A(KA,*), B(KB,*)
      COMPLEX C(KC,L)
C
      MCL = MAX0(ML,NL)
      MCU = MAX0(MU,NU)
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      IERR = 0
      K = MIN0(MU,NU) + 1
C
C     INSERT THE FIRST ABS(ML - NL) DIAGONALS
C
      IF (NL .GE. ML) GO TO 30
      JA = ML - NL
      JB = 0
      JC = JA
      JMAX = NL + K
      DO 20 J = 1,JC
         DO 10 I = 1,M
            C(I,J) = CMPLX(A(I,J),0.0)
   10    CONTINUE
   20 CONTINUE
      GO TO 60
C
   30 JA = 0
      JB = NL - ML
      JC = JB
      JMAX = ML + K
      IF (JC .EQ. 0) GO TO 60
      DO 50 J = 1,JC
         DO 40 I = 1,M
            C(I,J) = CMPLX(0.0,B(I,J))
   40    CONTINUE
   50 CONTINUE
C
C     ADDITION OF THE COMMON DIAGONALS
C
   60 DO 80 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 70 I = 1,M
            C(I,JC) = CMPLX(A(I,JA),B(I,JB))
   70    CONTINUE
   80 CONTINUE
C
C     INSERTION OF THE REMAINING DIAGONALS
C
      IF (NU .GE. MU) GO TO 120
      JMAX = MU - NU
      DO 110 J = 1,JMAX
         JA = JA + 1
         JC = JC + 1
         DO 100 I = 1,M
            C(I,JC) = CMPLX(A(I,JA),0.0)
  100    CONTINUE
  110 CONTINUE
      RETURN
C
  120 JMAX = NU - MU
      IF (JMAX .EQ. 0) RETURN
      DO 140 J = 1,JMAX
         JB = JB + 1
         JC = JC + 1
         DO 130 I = 1,M
            C(I,JC) = CMPLX(0.0,B(I,JB))
  130    CONTINUE
  140 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = NUM
      RETURN
      END
      SUBROUTINE BPOSE (A, KA, M, N, ML, MU, B, KB)
C-----------------------------------------------------------------------
C                TRANSPOSITION OF REAL BANDED MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,*), B(KB,*)
C
      L = ML + MU + 1
      LP1 = L + 1
      IF (MU .EQ. 0) GO TO 40
C
C     DEFINE THE FIRST MU COLUMNS OF B
C
      NDIAG = MU
      DO 31 J = 1,MU
         DO 10 I = 1,NDIAG
            B(I,J) = 0.0
   10    CONTINUE
C
         LJ = LP1 - J
         IMAX = MIN0(M,N - NDIAG)
         DO 20 I = 1,IMAX
            K = NDIAG + I
            B(K,J) = A(I,LJ)
   20    CONTINUE
C
         IF (K .EQ. N) GO TO 31
         IMIN = K + 1
         DO 30 I = IMIN,N
            B(I,J) = 0.0
   30    CONTINUE
   31    NDIAG = NDIAG - 1
C
C     DEFINE THE REMAINING COLUMNS OF B
C
   40 JMIN = MU + 1
      NDIAG = 0
      DO 61 J = JMIN,L
         LJ = LP1 - J
         IMAX = MIN0(M - NDIAG,N)
         DO 50 I = 1,IMAX
            K = NDIAG + I
            B(I,J) = A(K,LJ)
   50    CONTINUE
C
         IF (IMAX .EQ. N) GO TO 61
         IMIN = IMAX + 1
         DO 60 I = IMIN,N
            B(I,J) = 0.0
   60    CONTINUE
   61    NDIAG = NDIAG + 1
      RETURN
      END
      SUBROUTINE DBPOSE (A, KA, M, N, ML, MU, B, KB)
C-----------------------------------------------------------------------
C          TRANSPOSITION OF DOUBLE PRECISION BANDED MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), B(KB,*)
C
      L = ML + MU + 1
      LP1 = L + 1
      IF (MU .EQ. 0) GO TO 40
C
C     DEFINE THE FIRST MU COLUMNS OF B
C
      NDIAG = MU
      DO 31 J = 1,MU
         DO 10 I = 1,NDIAG
            B(I,J) = 0.D0
   10    CONTINUE
C
         LJ = LP1 - J
         IMAX = MIN0(M,N - NDIAG)
         DO 20 I = 1,IMAX
            K = NDIAG + I
            B(K,J) = A(I,LJ)
   20    CONTINUE
C
         IF (K .EQ. N) GO TO 31
         IMIN = K + 1
         DO 30 I = IMIN,N
            B(I,J) = 0.D0
   30    CONTINUE
   31    NDIAG = NDIAG - 1
C
C     DEFINE THE REMAINING COLUMNS OF B
C
   40 JMIN = MU + 1
      NDIAG = 0
      DO 61 J = JMIN,L
         LJ = LP1 - J
         IMAX = MIN0(M - NDIAG,N)
         DO 50 I = 1,IMAX
            K = NDIAG + I
            B(I,J) = A(K,LJ)
   50    CONTINUE
C
         IF (IMAX .EQ. N) GO TO 61
         IMIN = IMAX + 1
         DO 60 I = IMIN,N
            B(I,J) = 0.D0
   60    CONTINUE
   61    NDIAG = NDIAG + 1
      RETURN
      END
      SUBROUTINE CBPOSE (A, KA, M, N, ML, MU, B, KB)
C-----------------------------------------------------------------------
C              TRANSPOSITION OF COMPLEX BANDED MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(KA,*), B(KB,*)
C
      L = ML + MU + 1
      LP1 = L + 1
      IF (MU .EQ. 0) GO TO 40
C
C     DEFINE THE FIRST MU COLUMNS OF B
C
      NDIAG = MU
      DO 31 J = 1,MU
         DO 10 I = 1,NDIAG
            B(I,J) = (0.0,0.0)
   10    CONTINUE
C
         LJ = LP1 - J
         IMAX = MIN0(M,N - NDIAG)
         DO 20 I = 1,IMAX
            K = NDIAG + I
            B(K,J) = A(I,LJ)
   20    CONTINUE
C
         IF (K .EQ. N) GO TO 31
         IMIN = K + 1
         DO 30 I = IMIN,N
            B(I,J) = (0.0,0.0)
   30    CONTINUE
   31    NDIAG = NDIAG - 1
C
C     DEFINE THE REMAINING COLUMNS OF B
C
   40 JMIN = MU + 1
      NDIAG = 0
      DO 61 J = JMIN,L
         LJ = LP1 - J
         IMAX = MIN0(M - NDIAG,N)
         DO 50 I = 1,IMAX
            K = NDIAG + I
            B(I,J) = A(K,LJ)
   50    CONTINUE
C
         IF (IMAX .EQ. N) GO TO 61
         IMIN = IMAX + 1
         DO 60 I = IMIN,N
            B(I,J) = (0.0,0.0)
   60    CONTINUE
   61    NDIAG = NDIAG + 1
      RETURN
      END
      SUBROUTINE BADD (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR)
C-----------------------------------------------------------------------
C                 ADDITION OF REAL BANDED MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,*), B(KB,*), C(KC,L)
C
      IERR = 0
      IF (NL - ML) 10,30,20
C
C     INSERT THE FIRST ABS(ML - NL) DIAGONALS
C
   10 MCL = ML
      IF (ML .GE. L) GO TO 50
      JA = ML - NL
      JB = 0
      JC = JA
      JMAX = NL + 1
      DO 12 J = 1,JC
         DO 11 I = 1,M
   11       C(I,J) = A(I,J)
   12 CONTINUE
      GO TO 50
C
   20 MCL = NL
      IF (NL .GE. L) GO TO 50
      JA = 0
      JB = NL - ML
      JC = JB
      JMAX = ML + 1
      DO 22 J = 1,JC
         DO 21 I = 1,M
   21       C(I,J) = B(I,J)
   22 CONTINUE
      GO TO 50
C
C     COMPUTE MCL WHEN ML = NL
C
   30 MCL = ML
      IF (ML .EQ. 0) GO TO 40
      IMIN = ML + 1
      DO 32 J = 1,ML
         DO 31 I = IMIN,M
            IF ((A(I,J) + B(I,J)) .NE. 0.0) GO TO 40
   31    CONTINUE
         MCL = MCL - 1
         IMIN = IMIN - 1
   32 CONTINUE
C
   40 JA = ML - MCL
      JB = JA
      JC = 0
      JMAX = MCL + 1
C
   50 IF (NU - MU) 100,160,130
C
C     INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU
C
  100 MCU = MU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + NU
      DO 111 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 110 I = 1,M
            C(I,JC) = A(I,JA) + B(I,JB)
  110    CONTINUE
  111 CONTINUE
C
      JMAX = MU - NU
      DO 121 J = 1,JMAX
         JA = JA + 1
         JC = JC + 1
         DO 120 I = 1,M
  120       C(I,JC) = A(I,JA)
  121 CONTINUE
      RETURN
C
  130 MCU = NU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MU
      DO 141 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 140 I = 1,M
            C(I,JC) = A(I,JA) + B(I,JB)
  140    CONTINUE
  141 CONTINUE
C
      JMAX = NU - MU
      DO 151 J = 1,JMAX
         JB = JB + 1
         JC = JC + 1
         DO 150 I = 1,M
  150       C(I,JC) = B(I,JB)
  151 CONTINUE
      RETURN
C
C     COMPUTE MCU WHEN MU = NU
C
  160 MCU = MU
      IF (MU .EQ. 0) GO TO 170
      LA = ML + MU + 1
      LB = NL + NU + 1
      DO 162 J = 1,MU
         DO 161 I = 1,M
            IF ((A(I,LA) + B(I,LB)) .NE. 0.0) GO TO 170
  161    CONTINUE
         MCU = MCU - 1
         LA = LA - 1
         LB = LB - 1
  162 CONTINUE
C
C     ADDITION OF THE REMAINING COLUMNS WHEN MU = NU
C
  170 NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MCU
      DO 181 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 180 I = 1,M
            C(I,JC) = A(I,JA) + B(I,JB)
  180    CONTINUE
  181 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = NUM
      RETURN
      END
      SUBROUTINE DBADD (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR)
C-----------------------------------------------------------------------
C           ADDITION OF DOUBLE PRECISION BANDED MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), B(KB,*), C(KC,L)
C
      IERR = 0
      IF (NL - ML) 10,30,20
C
C     INSERT THE FIRST ABS(ML - NL) DIAGONALS
C
   10 MCL = ML
      IF (ML .GE. L) GO TO 50
      JA = ML - NL
      JB = 0
      JC = JA
      JMAX = NL + 1
      DO 12 J = 1,JC
         DO 11 I = 1,M
   11       C(I,J) = A(I,J)
   12 CONTINUE
      GO TO 50
C
   20 MCL = NL
      IF (NL .GE. L) GO TO 50
      JA = 0
      JB = NL - ML
      JC = JB
      JMAX = ML + 1
      DO 22 J = 1,JC
         DO 21 I = 1,M
   21       C(I,J) = B(I,J)
   22 CONTINUE
      GO TO 50
C
C     COMPUTE MCL WHEN ML = NL
C
   30 MCL = ML
      IF (ML .EQ. 0) GO TO 40
      IMIN = ML + 1
      DO 32 J = 1,ML
         DO 31 I = IMIN,M
            IF ((A(I,J) + B(I,J)) .NE. 0.D0) GO TO 40
   31    CONTINUE
         MCL = MCL - 1
         IMIN = IMIN - 1
   32 CONTINUE
C
   40 JA = ML - MCL
      JB = JA
      JC = 0
      JMAX = MCL + 1
C
   50 IF (NU - MU) 100,160,130
C
C     INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU
C
  100 MCU = MU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + NU
      DO 111 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 110 I = 1,M
            C(I,JC) = A(I,JA) + B(I,JB)
  110    CONTINUE
  111 CONTINUE
C
      JMAX = MU - NU
      DO 121 J = 1,JMAX
         JA = JA + 1
         JC = JC + 1
         DO 120 I = 1,M
  120       C(I,JC) = A(I,JA)
  121 CONTINUE
      RETURN
C
  130 MCU = NU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MU
      DO 141 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 140 I = 1,M
            C(I,JC) = A(I,JA) + B(I,JB)
  140    CONTINUE
  141 CONTINUE
C
      JMAX = NU - MU
      DO 151 J = 1,JMAX
         JB = JB + 1
         JC = JC + 1
         DO 150 I = 1,M
  150       C(I,JC) = B(I,JB)
  151 CONTINUE
      RETURN
C
C     COMPUTE MCU WHEN MU = NU
C
  160 MCU = MU
      IF (MU .EQ. 0) GO TO 170
      LA = ML + MU + 1
      LB = NL + NU + 1
      DO 162 J = 1,MU
         DO 161 I = 1,M
            IF ((A(I,LA) + B(I,LB)) .NE. 0.D0) GO TO 170
  161    CONTINUE
         MCU = MCU - 1
         LA = LA - 1
         LB = LB - 1
  162 CONTINUE
C
C     ADDITION OF THE REMAINING COLUMNS WHEN MU = NU
C
  170 NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MCU
      DO 181 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 180 I = 1,M
            C(I,JC) = A(I,JA) + B(I,JB)
  180    CONTINUE
  181 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = NUM
      RETURN
      END
      SUBROUTINE CBADD (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR)
C-----------------------------------------------------------------------
C                ADDITION OF COMPLEX BANDED MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(KA,*), B(KB,*), C(KC,L)
C
      IERR = 0
      IF (NL - ML) 10,30,20
C
C     INSERT THE FIRST ABS(ML - NL) DIAGONALS
C
   10 MCL = ML
      IF (ML .GE. L) GO TO 50
      JA = ML - NL
      JB = 0
      JC = JA
      JMAX = NL + 1
      DO 12 J = 1,JC
         DO 11 I = 1,M
   11       C(I,J) = A(I,J)
   12 CONTINUE
      GO TO 50
C
   20 MCL = NL
      IF (NL .GE. L) GO TO 50
      JA = 0
      JB = NL - ML
      JC = JB
      JMAX = ML + 1
      DO 22 J = 1,JC
         DO 21 I = 1,M
   21       C(I,J) = B(I,J)
   22 CONTINUE
      GO TO 50
C
C     COMPUTE MCL WHEN ML = NL
C
   30 MCL = ML
      IF (ML .EQ. 0) GO TO 40
      IMIN = ML + 1
      DO 32 J = 1,ML
         DO 31 I = IMIN,M
            IF ((A(I,J) + B(I,J)) .NE. (0.0,0.0)) GO TO 40
   31    CONTINUE
         MCL = MCL - 1
         IMIN = IMIN - 1
   32 CONTINUE
C
   40 JA = ML - MCL
      JB = JA
      JC = 0
      JMAX = MCL + 1
C
   50 IF (NU - MU) 100,160,130
C
C     INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU
C
  100 MCU = MU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + NU
      DO 111 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 110 I = 1,M
            C(I,JC) = A(I,JA) + B(I,JB)
  110    CONTINUE
  111 CONTINUE
C
      JMAX = MU - NU
      DO 121 J = 1,JMAX
         JA = JA + 1
         JC = JC + 1
         DO 120 I = 1,M
  120       C(I,JC) = A(I,JA)
  121 CONTINUE
      RETURN
C
  130 MCU = NU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MU
      DO 141 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 140 I = 1,M
            C(I,JC) = A(I,JA) + B(I,JB)
  140    CONTINUE
  141 CONTINUE
C
      JMAX = NU - MU
      DO 151 J = 1,JMAX
         JB = JB + 1
         JC = JC + 1
         DO 150 I = 1,M
  150       C(I,JC) = B(I,JB)
  151 CONTINUE
      RETURN
C
C     COMPUTE MCU WHEN MU = NU
C
  160 MCU = MU
      IF (MU .EQ. 0) GO TO 170
      LA = ML + MU + 1
      LB = NL + NU + 1
      DO 162 J = 1,MU
         DO 161 I = 1,M
            IF ((A(I,LA) + B(I,LB)) .NE. (0.0,0.0)) GO TO 170
  161    CONTINUE
         MCU = MCU - 1
         LA = LA - 1
         LB = LB - 1
  162 CONTINUE
C
C     ADDITION OF THE REMAINING COLUMNS WHEN MU = NU
C
  170 NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MCU
      DO 181 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 180 I = 1,M
            C(I,JC) = A(I,JA) + B(I,JB)
  180    CONTINUE
  181 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = NUM
      RETURN
      END
      SUBROUTINE BSUBT (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR)
C-----------------------------------------------------------------------
C                SUBTRACTION OF REAL BANDED MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,*), B(KB,*), C(KC,L)
C
      IERR = 0
      IF (NL - ML) 10,30,20
C
C     INSERT THE FIRST ABS(ML - NL) DIAGONALS
C
   10 MCL = ML
      IF (ML .GE. L) GO TO 50
      JA = ML - NL
      JB = 0
      JC = JA
      JMAX = NL + 1
      DO 12 J = 1,JC
         DO 11 I = 1,M
   11       C(I,J) = A(I,J)
   12 CONTINUE
      GO TO 50
C
   20 MCL = NL
      IF (NL .GE. L) GO TO 50
      JA = 0
      JB = NL - ML
      JC = JB
      JMAX = ML + 1
      DO 22 J = 1,JC
         DO 21 I = 1,M
   21       C(I,J) = -B(I,J)
   22 CONTINUE
      GO TO 50
C
C     COMPUTE MCL WHEN ML = NL
C
   30 MCL = ML
      IF (ML .EQ. 0) GO TO 40
      IMIN = ML + 1
      DO 32 J = 1,ML
         DO 31 I = IMIN,M
            IF ((A(I,J) - B(I,J)) .NE. 0.0) GO TO 40
   31    CONTINUE
         MCL = MCL - 1
         IMIN = IMIN - 1
   32 CONTINUE
C
   40 JA = ML - MCL
      JB = JA
      JC = 0
      JMAX = MCL + 1
C
   50 IF (NU - MU) 100,160,130
C
C     INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU
C
  100 MCU = MU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + NU
      DO 111 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 110 I = 1,M
            C(I,JC) = A(I,JA) - B(I,JB)
  110    CONTINUE
  111 CONTINUE
C
      JMAX = MU - NU
      DO 121 J = 1,JMAX
         JA = JA + 1
         JC = JC + 1
         DO 120 I = 1,M
  120       C(I,JC) = A(I,JA)
  121 CONTINUE
      RETURN
C
  130 MCU = NU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MU
      DO 141 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 140 I = 1,M
            C(I,JC) = A(I,JA) - B(I,JB)
  140    CONTINUE
  141 CONTINUE
C
      JMAX = NU - MU
      DO 151 J = 1,JMAX
         JB = JB + 1
         JC = JC + 1
         DO 150 I = 1,M
  150       C(I,JC) = -B(I,JB)
  151 CONTINUE
      RETURN
C
C     COMPUTE MCU WHEN MU = NU
C
  160 MCU = MU
      IF (MU .EQ. 0) GO TO 170
      LA = ML + MU + 1
      LB = NL + NU + 1
      DO 162 J = 1,MU
         DO 161 I = 1,M
            IF ((A(I,LA) - B(I,LB)) .NE. 0.0) GO TO 170
  161    CONTINUE
         MCU = MCU - 1
         LA = LA - 1
         LB = LB - 1
  162 CONTINUE
C
C     ADDITION OF THE REMAINING COLUMNS WHEN MU = NU
C
  170 NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MCU
      DO 181 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 180 I = 1,M
            C(I,JC) = A(I,JA) - B(I,JB)
  180    CONTINUE
  181 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = NUM
      RETURN
      END
      SUBROUTINE DBSUBT (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR)
C-----------------------------------------------------------------------
C          SUBTRACTION OF DOUBLE PRECISION BANDED MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), B(KB,*), C(KC,L)
C
      IERR = 0
      IF (NL - ML) 10,30,20
C
C     INSERT THE FIRST ABS(ML - NL) DIAGONALS
C
   10 MCL = ML
      IF (ML .GE. L) GO TO 50
      JA = ML - NL
      JB = 0
      JC = JA
      JMAX = NL + 1
      DO 12 J = 1,JC
         DO 11 I = 1,M
   11       C(I,J) = A(I,J)
   12 CONTINUE
      GO TO 50
C
   20 MCL = NL
      IF (NL .GE. L) GO TO 50
      JA = 0
      JB = NL - ML
      JC = JB
      JMAX = ML + 1
      DO 22 J = 1,JC
         DO 21 I = 1,M
   21       C(I,J) = -B(I,J)
   22 CONTINUE
      GO TO 50
C
C     COMPUTE MCL WHEN ML = NL
C
   30 MCL = ML
      IF (ML .EQ. 0) GO TO 40
      IMIN = ML + 1
      DO 32 J = 1,ML
         DO 31 I = IMIN,M
            IF ((A(I,J) - B(I,J)) .NE. 0.D0) GO TO 40
   31    CONTINUE
         MCL = MCL - 1
         IMIN = IMIN - 1
   32 CONTINUE
C
   40 JA = ML - MCL
      JB = JA
      JC = 0
      JMAX = MCL + 1
C
   50 IF (NU - MU) 100,160,130
C
C     INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU
C
  100 MCU = MU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + NU
      DO 111 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 110 I = 1,M
            C(I,JC) = A(I,JA) - B(I,JB)
  110    CONTINUE
  111 CONTINUE
C
      JMAX = MU - NU
      DO 121 J = 1,JMAX
         JA = JA + 1
         JC = JC + 1
         DO 120 I = 1,M
  120       C(I,JC) = A(I,JA)
  121 CONTINUE
      RETURN
C
  130 MCU = NU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MU
      DO 141 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 140 I = 1,M
            C(I,JC) = A(I,JA) - B(I,JB)
  140    CONTINUE
  141 CONTINUE
C
      JMAX = NU - MU
      DO 151 J = 1,JMAX
         JB = JB + 1
         JC = JC + 1
         DO 150 I = 1,M
  150       C(I,JC) = -B(I,JB)
  151 CONTINUE
      RETURN
C
C     COMPUTE MCU WHEN MU = NU
C
  160 MCU = MU
      IF (MU .EQ. 0) GO TO 170
      LA = ML + MU + 1
      LB = NL + NU + 1
      DO 162 J = 1,MU
         DO 161 I = 1,M
            IF ((A(I,LA) - B(I,LB)) .NE. 0.D0) GO TO 170
  161    CONTINUE
         MCU = MCU - 1
         LA = LA - 1
         LB = LB - 1
  162 CONTINUE
C
C     ADDITION OF THE REMAINING COLUMNS WHEN MU = NU
C
  170 NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MCU
      DO 181 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 180 I = 1,M
            C(I,JC) = A(I,JA) - B(I,JB)
  180    CONTINUE
  181 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = NUM
      RETURN
      END
      SUBROUTINE CBSUBT (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR)
C-----------------------------------------------------------------------
C             SUBTRACTION OF COMPLEX BANDED MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(KA,*), B(KB,*), C(KC,L)
C
      IERR = 0
      IF (NL - ML) 10,30,20
C
C     INSERT THE FIRST ABS(ML - NL) DIAGONALS
C
   10 MCL = ML
      IF (ML .GE. L) GO TO 50
      JA = ML - NL
      JB = 0
      JC = JA
      JMAX = NL + 1
      DO 12 J = 1,JC
         DO 11 I = 1,M
   11       C(I,J) = A(I,J)
   12 CONTINUE
      GO TO 50
C
   20 MCL = NL
      IF (NL .GE. L) GO TO 50
      JA = 0
      JB = NL - ML
      JC = JB
      JMAX = ML + 1
      DO 22 J = 1,JC
         DO 21 I = 1,M
   21       C(I,J) = -B(I,J)
   22 CONTINUE
      GO TO 50
C
C     COMPUTE MCL WHEN ML = NL
C
   30 MCL = ML
      IF (ML .EQ. 0) GO TO 40
      IMIN = ML + 1
      DO 32 J = 1,ML
         DO 31 I = IMIN,M
            IF ((A(I,J) - B(I,J)) .NE. (0.0,0.0)) GO TO 40
   31    CONTINUE
         MCL = MCL - 1
         IMIN = IMIN - 1
   32 CONTINUE
C
   40 JA = ML - MCL
      JB = JA
      JC = 0
      JMAX = MCL + 1
C
   50 IF (NU - MU) 100,160,130
C
C     INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU
C
  100 MCU = MU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + NU
      DO 111 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 110 I = 1,M
            C(I,JC) = A(I,JA) - B(I,JB)
  110    CONTINUE
  111 CONTINUE
C
      JMAX = MU - NU
      DO 121 J = 1,JMAX
         JA = JA + 1
         JC = JC + 1
         DO 120 I = 1,M
  120       C(I,JC) = A(I,JA)
  121 CONTINUE
      RETURN
C
  130 MCU = NU
      NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MU
      DO 141 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 140 I = 1,M
            C(I,JC) = A(I,JA) - B(I,JB)
  140    CONTINUE
  141 CONTINUE
C
      JMAX = NU - MU
      DO 151 J = 1,JMAX
         JB = JB + 1
         JC = JC + 1
         DO 150 I = 1,M
  150       C(I,JC) = -B(I,JB)
  151 CONTINUE
      RETURN
C
C     COMPUTE MCU WHEN MU = NU
C
  160 MCU = MU
      IF (MU .EQ. 0) GO TO 170
      LA = ML + MU + 1
      LB = NL + NU + 1
      DO 162 J = 1,MU
         DO 161 I = 1,M
            IF ((A(I,LA) - B(I,LB)) .NE. (0.0,0.0)) GO TO 170
  161    CONTINUE
         MCU = MCU - 1
         LA = LA - 1
         LB = LB - 1
  162 CONTINUE
C
C     ADDITION OF THE REMAINING COLUMNS WHEN MU = NU
C
  170 NUM = MCL + MCU + 1
      IF (NUM .GT. L) GO TO 200
C
      JMAX = JMAX + MCU
      DO 181 J = 1,JMAX
         JA = JA + 1
         JB = JB + 1
         JC = JC + 1
         DO 180 I = 1,M
            C(I,JC) = A(I,JA) - B(I,JB)
  180    CONTINUE
  181 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = NUM
      RETURN
      END
      SUBROUTINE BPROD (M, N, L, A, KA, ML, MU, B, KB, NL, NU,
     *                  C, KC, NC, MCL, MCU, IERR)
C-----------------------------------------------------------------------
C                MULTIPLICATION OF REAL BANDED MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,*), B(KB,*), C(KC,NC)
C
      IERR = 0
      DO 11 J = 1,NC
         DO 10 I = 1,M
   10       C(I,J) = 0.0
   11 CONTINUE
C
      MLP1 = ML + 1
      NLP1 = NL + 1
      NPML = N + ML
      NPNU = N + NU
      MCL = MIN0(M - 1,ML + NL)
      JC = 0
      IF (MCL .EQ. 0) GO TO 100
C
C     FIND THE FIRST NONZERO LOWER DIAGONAL
C
      MAXD = MCL
      DO 31 NDIAG = 1,MAXD
         IMJ = MAXD + 1 - NDIAG
         JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU)
         DO 21 J = 1,JMAX
            I = J + IMJ
            SUM = 0.0
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 20 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
   20       CONTINUE
            C(I,1) = SUM
   21    CONTINUE
C
         DO 30 J = 1,JMAX
            I = J + IMJ
            IF (C(I,1) .NE. 0.0) GO TO 40
   30    CONTINUE
         MCL = MCL - 1
   31 CONTINUE
      GO TO 100
C
   40 IF (MCL .GE. NC) GO TO 100
      JC = 1
      IF (MCL .EQ. 1) GO TO 100
C
C     COMPUTE THE REMAINING LOWER DIAGONALS
C
      MIND = NDIAG + 1
      DO 52 NDIAG = MIND,MAXD
         JC = JC + 1
         IMJ = MAXD + 1 - NDIAG
         JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU)
         DO 51 J = 1,JMAX
            I = J + IMJ
            SUM = 0.0
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 50 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
   50       CONTINUE
            C(I,JC) = SUM
   51    CONTINUE
   52 CONTINUE
C
C     FIND THE LAST NONZERO UPPER DIAGONAL
C
  100 JC = JC + 1
      MCU = MIN0(L - 1,MU + NU)
      IF (MCU .EQ. 0) GO TO 130
C
      MAXD = MCU
      DO 121 NDIAG = 1,MAXD
         JMI = MAXD + 1 - NDIAG
         IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI)
         DO 111 I = 1,IMAX
            J = I + JMI
            SUM = 0.0
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 110 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
  110       CONTINUE
            C(I,JC) = SUM
  111    CONTINUE
C
         DO 120 I = 1,IMAX
            IF (C(I,JC) .NE. 0.0) GO TO 130
  120    CONTINUE
         MCU = MCU - 1
  121 CONTINUE
C
  130 LAST = MCL + MCU + 1
      IF (LAST .GT. NC) GO TO 200
      IF (MCU .EQ. 0) GO TO 140
      DO 131 I = 1,IMAX
         C(I,LAST) = C(I,JC)
         C(I,JC) = 0.0
  131 CONTINUE
C
C     COMPUTE THE MAIN DIAGONAL AND THE REMAINING UPPER DIAGONALS
C
  140 MAXD = MAX0(1,MCU)
      DO 143 NDIAG = 1,MAXD
         JMI = NDIAG - 1
         IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI)
         DO 142 I = 1,IMAX
            J = I + JMI
            SUM = 0.0
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 141 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
  141       CONTINUE
            C(I,JC) = SUM
  142    CONTINUE
         JC = JC + 1
  143 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = LAST
      RETURN
      END
      SUBROUTINE DBPROD (M, N, L, A, KA, ML, MU, B, KB, NL, NU,
     *                   C, KC, NC, MCL, MCU, IERR)
C-----------------------------------------------------------------------
C          MULTIPLICATION OF DOUBLE PRECISION BANDED MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), B(KB,*), C(KC,NC)
      DOUBLE PRECISION SUM
C
      IERR = 0
      DO 11 J = 1,NC
         DO 10 I = 1,M
   10       C(I,J) = 0.D0
   11 CONTINUE
C
      MLP1 = ML + 1
      NLP1 = NL + 1
      NPML = N + ML
      NPNU = N + NU
      MCL = MIN0(M - 1,ML + NL)
      JC = 0
      IF (MCL .EQ. 0) GO TO 100
C
C     FIND THE FIRST NONZERO LOWER DIAGONAL
C
      MAXD = MCL
      DO 31 NDIAG = 1,MAXD
         IMJ = MAXD + 1 - NDIAG
         JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU)
         DO 21 J = 1,JMAX
            I = J + IMJ
            SUM = 0.D0
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 20 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
   20       CONTINUE
            C(I,1) = SUM
   21    CONTINUE
C
         DO 30 J = 1,JMAX
            I = J + IMJ
            IF (C(I,1) .NE. 0.D0) GO TO 40
   30    CONTINUE
         MCL = MCL - 1
   31 CONTINUE
      GO TO 100
C
   40 IF (MCL .GE. NC) GO TO 100
      JC = 1
      IF (MCL .EQ. 1) GO TO 100
C
C     COMPUTE THE REMAINING LOWER DIAGONALS
C
      MIND = NDIAG + 1
      DO 52 NDIAG = MIND,MAXD
         JC = JC + 1
         IMJ = MAXD + 1 - NDIAG
         JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU)
         DO 51 J = 1,JMAX
            I = J + IMJ
            SUM = 0.D0
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 50 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
   50       CONTINUE
            C(I,JC) = SUM
   51    CONTINUE
   52 CONTINUE
C
C     FIND THE LAST NONZERO UPPER DIAGONAL
C
  100 JC = JC + 1
      MCU = MIN0(L - 1,MU + NU)
      IF (MCU .EQ. 0) GO TO 130
C
      MAXD = MCU
      DO 121 NDIAG = 1,MAXD
         JMI = MAXD + 1 - NDIAG
         IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI)
         DO 111 I = 1,IMAX
            J = I + JMI
            SUM = 0.D0
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 110 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
  110       CONTINUE
            C(I,JC) = SUM
  111    CONTINUE
C
         DO 120 I = 1,IMAX
            IF (C(I,JC) .NE. 0.D0) GO TO 130
  120    CONTINUE
         MCU = MCU - 1
  121 CONTINUE
C
  130 LAST = MCL + MCU + 1
      IF (LAST .GT. NC) GO TO 200
      IF (MCU .EQ. 0) GO TO 140
      DO 131 I = 1,IMAX
         C(I,LAST) = C(I,JC)
         C(I,JC) = 0.D0
  131 CONTINUE
C
C     COMPUTE THE MAIN DIAGONAL AND THE REMAINING UPPER DIAGONALS
C
  140 MAXD = MAX0(1,MCU)
      DO 143 NDIAG = 1,MAXD
         JMI = NDIAG - 1
         IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI)
         DO 142 I = 1,IMAX
            J = I + JMI
            SUM = 0.D0
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 141 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
  141       CONTINUE
            C(I,JC) = SUM
  142    CONTINUE
         JC = JC + 1
  143 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = LAST
      RETURN
      END
      SUBROUTINE CBPROD (M, N, L, A, KA, ML, MU, B, KB, NL, NU,
     *                   C, KC, NC, MCL, MCU, IERR)
C-----------------------------------------------------------------------
C             MULTIPLICATION OF COMPLEX BANDED MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(KA,*), B(KB,*), C(KC,NC)
      COMPLEX SUM
C
      IERR = 0
      DO 11 J = 1,NC
         DO 10 I = 1,M
   10       C(I,J) = (0.0,0.0)
   11 CONTINUE
C
      MLP1 = ML + 1
      NLP1 = NL + 1
      NPML = N + ML
      NPNU = N + NU
      MCL = MIN0(M - 1,ML + NL)
      JC = 0
      IF (MCL .EQ. 0) GO TO 100
C
C     FIND THE FIRST NONZERO LOWER DIAGONAL
C
      MAXD = MCL
      DO 31 NDIAG = 1,MAXD
         IMJ = MAXD + 1 - NDIAG
         JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU)
         DO 21 J = 1,JMAX
            I = J + IMJ
            SUM = (0.0,0.0)
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 20 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
   20       CONTINUE
            C(I,1) = SUM
   21    CONTINUE
C
         DO 30 J = 1,JMAX
            I = J + IMJ
            IF (C(I,1) .NE. (0.0,0.0)) GO TO 40
   30    CONTINUE
         MCL = MCL - 1
   31 CONTINUE
      GO TO 100
C
   40 IF (MCL .GE. NC) GO TO 100
      JC = 1
      IF (MCL .EQ. 1) GO TO 100
C
C     COMPUTE THE REMAINING LOWER DIAGONALS
C
      MIND = NDIAG + 1
      DO 52 NDIAG = MIND,MAXD
         JC = JC + 1
         IMJ = MAXD + 1 - NDIAG
         JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU)
         DO 51 J = 1,JMAX
            I = J + IMJ
            SUM = (0.0,0.0)
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 50 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
   50       CONTINUE
            C(I,JC) = SUM
   51    CONTINUE
   52 CONTINUE
C
C     FIND THE LAST NONZERO UPPER DIAGONAL
C
  100 JC = JC + 1
      MCU = MIN0(L - 1,MU + NU)
      IF (MCU .EQ. 0) GO TO 130
C
      MAXD = MCU
      DO 121 NDIAG = 1,MAXD
         JMI = MAXD + 1 - NDIAG
         IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI)
         DO 111 I = 1,IMAX
            J = I + JMI
            SUM = (0.0,0.0)
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 110 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
  110       CONTINUE
            C(I,JC) = SUM
  111    CONTINUE
C
         DO 120 I = 1,IMAX
            IF (C(I,JC) .NE. (0.0,0.0)) GO TO 130
  120    CONTINUE
         MCU = MCU - 1
  121 CONTINUE
C
  130 LAST = MCL + MCU + 1
      IF (LAST .GT. NC) GO TO 200
      IF (MCU .EQ. 0) GO TO 140
      DO 131 I = 1,IMAX
         C(I,LAST) = C(I,JC)
         C(I,JC) = (0.0,0.0)
  131 CONTINUE
C
C     COMPUTE THE MAIN DIAGONAL AND THE REMAINING UPPER DIAGONALS
C
  140 MAXD = MAX0(1,MCU)
      DO 143 NDIAG = 1,MAXD
         JMI = NDIAG - 1
         IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI)
         DO 142 I = 1,IMAX
            J = I + JMI
            SUM = (0.0,0.0)
            KMIN = MAX0(1,I - ML,J - NU)
            KMAX = MIN0(N,I + MU,J + NL)
            KK = MLP1 - I + KMIN
            JJ = NLP1 + J - KMIN
            DO 141 K = KMIN,KMAX
               SUM = SUM + A(I,KK)*B(K,JJ)
               KK = KK + 1
               JJ = JJ - 1
  141       CONTINUE
            C(I,JC) = SUM
  142    CONTINUE
         JC = JC + 1
  143 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = LAST
      RETURN
      END
      SUBROUTINE BVPRD (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C         PRODUCT OF A REAL BANDED MATRIX AND A REAL VECTOR
C-----------------------------------------------------------------------
      REAL A(KA,*), X(N), Y(M)
C
C     COMPUTE THE FIRST ML COMPONENTS
C
      MLP1 = ML + 1
      IF (ML .EQ. 0) GO TO 20
      JMIN = MLP1
      DO 11 I = 1,ML
         KMAX = MIN0(N,I + MU)
         KK = JMIN
         SUM = 0.0
         DO 10 K = 1,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   10    CONTINUE
         Y(I) = SUM
         JMIN = JMIN - 1
   11 CONTINUE
C
C     COMPUTE THE REMAINING NONZERO COMPONENTS
C
   20 IMAX = MIN0(M,N + ML)
      DO 22 I = MLP1,IMAX
         KMIN = I - ML
         KMAX = MIN0(N,I + MU)
         KK = 1
         SUM = 0.0
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   21    CONTINUE
         Y(I) = SUM
   22 CONTINUE
C
C     STORE ZEROS IN THE FINAL M-IMAX COMPONENTS
C
      IF (IMAX .EQ. M) RETURN
      IMIN = IMAX + 1
      DO 30 I = IMIN,M
         Y(I) = 0.0
   30 CONTINUE
      RETURN
      END
      SUBROUTINE BVPRD1 (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C        SETTING Y = A*X + Y WHERE A IS A REAL BANDED MATRIX
C                     AND X,Y ARE REAL VECTORS
C-----------------------------------------------------------------------
      REAL A(KA,*), X(N), Y(M)
C
C     COMPUTE THE FIRST ML COMPONENTS
C
      MLP1 = ML + 1
      IF (ML .EQ. 0) GO TO 20
      JMIN = MLP1
      DO 11 I = 1,ML
         KMAX = MIN0(N,I + MU)
         KK = JMIN
         SUM = Y(I)
         DO 10 K = 1,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   10    CONTINUE
         Y(I) = SUM
         JMIN = JMIN - 1
   11 CONTINUE
C
C     COMPUTE THE REMAINING COMPONENTS
C
   20 IMAX = MIN0(M,N + ML)
      DO 22 I = MLP1,IMAX
         KMIN = I - ML
         KMAX = MIN0(N,I + MU)
         KK = 1
         SUM = Y(I)
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   21    CONTINUE
         Y(I) = SUM
   22 CONTINUE
      RETURN
      END
      SUBROUTINE DBVPD (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C           PRODUCT OF A DOUBLE PRECISION BANDED MATRIX
C                  AND A DOUBLE PRECISION VECTOR
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), X(N), Y(M)
      DOUBLE PRECISION SUM
C
C     COMPUTE THE FIRST ML COMPONENTS
C
      MLP1 = ML + 1
      IF (ML .EQ. 0) GO TO 20
      JMIN = MLP1
      DO 11 I = 1,ML
         KMAX = MIN0(N,I + MU)
         KK = JMIN
         SUM = 0.D0
         DO 10 K = 1,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   10    CONTINUE
         Y(I) = SUM
         JMIN = JMIN - 1
   11 CONTINUE
C
C     COMPUTE THE REMAINING NONZERO COMPONENTS
C
   20 IMAX = MIN0(M,N + ML)
      DO 22 I = MLP1,IMAX
         KMIN = I - ML
         KMAX = MIN0(N,I + MU)
         KK = 1
         SUM = 0.D0
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   21    CONTINUE
         Y(I) = SUM
   22 CONTINUE
C
C     STORE ZEROS IN THE FINAL M-IMAX COMPONENTS
C
      IF (IMAX .EQ. M) RETURN
      IMIN = IMAX + 1
      DO 30 I = IMIN,M
         Y(I) = 0.D0
   30 CONTINUE
      RETURN
      END
      SUBROUTINE DBVPD1 (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C         SETTING Y = A*X + Y WHERE A IS A DOUBLE PRECISION
C         BANDED MATRIX AND X,Y ARE DOUBLE PRECISION VECTORS
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), X(N), Y(M)
      DOUBLE PRECISION SUM
C
C     COMPUTE THE FIRST ML COMPONENTS
C
      MLP1 = ML + 1
      IF (ML .EQ. 0) GO TO 20
      JMIN = MLP1
      DO 11 I = 1,ML
         KMAX = MIN0(N,I + MU)
         KK = JMIN
         SUM = Y(I)
         DO 10 K = 1,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   10    CONTINUE
         Y(I) = SUM
         JMIN = JMIN - 1
   11 CONTINUE
C
C     COMPUTE THE REMAINING COMPONENTS
C
   20 IMAX = MIN0(M,N + ML)
      DO 22 I = MLP1,IMAX
         KMIN = I - ML
         KMAX = MIN0(N,I + MU)
         KK = 1
         SUM = Y(I)
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   21    CONTINUE
         Y(I) = SUM
   22 CONTINUE
      RETURN
      END
      SUBROUTINE CBVPD (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C        PRODUCT OF A COMPLEX BANDED MATRIX AND A COMPLEX VECTOR
C-----------------------------------------------------------------------
      COMPLEX A(KA,*), X(N), Y(M)
      COMPLEX SUM
C
C     COMPUTE THE FIRST ML COMPONENTS
C
      MLP1 = ML + 1
      IF (ML .EQ. 0) GO TO 20
      JMIN = MLP1
      DO 11 I = 1,ML
         KMAX = MIN0(N,I + MU)
         KK = JMIN
         SUM = (0.0,0.0)
         DO 10 K = 1,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   10    CONTINUE
         Y(I) = SUM
         JMIN = JMIN - 1
   11 CONTINUE
C
C     COMPUTE THE REMAINING NONZERO COMPONENTS
C
   20 IMAX = MIN0(M,N + ML)
      DO 22 I = MLP1,IMAX
         KMIN = I - ML
         KMAX = MIN0(N,I + MU)
         KK = 1
         SUM = (0.0,0.0)
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   21    CONTINUE
         Y(I) = SUM
   22 CONTINUE
C
C     STORE ZEROS IN THE FINAL M-IMAX COMPONENTS
C
      IF (IMAX .EQ. M) RETURN
      IMIN = IMAX + 1
      DO 30 I = IMIN,M
         Y(I) = (0.0,0.0)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE CBVPD1 (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C        SETTING Y = A*X + Y WHERE A IS A COMPLEX BANDED MATRIX
C                     AND X,Y ARE COMPLEX VECTORS
C-----------------------------------------------------------------------
      COMPLEX A(KA,*), X(N), Y(M)
      COMPLEX SUM
C
C     COMPUTE THE FIRST ML COMPONENTS
C
      MLP1 = ML + 1
      IF (ML .EQ. 0) GO TO 20
      JMIN = MLP1
      DO 11 I = 1,ML
         KMAX = MIN0(N,I + MU)
         KK = JMIN
         SUM = Y(I)
         DO 10 K = 1,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   10    CONTINUE
         Y(I) = SUM
         JMIN = JMIN - 1
   11 CONTINUE
C
C     COMPUTE THE REMAINING COMPONENTS
C
   20 IMAX = MIN0(M,N + ML)
      DO 22 I = MLP1,IMAX
         KMIN = I - ML
         KMAX = MIN0(N,I + MU)
         KK = 1
         SUM = Y(I)
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(I,KK)*X(K)
            KK = KK + 1
   21    CONTINUE
         Y(I) = SUM
   22 CONTINUE
      RETURN
      END
      SUBROUTINE BTPRD (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C         PRODUCT OF A REAL VECTOR AND A REAL BANDED MATRIX
C-----------------------------------------------------------------------
      REAL A(KA,*), X(M), Y(N)
C
C     COMPUTE THE FIRST MU COMPONENTS
C
      IF (MU .EQ. 0) GO TO 20
      DO 11 J = 1,MU
         JJ = ML + J
         KMAX = MIN0(M,JJ)
         SUM = 0.0
         DO 10 K = 1,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   10    CONTINUE
         Y(J) = SUM
   11 CONTINUE
C
C     COMPUTE THE REMAINING NONZERO COMPONENTS
C
   20 NUM = ML + MU + 1
      JMIN = MU + 1
      JMAX = MIN0(N,M + MU)
      DO 22 J = JMIN,JMAX
         KMIN = J - MU
         KMAX = MIN0(M,J + ML)
         JJ = NUM
         SUM = 0.0
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   21    CONTINUE
         Y(J) = SUM
   22 CONTINUE
C
C     STORE ZEROS IN THE FINAL N-JMAX COMPONENTS
C
      IF (JMAX .EQ. N) RETURN
      JMIN = JMAX + 1
      DO 30 J = JMIN,N
         Y(J) = 0.0
   30 CONTINUE
      RETURN
      END
      SUBROUTINE BTPRD1 (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C        SETTING Y = X*A + Y WHERE A IS A REAL BANDED MATRIX
C                     AND X,Y ARE REAL VECTORS
C-----------------------------------------------------------------------
      REAL A(KA,*), X(M), Y(N)
C
C     COMPUTE THE FIRST MU COMPONENTS
C
      IF (MU .EQ. 0) GO TO 20
      DO 11 J = 1,MU
         JJ = ML + J
         KMAX = MIN0(M,JJ)
         SUM = Y(J)
         DO 10 K = 1,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   10    CONTINUE
         Y(J) = SUM
   11 CONTINUE
C
C     COMPUTE THE REMAINING COMPONENTS
C
   20 NUM = ML + MU + 1
      JMIN = MU + 1
      JMAX = MIN0(N,M + MU)
      DO 22 J = JMIN,JMAX
         KMIN = J - MU
         KMAX = MIN0(M,J + ML)
         JJ = NUM
         SUM = Y(J)
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   21    CONTINUE
         Y(J) = SUM
   22 CONTINUE
      RETURN
      END
      SUBROUTINE DBTPD (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C              PRODUCT OF A DOUBLE PRECISION VECTOR AND
C                  A DOUBLE PRECISION BANDED MATRIX
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), X(M), Y(N)
      DOUBLE PRECISION SUM
C
C     COMPUTE THE FIRST MU COMPONENTS
C
      IF (MU .EQ. 0) GO TO 20
      DO 11 J = 1,MU
         JJ = ML + J
         KMAX = MIN0(M,JJ)
         SUM = 0.D0
         DO 10 K = 1,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   10    CONTINUE
         Y(J) = SUM
   11 CONTINUE
C
C     COMPUTE THE REMAINING NONZERO COMPONENTS
C
   20 NUM = ML + MU + 1
      JMIN = MU + 1
      JMAX = MIN0(N,M + MU)
      DO 22 J = JMIN,JMAX
         KMIN = J - MU
         KMAX = MIN0(M,J + ML)
         JJ = NUM
         SUM = 0.D0
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   21    CONTINUE
         Y(J) = SUM
   22 CONTINUE
C
C     STORE ZEROS IN THE FINAL N-JMAX COMPONENTS
C
      IF (JMAX .EQ. N) RETURN
      JMIN = JMAX + 1
      DO 30 J = JMIN,N
         Y(J) = 0.D0
   30 CONTINUE
      RETURN
      END
      SUBROUTINE DBTPD1 (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C         SETTING Y = X*A + Y WHERE A IS A DOUBLE PRECISION
C         BANDED MATRIX AND X,Y ARE DOUBLE PRECISION VECTORS
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), X(M), Y(N)
      DOUBLE PRECISION SUM
C
C     COMPUTE THE FIRST MU COMPONENTS
C
      IF (MU .EQ. 0) GO TO 20
      DO 11 J = 1,MU
         JJ = ML + J
         KMAX = MIN0(M,JJ)
         SUM = Y(J)
         DO 10 K = 1,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   10    CONTINUE
         Y(J) = SUM
   11 CONTINUE
C
C     COMPUTE THE REMAINING COMPONENTS
C
   20 NUM = ML + MU + 1
      JMIN = MU + 1
      JMAX = MIN0(N,M + MU)
      DO 22 J = JMIN,JMAX
         KMIN = J - MU
         KMAX = MIN0(M,J + ML)
         JJ = NUM
         SUM = Y(J)
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   21    CONTINUE
         Y(J) = SUM
   22 CONTINUE
      RETURN
      END
      SUBROUTINE CBTPD (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C        PRODUCT OF A COMPLEX VECTOR AND A COMPLEX BANDED MATRIX
C-----------------------------------------------------------------------
      COMPLEX A(KA,*), X(M), Y(N)
      COMPLEX SUM
C
C     COMPUTE THE FIRST MU COMPONENTS
C
      IF (MU .EQ. 0) GO TO 20
      DO 11 J = 1,MU
         JJ = ML + J
         KMAX = MIN0(M,JJ)
         SUM = (0.0,0.0)
         DO 10 K = 1,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   10    CONTINUE
         Y(J) = SUM
   11 CONTINUE
C
C     COMPUTE THE REMAINING NONZERO COMPONENTS
C
   20 NUM = ML + MU + 1
      JMIN = MU + 1
      JMAX = MIN0(N,M + MU)
      DO 22 J = JMIN,JMAX
         KMIN = J - MU
         KMAX = MIN0(M,J + ML)
         JJ = NUM
         SUM = (0.0,0.0)
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   21    CONTINUE
         Y(J) = SUM
   22 CONTINUE
C
C     STORE ZEROS IN THE FINAL N-JMAX COMPONENTS
C
      IF (JMAX .EQ. N) RETURN
      JMIN = JMAX + 1
      DO 30 J = JMIN,N
         Y(J) = (0.0,0.0)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE CBTPD1 (M,N,A,KA,ML,MU,X,Y)
C-----------------------------------------------------------------------
C        SETTING Y = X*A + Y WHERE A IS A COMPLEX BANDED MATRIX
C                     AND X,Y ARE COMPLEX VECTORS
C-----------------------------------------------------------------------
      COMPLEX A(KA,*), X(M), Y(N)
      COMPLEX SUM
C
C     COMPUTE THE FIRST MU COMPONENTS
C
      IF (MU .EQ. 0) GO TO 20
      DO 11 J = 1,MU
         JJ = ML + J
         KMAX = MIN0(M,JJ)
         SUM = Y(J)
         DO 10 K = 1,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   10    CONTINUE
         Y(J) = SUM
   11 CONTINUE
C
C     COMPUTE THE REMAINING COMPONENTS
C
   20 NUM = ML + MU + 1
      JMIN = MU + 1
      JMAX = MIN0(N,M + MU)
      DO 22 J = JMIN,JMAX
         KMIN = J - MU
         KMAX = MIN0(M,J + ML)
         JJ = NUM
         SUM = Y(J)
         DO 21 K = KMIN,KMAX
            SUM = SUM + A(K,JJ)*X(K)
            JJ = JJ - 1
   21    CONTINUE
         Y(J) = SUM
   22 CONTINUE
      RETURN
      END
      REAL FUNCTION BNRM (A, KA, M, N, ML, MU)
C-----------------------------------------------------------------------
C             COMPUTATION OF THE L-INFINITY NORM OF A
C                      REAL BANDED MATRIX A
C-----------------------------------------------------------------------
      REAL A(KA,*)
C
      NUM = ML + MU + 1
      BNRM = 0.0
      DO 20 I = 1,M
         SUM = 0.0
         DO 10 J = 1,NUM
            SUM = SUM + ABS(A(I,J))
   10    CONTINUE
         BNRM = AMAX1(BNRM, SUM)
   20 CONTINUE
      RETURN
      END
      REAL FUNCTION B1NRM (A, KA, M, N, ML, MU)
C-----------------------------------------------------------------------
C            COMPUTATION OF THE L1 NORM OF A BANDED MATRIX A
C-----------------------------------------------------------------------
      REAL A(*)
C
      INCR = KA - 1
      B1NRM = 0.0
C
C     GO DOWN THE FIRST COLUMN OF A
C
      IMIN = ML + 1
      IMAX = MIN0(M, IMIN + MU)
      DO 10 I = IMIN,IMAX
         B1NRM = AMAX1(B1NRM, SASUM(I,A(I),INCR))
   10 CONTINUE
      I = IMAX
      J = I - ML
      NUM = I
      IF (J .EQ. N) RETURN
      IF (I .EQ. M) GO TO 30
C
      IMIN = I + 1
      IMAX = MIN0(M, ML + N)
      DO 20 I = IMIN,IMAX
         B1NRM = AMAX1(B1NRM, SASUM(NUM,A(I),INCR))
   20 CONTINUE
      I = IMAX
      J = I - ML
      GO TO 50
C
C     PROCEED ALONG THE LAST ROW OF A
C
   30 JMAX = MU + 1
      IF (J .EQ. JMAX) GO TO 50
      JMIN = J + 1
      DO 40 J = JMIN,JMAX
         I = I + KA
         B1NRM = AMAX1(B1NRM, SASUM(NUM,A(I),INCR))
   40 CONTINUE
      J = JMAX
C
   50 IF (J .EQ. N .OR. NUM .EQ. 1) RETURN
         I = I + KA
         J = J + 1
         NUM = NUM - 1
         B1NRM = AMAX1(B1NRM, SASUM(NUM,A(I),INCR))
         GO TO 50
      END
      DOUBLE PRECISION FUNCTION DBNRM (A, KA, M, N, ML, MU)
C-----------------------------------------------------------------------
C             COMPUTATION OF THE L-INFINITY NORM OF A
C                DOUBLE PRECISION BANDED MATRIX A
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*)
      DOUBLE PRECISION SUM
C
      NUM = ML + MU + 1
      DBNRM = 0.D0
      DO 20 I = 1,M
         SUM = 0.D0
         DO 10 J = 1,NUM
            SUM = SUM + DABS(A(I,J))
   10    CONTINUE
         DBNRM = DMAX1(DBNRM, SUM)
   20 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DB1NRM (A, KA, M, N, ML, MU)
C-----------------------------------------------------------------------
C            COMPUTATION OF THE L1 NORM OF A DOUBLE PRECISION
C                            BANDED MATRIX A
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*)
      DOUBLE PRECISION DASUM
C
      INCR = KA - 1
      DB1NRM = 0.D0
C
C     GO DOWN THE FIRST COLUMN OF A
C
      IMIN = ML + 1
      IMAX = MIN0(M, IMIN + MU)
      DO 10 I = IMIN,IMAX
         DB1NRM = DMAX1(DB1NRM, DASUM(I,A(I),INCR))
   10 CONTINUE
      I = IMAX
      J = I - ML
      NUM = I
      IF (J .EQ. N) RETURN
      IF (I .EQ. M) GO TO 30
C
      IMIN = I + 1
      IMAX = MIN0(M, ML + N)
      DO 20 I = IMIN,IMAX
         DB1NRM = DMAX1(DB1NRM, DASUM(NUM,A(I),INCR))
   20 CONTINUE
      I = IMAX
      J = I - ML
      GO TO 50
C
C     PROCEED ALONG THE LAST ROW OF A
C
   30 JMAX = MU + 1
      IF (J .EQ. JMAX) GO TO 50
      JMIN = J + 1
      DO 40 J = JMIN,JMAX
         I = I + KA
         DB1NRM = DMAX1(DB1NRM, DASUM(NUM,A(I),INCR))
   40 CONTINUE
      J = JMAX
C
   50 IF (J .EQ. N .OR. NUM .EQ. 1) RETURN
         I = I + KA
         J = J + 1
         NUM = NUM - 1
         DB1NRM = DMAX1(DB1NRM, DASUM(NUM,A(I),INCR))
         GO TO 50
      END
      SUBROUTINE BSLV(M0,A,KA,N,ML,MU,B,IWK,IERR)
C ----------------------------------------------------------------------
C     BSLV EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE
C     THE NXN BANDED LINEAR SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES
C     IF BSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO-
C     SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED.
C     ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED
C     USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO BSLV.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     A,KA      2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE
C               KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1
C               COLUMNS CONTAIN THE MATRIX A IN BANDED FORM.
C
C     N         NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     ML        NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C     MU        NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C     B         ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND
C               SIDE DATA.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     A         AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND
C               THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C
C     B         THE SOLUTION OF THE EQUATIONS.
C
C     IWK       ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES.
C
C     IERR      INTEGER SPECIFYING THE STATUS OF THE RESULTS.
C               IERR=0 IF THE SOLUTION OF AX = B IS OBTAINED.
C               OTHERWISE IERR.NE.0.
C
C
C     AFTER AN INITIAL CALL TO BSLV, THE ROUTINE MAY BE RECALLED
C     WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT
C     A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. BSLV RETRIEVES THE
C     LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO
C     BSLV AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE IERR
C     IS NOT REFERENCED.
C ----------------------------------------------------------------------
      REAL A(KA,*),B(N)
      INTEGER IWK(N)
      IF (M0 .NE. 0) GO TO 10
C
C     ERROR CHECKING
C
      IF (N .LE. 0 .OR. N .GT. KA) GO TO 100
      IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110
      IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120
C
C     OBTAIN AN LU DECOMPOSITION OF A
C
      CALL SNBFA(A,KA,N,ML,MU,IWK,IERR)
      IF (IERR .NE. 0) RETURN
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   10 CALL SNBSL(A,KA,N,ML,MU,IWK,B,0)
      RETURN
C
C     ERROR RETURN
C
  100 IERR = -1
      RETURN
  110 IERR = -2
      RETURN
  120 IERR = -3
      RETURN
      END
      SUBROUTINE BSLV1(M0,A,KA,N,ML,MU,B,IWK,IERR)
C ----------------------------------------------------------------------
C     BSLV1 EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE
C     THE NXN BANDED LINEAR SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES
C     IF BSLV1 IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO-
C     SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED.
C     ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED
C     USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO BSLV1.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     A,KA      2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE
C               KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1
C               COLUMNS CONTAIN THE MATRIX A IN BANDED FORM.
C
C     N         NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     ML        NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C     MU        NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C     B         ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND
C               SIDE DATA.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     A         AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND
C               THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C
C     B         THE SOLUTION OF THE EQUATIONS.
C
C     IWK       ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES.
C
C     IERR      INTEGER SPECIFYING THE STATUS OF THE RESULTS.
C               IERR=0 IF THE SOLUTION OF XA = B IS OBTAINED.
C               OTHERWISE IERR.NE.0.
C
C
C     AFTER AN INITIAL CALL TO BSLV1, THE ROUTINE MAY BE RECALLED
C     WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT
C     A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. BSLV RETRIEVES THE
C     LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO
C     BSLV1 AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE IERR
C     IS NOT REFERENCED.
C ----------------------------------------------------------------------
      REAL A(KA,*),B(N)
      INTEGER IWK(N)
      IF (M0 .NE. 0) GO TO 10
C
C     ERROR CHECKING
C
      IF (N .LE. 0 .OR. N .GT. KA) GO TO 100
      IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110
      IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120
C
C     OBTAIN AN LU DECOMPOSITION OF A
C
      CALL SNBFA(A,KA,N,ML,MU,IWK,IERR)
      IF (IERR .NE. 0) RETURN
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   10 CALL SNBSL(A,KA,N,ML,MU,IWK,B,1)
      RETURN
C
C     ERROR RETURN
C
  100 IERR = -1
      RETURN
  110 IERR = -2
      RETURN
  120 IERR = -3
      RETURN
      END
      SUBROUTINE SNBFA (A, LDA, N, ML, MU, IPVT, INFO)
C ----------------------------------------------------------------------
C
C               SNBFA FACTORS A REAL BAND MATRIX BY ELIMINATION.
C
C                               --------
C     ON ENTRY
C
C        A       REAL(LDA, NC)
C                CONTAINS THE MATRIX IN BAND STORAGE. THE ROWS
C                OF THE ORIGINAL MATRIX ARE STORED IN THE ROWS
C                OF A AND THE DIAGONALS OF THE ORIGINAL MATRIX
C                ARE STORED IN COLUMNS 1 THROUGH ML+MU+1 OF A.
C                NC MUST BE .GE. 2*ML+MU+1 .
C                SEE THE COMMENTS BELOW FOR DETAILS.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY A. IT IS
C                ASSUMED THAT LDA .GE. N.
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C                0 .LE. MU .LT. N .
C                MORE EFFICIENT IF ML .LE. MU .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX IN BAND STORAGE
C                AND THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                =0  NORMAL VALUE
C                =K  IF  U(K,K) .EQ. 0. THIS IS NOT AN ERROR
C                CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                INDICATE THAT SNBSL WILL DIVIDE BY ZERO IF
C                IT IS CALLED.
C
C     BAND STORAGE
C
C           IF A0 IS THE MATRIX THEN THE FOLLOWING CODE WILL STORE
C           A0 IN BAND FORM.
C
C                   ML = (BAND WIDTH BELOW THE DIAGONAL)
C                   MU = (BAND WIDTH ABOVE THE DIAGONAL)
C                   DO 20 I = 1, N
C                      J1 = MAX0(1, I-ML)
C                      J2 = MIN0(N, I+MU)
C                      DO 10 J = J1, J2
C                         K = J - I + ML + 1
C                         A(I,K) = A0(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           THIS USES COLUMNS 1 THROUGH  ML + MU + 1  OF A.
C           FURTHERMORE, ML ADDITIONAL COLUMNS ARE NEEDED IN
C           A (STARTING WITH COLUMN  ML+MU+2) FOR ELEMENTS
C           GENERATED DURING THE TRIANGULARIZATION. THE TOTAL
C           NUMBER OF COLUMNS NEEDED IN A IS  2*ML+MU+1 .
C
C     EXAMPLE..  IF THE ORIGINAL MATRIX IS
C
C           11 12 13  0  0  0
C           21 22 23 24  0  0
C            0 32 33 34 35  0
C            0  0 43 44 45 46
C            0  0  0 54 55 56
C            0  0  0  0 65 66
C
C      THEN  N = 6, ML = 1, MU = 2, LDA .GE. 6  AND A SHOULD CONTAIN
C
C              11 12 13  +     , + = USED FOR PIVOTING
C           21 22 23 24  +
C           32 33 34 35  +
C           43 44 45 46  +
C           54 55 56  +  +
C           65 66  +  +  +
C
C     WRITTEN BY E.A.VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY.
C     MODIFIED BY A.H.MORRIS, NAVAL SURFACE WEAPONS CENTER.
C
C     SUBROUTINES AND FUNCTIONS
C        MIN0,ISAMAX,SAXPY,SSCAL,SSWAP
C ----------------------------------------------------------------------
      INTEGER LDA,N,ML,MU,INFO
      REAL A(LDA,*)
      INTEGER IPVT(N)
      REAL T
C
      INFO = 0
      IF (ML .EQ. 0) GO TO 100
      M = ML + MU + 1
C
C     SET FILL-IN COLUMNS TO ZERO
C
      DO 11 J = 1,ML
         JJ = M + J
         DO 10 I = 1,N
            A(I,JJ) = 0.0
   10    CONTINUE
   11 CONTINUE
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      ML1 = ML + 1
      MB = ML + MU
      N1 = N - 1
      LDB = LDA - 1
      DO 40 K = 1,N1
        LM = MIN0(N-K,ML)
        LMK = LM + K
        LM1 = LM + 1
        LM2 = ML1 - LM
C
C     SEARCH FOR PIVOT INDEX
C
        L = -ISAMAX(LM1, A(LMK,LM2), LDB) + LM1 + K
        IPVT(K) = L
        MP = MIN0(MB,N-K)
C
C     SWAP ROWS IF NECESSARY
C
        LL = ML1 + K - L
        IF (L .NE. K) CALL SSWAP(MP + 1, A(K,ML1), LDA, A(L,LL), LDA)
C
C     SKIP COLUMN REDUCTION IF PIVOT IS ZERO
C
        IF (A(K,ML1) .NE. 0.0) GO TO 20
           INFO = K
           GO TO 40
C
C     COMPUTE MULTIPLIERS
C
   20   T = -1.0/A(K,ML1)
        CALL SSCAL(LM, T, A(LMK,LM2), LDB)
C
C     ROW ELIMINATION WITH COLUMN INDEXING
C
        DO 30 J = 1,MP
           JJ = ML1 + J
           J1 = LM2 + J
           CALL SAXPY(LM, A(K,JJ), A(LMK,LM2), LDB, A(LMK,J1), LDB)
   30   CONTINUE
   40 CONTINUE
C
      IPVT(N) = N
      IF (A(N,ML1) .EQ. 0.0) INFO = N
      RETURN
C
C     CASE WHEN ML = 0
C
  100 DO 110 K = 1,N
        IPVT(K) = K
        IF (A(K,1) .EQ. 0.0) INFO = K
  110 CONTINUE
      RETURN
      END
      SUBROUTINE SNBSL (A,LDA,N,ML,MU,IPVT,B,JOB)
C ----------------------------------------------------------------------
C
C     SNBSL SOLVES THE REAL BAND SYSTEM A*X = B OR TRANS(A)*X = B
C     USING THE FACTORS COMPUTED BY SNBFA.
C
C                         ----------
C     ON ENTRY
C
C        A       REAL(LDA, NC)
C                THE OUTPUT FROM SNBFA.
C                NC MUST BE .GE. 2*ML+MU+1 .
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY A.
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SNBFA.
C
C        B       REAL(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B .
C                = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA.  IT WILL NOT OCCUR IF SNBFA AND SNBSL ARE
C        CALLED CORRECTLY AND SNBFA HAS SET INFO = 0.
C
C     WRITTEN BY E.A. VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY.
C     MODIFIED BY A.H. MORRIS, NAVAL SURFACE WEAPONS CENTER.
C
C     SUBROUTINES AND FUNCTIONS
C      SAXPY,SDOT
C
C     FORTRAN  MIN0
C ----------------------------------------------------------------------
      INTEGER LDA,N,ML,MU,JOB
      REAL A(LDA,*),B(N)
      INTEGER IPVT(N)
      REAL SDOT,T
      INTEGER K,KB,KLM,L,LB,LDB,LM,M,MLM,NM1
C
      M = MU + ML + 1
      IF (M .EQ. 1) GO TO 100
      ML1 = ML + 1
      ML2 = ML + 2
      NM1 = N - 1
      LDB = 1 - LDA
      IF (JOB .NE. 0) GO TO 50
C
C     JOB = 0 , SOLVE  A * X = B
C       FIRST SOLVE L*Y = B
C
      IF (ML .EQ. 0) GO TO 30
      DO 20 K = 1,NM1
         LM = MIN0(ML,N-K)
         L = IPVT(K)
         T = B(L)
         IF (L .EQ. K) GO TO 10
            B(L) = B(K)
            B(K) = T
   10    KLM = K + LM
         MLM = ML1 - LM
         CALL SAXPY(LM, T, A(KLM,MLM), LDB, B(K+1), 1)
   20 CONTINUE
C
C       NOW SOLVE  U*X = Y
C
   30 K = N
      DO 40 KB = 2,N
         B(K) = B(K)/A(K,ML1)
         LM = MIN0(K,M) - 1
         LB = K - LM
         T = -B(K)
         CALL SAXPY(LM, T, A(K-1,ML2), LDB, B(LB), 1)
         K = K - 1
   40 CONTINUE
      B(1) = B(1)/A(1,ML1)
      RETURN
C
C     JOB = NONZERO, SOLVE TRANS(A) * X = B
C       FIRST SOLVE  TRANS(U)*Y = B
C
   50 B(1) = B(1)/A(1,ML1)
      DO 60 K = 2,N
         LM = MIN0(K,M) - 1
         LB = K - LM
         T = SDOT(LM, A(K-1,ML2), LDB, B(LB), 1)
         B(K) = (B(K) - T)/A(K,ML1)
   60 CONTINUE
      IF (ML .EQ. 0) RETURN
C
C       NOW SOLVE TRANS(L)*X = Y
C
      DO 70 KB = 1,NM1
         K = N - KB
         LM = MIN0(ML,N-K)
         KLM = K + LM
         MLM = ML1 - LM
         B(K) = B(K) + SDOT(LM, A(KLM,MLM), LDB, B(K+1), 1)
         L = IPVT(K)
         IF (L .EQ. K) GO TO 70
            T = B(L)
            B(L) = B(K)
            B(K) = T
   70 CONTINUE
      RETURN
C
C     CASE WHEN ML = 0 AND MU = 0
C
  100 DO 110 K = 1,N
  110    B(K) = B(K)/A(K,1)
      RETURN
      END
      SUBROUTINE DBSLV (M0,A,KA,N,ML,MU,B,IWK,IERR)
C ----------------------------------------------------------------------
C     DBSLV EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE
C     THE NXN BANDED LINEAR SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES
C     IF DBSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO-
C     SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED.
C     ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED
C     USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO DBSLV.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     A,KA      2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE
C               KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1
C               COLUMNS CONTAIN THE MATRIX A IN BANDED FORM.
C
C     N         NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     ML        NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C     MU        NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C     B         ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND
C               SIDE DATA.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     A         AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND
C               THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C
C     B         THE SOLUTION OF THE EQUATIONS.
C
C     IWK       ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES.
C
C     IERR      INTEGER SPECIFYING THE STATUS OF THE RESULTS.
C               IERR=0 IF THE SOLUTION OF AX = B IS OBTAINED.
C               OTHERWISE IERR.NE.0.
C
C
C     AFTER AN INITIAL CALL TO DBSLV, THE ROUTINE MAY BE RECALLED
C     WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT
C     A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. DBSLV RETRIEVES THE
C     LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO
C     DBSLV AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE IERR
C     IS NOT REFERENCED.
C ----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), B(N)
      INTEGER IWK(N)
      IF (M0 .NE. 0) GO TO 10
C
C     ERROR CHECKING
C
      IF (N .LE. 0 .OR. N .GT. KA) GO TO 100
      IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110
      IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120
C
C     OBTAIN AN LU DECOMPOSITION OF A
C
      CALL DBFA(A,KA,N,ML,MU,IWK,IERR)
      IF (IERR .NE. 0) RETURN
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   10 CALL DBSL(A,KA,N,ML,MU,IWK,B,0)
      RETURN
C
C     ERROR RETURN
C
  100 IERR = -1
      RETURN
  110 IERR = -2
      RETURN
  120 IERR = -3
      RETURN
      END
      SUBROUTINE DBSLV1 (M0,A,KA,N,ML,MU,B,IWK,IERR)
C ----------------------------------------------------------------------
C     DBSLV1 EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE
C     THE NXN BANDED LINEAR SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES
C     IF DBSLV1 IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO-
C     SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED.
C     ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED
C     USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO DBSLV1.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     A,KA      2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE
C               KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1
C               COLUMNS CONTAIN THE MATRIX A IN BANDED FORM.
C
C     N         NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     ML        NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C     MU        NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C     B         ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND
C               SIDE DATA.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     A         AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND
C               THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C
C     B         THE SOLUTION OF THE EQUATIONS.
C
C     IWK       ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES.
C
C     IERR      INTEGER SPECIFYING THE STATUS OF THE RESULTS.
C               IERR=0 IF THE SOLUTION OF XA = B IS OBTAINED.
C               OTHERWISE IERR.NE.0.
C
C
C     AFTER AN INITIAL CALL TO DBSLV1, THE ROUTINE MAY BE RECALLED
C     WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT
C     A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. DBSLV RETRIEVES THE
C     LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO
C     DBSLV1 AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE IERR
C     IS NOT REFERENCED.
C ----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), B(N)
      INTEGER IWK(N)
      IF (M0 .NE. 0) GO TO 10
C
C     ERROR CHECKING
C
      IF (N .LE. 0 .OR. N .GT. KA) GO TO 100
      IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110
      IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120
C
C     OBTAIN AN LU DECOMPOSITION OF A
C
      CALL DBFA(A,KA,N,ML,MU,IWK,IERR)
      IF (IERR .NE. 0) RETURN
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   10 CALL DBSL(A,KA,N,ML,MU,IWK,B,1)
      RETURN
C
C     ERROR RETURN
C
  100 IERR = -1
      RETURN
  110 IERR = -2
      RETURN
  120 IERR = -3
      RETURN
      END
      SUBROUTINE DBFA (A, LDA, N, ML, MU, IPVT, INFO)
C ----------------------------------------------------------------------
C
C               DBFA FACTORS A REAL BAND MATRIX BY ELIMINATION.
C
C                               --------
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, NC)
C                CONTAINS THE MATRIX IN BAND STORAGE. THE ROWS
C                OF THE ORIGINAL MATRIX ARE STORED IN THE ROWS
C                OF A AND THE DIAGONALS OF THE ORIGINAL MATRIX
C                ARE STORED IN COLUMNS 1 THROUGH ML+MU+1 OF A.
C                NC MUST BE .GE. 2*ML+MU+1 .
C                SEE THE COMMENTS BELOW FOR DETAILS.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY A. IT IS
C                ASSUMED THAT LDA .GE. N.
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C                0 .LE. MU .LT. N .
C                MORE EFFICIENT IF ML .LE. MU .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX IN BAND STORAGE
C                AND THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                =0  NORMAL VALUE
C                =K  IF  U(K,K) .EQ. 0. THIS IS NOT AN ERROR
C                CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                INDICATE THAT DBSL WILL DIVIDE BY ZERO IF
C                IT IS CALLED.
C
C     BAND STORAGE
C
C           IF A0 IS THE MATRIX THEN THE FOLLOWING CODE WILL STORE
C           A0 IN BAND FORM.
C
C                   ML = (BAND WIDTH BELOW THE DIAGONAL)
C                   MU = (BAND WIDTH ABOVE THE DIAGONAL)
C                   DO 20 I = 1, N
C                      J1 = MAX0(1, I-ML)
C                      J2 = MIN0(N, I+MU)
C                      DO 10 J = J1, J2
C                         K = J - I + ML + 1
C                         A(I,K) = A0(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           THIS USES COLUMNS 1 THROUGH  ML + MU + 1  OF A.
C           FURTHERMORE, ML ADDITIONAL COLUMNS ARE NEEDED IN
C           A (STARTING WITH COLUMN  ML+MU+2) FOR ELEMENTS
C           GENERATED DURING THE TRIANGULARIZATION. THE TOTAL
C           NUMBER OF COLUMNS NEEDED IN A IS  2*ML+MU+1 .
C
C     EXAMPLE..  IF THE ORIGINAL MATRIX IS
C
C           11 12 13  0  0  0
C           21 22 23 24  0  0
C            0 32 33 34 35  0
C            0  0 43 44 45 46
C            0  0  0 54 55 56
C            0  0  0  0 65 66
C
C      THEN  N = 6, ML = 1, MU = 2, LDA .GE. 6  AND A SHOULD CONTAIN
C
C              11 12 13  +     , + = USED FOR PIVOTING
C           21 22 23 24  +
C           32 33 34 35  +
C           43 44 45 46  +
C           54 55 56  +  +
C           65 66  +  +  +
C
C     WRITTEN BY E.A.VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY.
C     MODIFIED BY A.H.MORRIS, NAVAL SURFACE WEAPONS CENTER.
C
C     SUBROUTINES AND FUNCTIONS
C        MIN0,IDAMAX,DAXPY,DSCAL,DSWAP
C ----------------------------------------------------------------------
      INTEGER LDA,N,ML,MU,INFO
      DOUBLE PRECISION A(LDA,*)
      INTEGER IPVT(N)
      DOUBLE PRECISION T
C
      INFO = 0
      IF (ML .EQ. 0) GO TO 100
      M = ML + MU + 1
C
C     SET FILL-IN COLUMNS TO ZERO
C
      DO 11 J = 1,ML
         JJ = M + J
         DO 10 I = 1,N
            A(I,JJ) = 0.D0
   10    CONTINUE
   11 CONTINUE
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      ML1 = ML + 1
      MB = ML + MU
      N1 = N - 1
      LDB = LDA - 1
      DO 40 K = 1,N1
        LM = MIN0(N-K,ML)
        LMK = LM + K
        LM1 = LM + 1
        LM2 = ML1 - LM
C
C     SEARCH FOR PIVOT INDEX
C
        L = -IDAMAX(LM1, A(LMK,LM2), LDB) + LM1 + K
        IPVT(K) = L
        MP = MIN0(MB,N-K)
C
C     SWAP ROWS IF NECESSARY
C
        LL = ML1 + K - L
        IF (L .NE. K) CALL DSWAP(MP + 1, A(K,ML1), LDA, A(L,LL), LDA)
C
C     SKIP COLUMN REDUCTION IF PIVOT IS ZERO
C
        IF (A(K,ML1) .NE. 0.D0) GO TO 20
           INFO = K
           GO TO 40
C
C     COMPUTE MULTIPLIERS
C
   20   T = -1.D0/A(K,ML1)
        CALL DSCAL(LM, T, A(LMK,LM2), LDB)
C
C     ROW ELIMINATION WITH COLUMN INDEXING
C
        DO 30 J = 1,MP
           JJ = ML1 + J
           J1 = LM2 + J
           CALL DAXPY(LM, A(K,JJ), A(LMK,LM2), LDB, A(LMK,J1), LDB)
   30   CONTINUE
   40 CONTINUE
C
      IPVT(N) = N
      IF (A(N,ML1) .EQ. 0.D0) INFO = N
      RETURN
C
C     CASE WHEN ML = 0
C
  100 DO 110 K = 1,N
        IPVT(K) = K
        IF (A(K,1) .EQ. 0.D0) INFO = K
  110 CONTINUE
      RETURN
      END
      SUBROUTINE DBSL (A,LDA,N,ML,MU,IPVT,B,JOB)
C ----------------------------------------------------------------------
C
C     DBSL SOLVES THE REAL BAND SYSTEM A*X = B OR TRANS(A)*X = B
C     USING THE FACTORS COMPUTED BY DBFA.
C
C                         ----------
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, NC)
C                THE OUTPUT FROM DBFA.
C                NC MUST BE .GE. 2*ML+MU+1 .
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY A.
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DBFA.
C
C        B       DOUBLE PRECISION(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B .
C                = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA.  IT WILL NOT OCCUR IF DBFA AND DBSL ARE
C        CALLED CORRECTLY AND DBFA HAS SET INFO = 0.
C
C     WRITTEN BY E.A. VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY.
C     MODIFIED BY A.H. MORRIS, NAVAL SURFACE WEAPONS CENTER.
C
C     SUBROUTINES AND FUNCTIONS
C      DAXPY,DDOT
C
C     FORTRAN  MIN0
C ----------------------------------------------------------------------
      INTEGER LDA,N,ML,MU,JOB
      DOUBLE PRECISION A(LDA,*),B(N)
      INTEGER IPVT(N)
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,KLM,L,LB,LDB,LM,M,MLM,NM1
C
      M = MU + ML + 1
      IF (M .EQ. 1) GO TO 100
      ML1 = ML + 1
      ML2 = ML + 2
      NM1 = N - 1
      LDB = 1 - LDA
      IF (JOB .NE. 0) GO TO 50
C
C     JOB = 0 , SOLVE  A * X = B
C       FIRST SOLVE L*Y = B
C
      IF (ML .EQ. 0) GO TO 30
      DO 20 K = 1,NM1
         LM = MIN0(ML,N-K)
         L = IPVT(K)
         T = B(L)
         IF (L .EQ. K) GO TO 10
            B(L) = B(K)
            B(K) = T
   10    KLM = K + LM
         MLM = ML1 - LM
         CALL DAXPY(LM, T, A(KLM,MLM), LDB, B(K+1), 1)
   20 CONTINUE
C
C       NOW SOLVE  U*X = Y
C
   30 K = N
      DO 40 KB = 2,N
         B(K) = B(K)/A(K,ML1)
         LM = MIN0(K,M) - 1
         LB = K - LM
         T = -B(K)
         CALL DAXPY(LM, T, A(K-1,ML2), LDB, B(LB), 1)
         K = K - 1
   40 CONTINUE
      B(1) = B(1)/A(1,ML1)
      RETURN
C
C     JOB = NONZERO, SOLVE TRANS(A) * X = B
C       FIRST SOLVE  TRANS(U)*Y = B
C
   50 B(1) = B(1)/A(1,ML1)
      DO 60 K = 2,N
         LM = MIN0(K,M) - 1
         LB = K - LM
         T = DDOT(LM, A(K-1,ML2), LDB, B(LB), 1)
         B(K) = (B(K) - T)/A(K,ML1)
   60 CONTINUE
      IF (ML .EQ. 0) RETURN
C
C       NOW SOLVE TRANS(L)*X = Y
C
      DO 70 KB = 1,NM1
         K = N - KB
         LM = MIN0(ML,N-K)
         KLM = K + LM
         MLM = ML1 - LM
         B(K) = B(K) + DDOT(LM, A(KLM,MLM), LDB, B(K+1), 1)
         L = IPVT(K)
         IF (L .EQ. K) GO TO 70
            T = B(L)
            B(L) = B(K)
            B(K) = T
   70 CONTINUE
      RETURN
C
C     CASE WHEN ML = 0 AND MU = 0
C
  100 DO 110 K = 1,N
  110    B(K) = B(K)/A(K,1)
      RETURN
      END
      SUBROUTINE B1CND (A, KA, N, ML, MU, COND, IWK, WK, IERR)
C-----------------------------------------------------------------------
C              COMPUTATION OF THE L1 CONDITION NUMBER
C                       OF A BANDED MATRIX A
C-----------------------------------------------------------------------
      REAL A(KA,*), WK(*)
      INTEGER IWK(*)
C-----------------------
C     REAL WK(2*N)
C     INTEGER IWK(2*N)
C-----------------------
      COND = 0.0
      IF (N .LE. 0 .OR. KA .LT. N) GO TO 100
      IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110
      IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120
C
      ANORM = B1NRM(A, KA, N, N, ML, MU)
      IF (ANORM .EQ. 0.0) GO TO 40
C
      IX = 1
      IV = N + 1
      ISGN = N + 1
C
      KASE = 0
      AINORM = 0.0
      CALL SONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE,
     *             ITER, J, JUMP)
      CALL BSLV (0, A, KA, N, ML, MU, WK(IX), IWK(1), IERR)
C
C     CHECK IF A IS SINGULAR
C
      IF (IERR .GT. 0) GO TO 40
C
C     GENERAL LOOP TO ESTIMATE THE NORM  AINORM
C     OF THE INVERSE OF A
C
   10 CALL SONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE,
     *             ITER, J, JUMP)
      IF (KASE .EQ. 0) GO TO 30
      IF (KASE .NE. 1) GO TO 20
         CALL BSLV (1, A, KA, N, ML, MU, WK(IX), IWK(1), IERR)
         GO TO 10
   20 CALL BSLV1 (1, A, KA, N, ML, MU, WK(IX), IWK(1), IERR)
      GO TO 10
C
C     COMPUTE THE VALUE OF COND
C
   30 COND = ANORM*AINORM
      RETURN
C
C     SINGULAR CASE
C
   40 IERR = 1
      RETURN
C
C     ERROR RETURN
C
  100 IERR = -1
      RETURN
  110 IERR = -2
      RETURN
  120 IERR = -3
      RETURN
      END
      SUBROUTINE DB1CND (A, KA, N, ML, MU, COND, IWK, WK, IERR)
C-----------------------------------------------------------------------
C            COMPUTATION OF THE L1 CONDITION NUMBER OF
C               A DOUBLE PRECISION BANDED MATRIX A
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,*), COND, WK(*)
      INTEGER IWK(*)
      DOUBLE PRECISION ANORM, AINORM
      DOUBLE PRECISION DB1NRM
C-----------------------
C     DOUBLE PRECISION WK(2*N)
C     INTEGER IWK(2*N)
C-----------------------
      COND = 0.D0
      IF (N .LE. 0 .OR. KA .LT. N) GO TO 100
      IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110
      IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120
C
      ANORM = DB1NRM(A, KA, N, N, ML, MU)
      IF (ANORM .EQ. 0.D0) GO TO 40
C
      IX = 1
      IV = N + 1
      ISGN = N + 1
C
      KASE = 0
      AINORM = 0.D0
      CALL DONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE,
     *             ITER, J, JUMP)
      CALL DBSLV (0, A, KA, N, ML, MU, WK(IX), IWK(1), IERR)
C
C     CHECK IF A IS SINGULAR
C
      IF (IERR .GT. 0) GO TO 40
C
C     GENERAL LOOP TO ESTIMATE THE NORM  AINORM
C     OF THE INVERSE OF A
C
   10 CALL DONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE,
     *             ITER, J, JUMP)
      IF (KASE .EQ. 0) GO TO 30
      IF (KASE .NE. 1) GO TO 20
         CALL DBSLV (1, A, KA, N, ML, MU, WK(IX), IWK(1), IERR)
         GO TO 10
   20 CALL DBSLV1 (1, A, KA, N, ML, MU, WK(IX), IWK(1), IERR)
      GO TO 10
C
C     COMPUTE THE VALUE OF COND
C
   30 COND = ANORM*AINORM
      RETURN
C
C     SINGULAR CASE
C
   40 IERR = 1
      RETURN
C
C     ERROR RETURN
C
  100 IERR = -1
      RETURN
  110 IERR = -2
      RETURN
  120 IERR = -3
      RETURN
      END
      SUBROUTINE CBSLV(M0,A,KA,N,ML,MU,B,IWK,IERR)
C ----------------------------------------------------------------------
C     CBSLV EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE
C     THE NXN COMPLEX BANDED SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES
C     IF CBSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO-
C     SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED.
C     ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED
C     USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO CBSLV.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     A,KA      2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE
C               KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1
C               COLUMNS CONTAIN THE MATRIX A IN BANDED FORM.
C               A IS A COMPLEX ARRAY.
C
C     N         NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     ML        NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C     MU        NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C     B         COMPLEX ARRAY OF N ENTRIES CONTAINING THE RIGHT
C               HAND SIDE DATA.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     A         AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND
C               THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C
C     B         THE SOLUTION OF THE EQUATIONS.
C
C     IWK       ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES.
C
C     IERR      INTEGER SPECIFYING THE STATUS OF THE RESULTS.
C               IERR=0 IF THE SOLUTION OF AX = B IS OBTAINED.
C               OTHERWISE IERR.NE.0.
C
C
C     AFTER AN INITIAL CALL TO CBSLV, THE ROUTINE MAY BE RECALLED
C     WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT
C     A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. CBSLV RETRIEVES THE
C     LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO
C     CBSLV AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE IERR
C     IS NOT REFERENCED.
C ----------------------------------------------------------------------
      COMPLEX A(KA,*),B(N)
      INTEGER IWK(N)
      IF (M0 .NE. 0) GO TO 10
C
C     ERROR CHECKING
C
      IF (N .LE. 0 .OR. N .GT. KA) GO TO 100
      IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110
      IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120
C
C     OBTAIN AN LU DECOMPOSITION OF A
C
      CALL CBFA(A,KA,N,ML,MU,IWK,IERR)
      IF (IERR .NE. 0) RETURN
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   10 CALL CBSL(A,KA,N,ML,MU,IWK,B,0)
      RETURN
C
C     ERROR RETURN
C
  100 IERR = -1
      RETURN
  110 IERR = -2
      RETURN
  120 IERR = -3
      RETURN
      END
      SUBROUTINE CBSLV1(M0,A,KA,N,ML,MU,B,IWK,IERR)
C ----------------------------------------------------------------------
C     CBSLV1 EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE
C     THE NXN COMPLEX BANDED SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES
C     IF CBSLV1 IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO-
C     SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED.
C     ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED
C     USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO CBSLV1.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     A,KA      2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE
C               KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1
C               COLUMNS CONTAIN THE MATRIX A IN BANDED FORM.
C               A IS A COMPLEX ARRAY.
C
C     N         NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     ML        NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C     MU        NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C     B         COMPLEX ARRAY OF N ENTRIES CONTAINING THE RIGHT
C               HAND SIDE DATA.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     A         AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND
C               THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C
C     B         THE SOLUTION OF THE EQUATIONS.
C
C     IWK       ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES.
C
C     IERR      INTEGER SPECIFYING THE STATUS OF THE RESULTS.
C               IERR=0 IF THE SOLUTION OF XA = B IS OBTAINED.
C               OTHERWISE IERR.NE.0.
C
C
C     AFTER AN INITIAL CALL TO CBSLV1, THE ROUTINE MAY BE RECALLED
C     WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT
C     A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. CBSLV RETRIEVES THE
C     LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO
C     CBSLV1 AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE IERR
C     IS NOT REFERENCED.
C ----------------------------------------------------------------------
      COMPLEX A(KA,*),B(N)
      INTEGER IWK(N)
      IF (M0 .NE. 0) GO TO 10
C
C     ERROR CHECKING
C
      IF (N .LE. 0 .OR. N .GT. KA) GO TO 100
      IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110
      IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120
C
C     OBTAIN AN LU DECOMPOSITION OF A
C
      CALL CBFA(A,KA,N,ML,MU,IWK,IERR)
      IF (IERR .NE. 0) RETURN
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   10 CALL CBSL(A,KA,N,ML,MU,IWK,B,1)
      RETURN
C
C     ERROR RETURN
C
  100 IERR = -1
      RETURN
  110 IERR = -2
      RETURN
  120 IERR = -3
      RETURN
      END
      SUBROUTINE CBFA (A, LDA, N, ML, MU, IPVT, INFO)
C ----------------------------------------------------------------------
C
C               CBFA FACTORS A COMPLEX BAND MATRIX BY ELIMINATION.
C
C                              ----------
C     ON ENTRY
C
C        A       COMPLEX(LDA, NC)
C                CONTAINS THE MATRIX IN BAND STORAGE. THE ROWS
C                OF THE ORIGINAL MATRIX ARE STORED IN THE ROWS
C                OF A AND THE DIAGONALS OF THE ORIGINAL MATRIX
C                ARE STORED IN COLUMNS 1 THROUGH ML+MU+1 OF A.
C                NC MUST BE .GE. 2*ML+MU+1 .
C                SEE THE COMMENTS BELOW FOR DETAILS.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY A. IT IS
C                ASSUMED THAT LDA .GE. N.
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C                0 .LE. MU .LT. N .
C                MORE EFFICIENT IF ML .LE. MU .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX IN BAND STORAGE
C                AND THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                =0  NORMAL VALUE
C                =K  IF  U(K,K) .EQ. 0. THIS IS NOT AN ERROR
C                CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                INDICATE THAT CBSL WILL DIVIDE BY ZERO IF
C                IT IS CALLED.
C
C     BAND STORAGE
C
C           IF A0 IS THE MATRIX THEN THE FOLLOWING CODE WILL STORE
C           A0 IN BAND FORM.
C
C                   ML = (BAND WIDTH BELOW THE DIAGONAL)
C                   MU = (BAND WIDTH ABOVE THE DIAGONAL)
C                   DO 20 I = 1, N
C                      J1 = MAX0(1, I-ML)
C                      J2 = MIN0(N, I+MU)
C                      DO 10 J = J1, J2
C                         K = J - I + ML + 1
C                         A(I,K) = A0(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           THIS USES COLUMNS 1 THROUGH  ML + MU + 1  OF A.
C           FURTHERMORE, ML ADDITIONAL COLUMNS ARE NEEDED IN
C           A (STARTING WITH COLUMN  ML+MU+2) FOR ELEMENTS
C           GENERATED DURING THE TRIANGULARIZATION. THE TOTAL
C           NUMBER OF COLUMNS NEEDED IN A IS  2*ML+MU+1 .
C
C     EXAMPLE..  IF THE ORIGINAL MATRIX IS
C
C           11 12 13  0  0  0
C           21 22 23 24  0  0
C            0 32 33 34 35  0
C            0  0 43 44 45 46
C            0  0  0 54 55 56
C            0  0  0  0 65 66
C
C      THEN  N = 6, ML = 1, MU = 2, LDA .GE. 6  AND A SHOULD CONTAIN
C
C              11 12 13  +     , + = USED FOR PIVOTING
C           21 22 23 24  +
C           32 33 34 35  +
C           43 44 45 46  +
C           54 55 56  +  +
C           65 66  +  +  +
C
C     WRITTEN BY E.A.VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY.
C     MODIFIED BY A.H.MORRIS, NAVAL SURFACE WEAPONS CENTER.
C
C     SUBROUTINES AND FUNCTIONS
C        MIN0,ICAMAX,CAXPY,CSCAL,CSWAP
C ----------------------------------------------------------------------
      INTEGER LDA,N,ML,MU,INFO
      COMPLEX A(LDA,*)
      INTEGER IPVT(N)
      COMPLEX T
C
      INFO = 0
      IF (ML .EQ. 0) GO TO 100
      M = ML + MU + 1
C
C     SET FILL-IN COLUMNS TO ZERO
C
      DO 11 J = 1,ML
         JJ = M + J
         DO 10 I = 1,N
            A(I,JJ) = (0.0,0.0)
   10    CONTINUE
   11 CONTINUE
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      ML1 = ML + 1
      MB = ML + MU
      N1 = N - 1
      LDB = LDA - 1
      DO 40 K = 1,N1
        LM = MIN0(N-K,ML)
        LMK = LM + K
        LM1 = LM + 1
        LM2 = ML1 - LM
C
C     SEARCH FOR PIVOT INDEX
C
        L = -ICAMAX(LM1, A(LMK,LM2), LDB) + LM1 + K
        IPVT(K) = L
        MP = MIN0(MB,N-K)
C
C     SWAP ROWS IF NECESSARY
C
        LL = ML1 + K - L
        IF (L .NE. K) CALL CSWAP(MP + 1, A(K,ML1), LDA, A(L,LL), LDA)
C
C     SKIP COLUMN REDUCTION IF PIVOT IS ZERO
C
        IF (A(K,ML1) .NE. (0.0,0.0)) GO TO 20
           INFO = K
           GO TO 40
C
C     COMPUTE MULTIPLIERS
C
   20   T = (-1.0,0.0)/A(K,ML1)
        CALL CSCAL(LM, T, A(LMK,LM2), LDB)
C
C     ROW ELIMINATION WITH COLUMN INDEXING
C
        DO 30 J = 1,MP
           JJ = ML1 + J
           J1 = LM2 + J
           CALL CAXPY(LM, A(K,JJ), A(LMK,LM2), LDB, A(LMK,J1), LDB)
   30   CONTINUE
   40 CONTINUE
C
      IPVT(N) = N
      IF (A(N,ML1) .EQ. (0.0,0.0)) INFO = N
      RETURN
C
C     CASE WHEN ML = 0
C
  100 DO 110 K = 1,N
        IPVT(K) = K
        IF (A(K,1) .EQ. (0.0,0.0)) INFO = K
  110 CONTINUE
      RETURN
      END
      SUBROUTINE CBSL (A,LDA,N,ML,MU,IPVT,B,JOB)
C ----------------------------------------------------------------------
C
C     CBSL SOLVES THE COMPLEX BAND SYSTEM A*X = B OR TRANS(A)*X = B
C     USING THE FACTORS COMPUTED BY CBFA.
C
C                         ----------
C     ON ENTRY
C
C        A       COMPLEX(LDA, NC)
C                THE OUTPUT FROM CBFA.
C                NC MUST BE .GE. 2*ML+MU+1 .
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY A.
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM CBFA.
C
C        B       COMPLEX(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B .
C                = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA.  IT WILL NOT OCCUR IF CBFA AND CBSL ARE
C        CALLED CORRECTLY AND CBFA HAS SET INFO = 0.
C
C     WRITTEN BY E.A. VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY.
C     ADAPTED BY A.H. MORRIS, NAVAL SURFACE WEAPONS CENTER.
C
C     SUBROUTINES AND FUNCTIONS
C      CAXPY,CDOTU
C
C     FORTRAN  MIN0
C ----------------------------------------------------------------------
      INTEGER LDA,N,ML,MU,JOB
      COMPLEX A(LDA,*),B(N)
      INTEGER IPVT(N)
      COMPLEX CDOTU,T
      INTEGER K,KB,KLM,L,LB,LDB,LM,M,MLM,NM1
C
      M = MU + ML + 1
      IF (M .EQ. 1) GO TO 100
      ML1 = ML + 1
      ML2 = ML + 2
      NM1 = N - 1
      LDB = 1 - LDA
      IF (JOB .NE. 0) GO TO 50
C
C     JOB = 0 , SOLVE  A * X = B
C       FIRST SOLVE L*Y = B
C
      IF (ML .EQ. 0) GO TO 30
      DO 20 K = 1,NM1
         LM = MIN0(ML,N-K)
         L = IPVT(K)
         T = B(L)
         IF (L .EQ. K) GO TO 10
            B(L) = B(K)
            B(K) = T
   10    KLM = K + LM
         MLM = ML1 - LM
         CALL CAXPY(LM, T, A(KLM,MLM), LDB, B(K+1), 1)
   20 CONTINUE
C
C       NOW SOLVE  U*X = Y
C
   30 K = N
      DO 40 KB = 2,N
         B(K) = B(K)/A(K,ML1)
         LM = MIN0(K,M) - 1
         LB = K - LM
         T = -B(K)
         CALL CAXPY(LM, T, A(K-1,ML2), LDB, B(LB), 1)
         K = K - 1
   40 CONTINUE
      B(1) = B(1)/A(1,ML1)
      RETURN
C
C     JOB = NONZERO, SOLVE TRANS(A) * X = B
C       FIRST SOLVE  TRANS(U)*Y = B
C
   50 B(1) = B(1)/A(1,ML1)
      DO 60 K = 2,N
         LM = MIN0(K,M) - 1
         LB = K - LM
         T = CDOTU(LM, A(K-1,ML2), LDB, B(LB), 1)
         B(K) = (B(K) - T)/A(K,ML1)
   60 CONTINUE
      IF (ML .EQ. 0) RETURN
C
C       NOW SOLVE TRANS(L)*X = Y
C
      DO 70 KB = 1, NM1
         K = N - KB
         LM = MIN0(ML,N-K)
         KLM = K + LM
         MLM = ML1 - LM
         B(K) = B(K) + CDOTU(LM, A(KLM,MLM), LDB, B(K+1), 1)
         L = IPVT(K)
         IF (L .EQ. K) GO TO 70
            T = B(L)
            B(L) = B(K)
            B(K) = T
   70 CONTINUE
      RETURN
C
C     CASE WHEN ML = 0 AND MU = 0
C
  100 DO 110 K = 1,N
  110    B(K) = B(K)/A(K,1)
      RETURN
      END
      SUBROUTINE CVRS (A, KA, M, N, B, IB, JB, NUM, IERR)
      REAL A(KA,N), B(*)
      INTEGER IB(*), JB(*)
C
C                 STORE THE I-TH ROW
C
      IP = 1
      DO 11 I = 1,M
         IB(I) = IP
         DO 10 J = 1,N
            IF (A(I,J) .EQ. 0.0) GO TO 10
            IF (IP .GT. NUM) GO TO 20
            B(IP) = A(I,J)
            JB(IP) = J
            IP = IP + 1
   10    CONTINUE
   11 CONTINUE
C
C                 COMPLETE THE SETUP
C
      IB(M + 1) = IP
      IERR = 0
      RETURN
C
C                   ERROR RETURN
C
   20 IERR = I
      RETURN
      END
      SUBROUTINE CVDS (A, KA, M, N, B, IB, JB, NUM, IERR)
      DOUBLE PRECISION A(KA,N), B(*)
      INTEGER IB(*), JB(*)
C
C                 STORE THE I-TH ROW
C
      IP = 1
      DO 11 I = 1,M
         IB(I) = IP
         DO 10 J = 1,N
            IF (A(I,J) .EQ. 0.D0) GO TO 10
            IF (IP .GT. NUM) GO TO 20
            B(IP) = A(I,J)
            JB(IP) = J
            IP = IP + 1
   10    CONTINUE
   11 CONTINUE
C
C                 COMPLETE THE SETUP
C
      IB(M + 1) = IP
      IERR = 0
      RETURN
C
C                   ERROR RETURN
C
   20 IERR = I
      RETURN
      END
      SUBROUTINE CVCS (A, KA, M, N, B, IB, JB, NUM, IERR)
      COMPLEX A(KA,N), B(*), ZERO
      INTEGER IB(*), JB(*)
      DATA ZERO /(0.0,0.0)/
C
C                 STORE THE I-TH ROW
C
      IP = 1
      DO 11 I = 1,M
         IB(I) = IP
         DO 10 J = 1,N
            IF (A(I,J) .EQ. ZERO) GO TO 10
            IF (IP .GT. NUM) GO TO 20
            B(IP) = A(I,J)
            JB(IP) = J
            IP = IP + 1
   10    CONTINUE
   11 CONTINUE
C
C                 COMPLETE THE SETUP
C
      IB(M + 1) = IP
      IERR = 0
      RETURN
C
C                   ERROR RETURN
C
   20 IERR = I
      RETURN
      END
      SUBROUTINE CVSR (A, IA, JA, B, KB, M, N)
      REAL A(*), B(KB,N)
      INTEGER IA(*), JA(*)
C
      DO 30 I = 1,M
C
C                 CLEAR THE I-TH ROW
C
         DO 10 J = 1,N
            B(I,J) = 0.0
   10    CONTINUE
C
C                 STORE THE I-TH ROW
C
         IPMIN = IA(I)
         IPMAX = IA(I+1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 30
         DO 20 IP = IPMIN,IPMAX
            J = JA(IP)
            B(I,J) = A(IP)
   20    CONTINUE
C
   30 CONTINUE
      RETURN
      END
      SUBROUTINE CVSD (A, IA, JA, B, KB, M, N)
      DOUBLE PRECISION A(*), B(KB,N)
      INTEGER IA(*), JA(*)
C
      DO 30 I = 1,M
C
C                 CLEAR THE I-TH ROW
C
         DO 10 J = 1,N
            B(I,J) = 0.D0
   10    CONTINUE
C
C                 STORE THE I-TH ROW
C
         IPMIN = IA(I)
         IPMAX = IA(I+1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 30
         DO 20 IP = IPMIN,IPMAX
            J = JA(IP)
            B(I,J) = A(IP)
   20    CONTINUE
C
   30 CONTINUE
      RETURN
      END
      SUBROUTINE CVSC (A, IA, JA, B, KB, M, N)
      COMPLEX A(*), B(KB,N)
      INTEGER IA(*), JA(*)
C
      DO 30 I = 1,M
C
C                 CLEAR THE I-TH ROW
C
         DO 10 J = 1,N
            B(I,J) = (0.0,0.0)
   10    CONTINUE
C
C                 STORE THE I-TH ROW
C
         IPMIN = IA(I)
         IPMAX = IA(I+1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 30
         DO 20 IP = IPMIN,IPMAX
            J = JA(IP)
            B(I,J) = A(IP)
   20    CONTINUE
C
   30 CONTINUE
      RETURN
      END
      SUBROUTINE SCVRD (A, IA, JA, B, IB, JB, M)
      REAL A(*)
      DOUBLE PRECISION B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
      L = 1
      DO 20 I = 1,M
         IB(I) = L
         IBEG = IA(I)
         IEND = IA(I+1) - 1
         IF (IBEG .GT. IEND) GO TO 20
         DO 10 IP = IBEG,IEND
            IF (A(IP) .EQ. 0.0) GO TO 10
            B(L) = A(IP)
            JB(L) = JA(IP)
            L = L + 1
   10    CONTINUE
   20 CONTINUE
      IB(M + 1) = L
      RETURN
      END
      SUBROUTINE SCVDR (A, IA, JA, B, IB, JB, M)
      DOUBLE PRECISION A(*)
      REAL B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
      L = 1
      DO 20 I = 1,M
         IB(I) = L
         IBEG = IA(I)
         IEND = IA(I+1) - 1
         IF (IBEG .GT. IEND) GO TO 20
         DO 10 IP = IBEG,IEND
            IF (A(IP) .EQ. 0.D0) GO TO 10
            B(L) = A(IP)
            JB(L) = JA(IP)
            L = L + 1
   10    CONTINUE
   20 CONTINUE
      IB(M + 1) = L
      RETURN
      END
      SUBROUTINE CSREAL (A, IA, JA, B, IB, JB, M)
C-----------------------------------------------------------------------
C              REAL PART OF A SPARSE COMPLEX MATRIX
C-----------------------------------------------------------------------
      COMPLEX A(*)
      REAL B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
      L = 1
      DO 20 I = 1,M
         IB(I) = L
         IBEG = IA(I)
         IEND = IA(I+1) - 1
         IF (IBEG .GT. IEND) GO TO 20
         DO 10 IP = IBEG,IEND
            T = REAL(A(IP))
            IF (T .EQ. 0.0) GO TO 10
            B(L) = T
            JB(L) = JA(IP)
            L = L + 1
   10    CONTINUE
   20 CONTINUE
      IB(M + 1) = L
      RETURN
      END
      SUBROUTINE CSIMAG (A, IA, JA, B, IB, JB, M)
C-----------------------------------------------------------------------
C            IMAGINARY PART OF A SPARSE COMPLEX MATRIX
C-----------------------------------------------------------------------
      COMPLEX A(*)
      REAL B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
      L = 1
      DO 20 I = 1,M
         IB(I) = L
         IBEG = IA(I)
         IEND = IA(I+1) - 1
         IF (IBEG .GT. IEND) GO TO 20
         DO 10 IP = IBEG,IEND
            T = AIMAG(A(IP))
            IF (T .EQ. 0.0) GO TO 10
            B(L) = T
            JB(L) = JA(IP)
            L = L + 1
   10    CONTINUE
   20 CONTINUE
      IB(M + 1) = L
      RETURN
      END
      SUBROUTINE SCVRC (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C       COMPUTE A + BI FOR THE SPARSE REAL MATRICES A AND B
C-----------------------------------------------------------------------
      REAL A(*), B(*), WK(N)
      COMPLEX C(*), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 J = 1,N
         WK(J) = 0.0
   10 CONTINUE
C
C                  COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 42 I = 1,M
         IC(I) = IP
         MINA = IA(I)
         MAXA = IA(I+1) - 1
         IF (MINA .GT. MAXA) GO TO 30
         DO 20 L = MINA,MAXA
            J = JA(L)
            WK(J) = A(L)
   20    CONTINUE
C
   30    MINB = IB(I)
         MAXB = IB(I+1) - 1
         IF (MINB .GT. MAXB) GO TO 40
         DO 31 L = MINB,MAXB
            IF (B(L) .EQ. 0.0) GO TO 31
            J = JB(L)
            T = CMPLX (WK(J), B(L))
            WK(J) = 0.0
            IF (IP .GT. NUM) GO TO 50
            C(IP) = T
            JC(IP) = J
            IP = IP + 1
   31    CONTINUE
C
   40    IF (MINA .GT. MAXA) GO TO 42
         DO 41 L = MINA,MAXA
            J = JA(L)
            IF (WK(J) .EQ. 0.0) GO TO 41
            IF (IP .GT. NUM) GO TO 50
            C(IP) = CMPLX (WK(J), 0.0)
            WK(J) = 0.0
            JC(IP) = J
            IP = IP + 1
   41    CONTINUE
   42 CONTINUE
      IC(M + 1) = IP
      IERR = 0
      RETURN
C
C                        ERROR RETURN
C
   50 IERR = I
      RETURN
      END
      SUBROUTINE RSCOPY (A, IA, JA, B, IB, JB, M)
C-----------------------------------------------------------------------
C                  COPYING A SPARSE REAL MATRIX
C-----------------------------------------------------------------------
      REAL A(*), B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
      L = 1
      DO 20 I = 1,M
         IB(I) = L
         IBEG = IA(I)
         IEND = IA(I+1) - 1
         IF (IBEG .GT. IEND) GO TO 20
         DO 10 IP = IBEG,IEND
            IF (A(IP) .EQ. 0.0) GO TO 10
            B(L) = A(IP)
            JB(L) = JA(IP)
            L = L + 1
   10    CONTINUE
   20 CONTINUE
      IB(M + 1) = L
      RETURN
      END
      SUBROUTINE DSCOPY (A, IA, JA, B, IB, JB, M)
C-----------------------------------------------------------------------
C              COPYING A SPARSE DOUBLE PRECISION MATRIX
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
      L = 1
      DO 20 I = 1,M
         IB(I) = L
         IBEG = IA(I)
         IEND = IA(I+1) - 1
         IF (IBEG .GT. IEND) GO TO 20
         DO 10 IP = IBEG,IEND
            IF (A(IP) .EQ. 0.D0) GO TO 10
            B(L) = A(IP)
            JB(L) = JA(IP)
            L = L + 1
   10    CONTINUE
   20 CONTINUE
      IB(M + 1) = L
      RETURN
      END
      SUBROUTINE CSCOPY (A, IA, JA, B, IB, JB, M)
C-----------------------------------------------------------------------
C                 COPYING A SPARSE COMPLEX MATRIX
C-----------------------------------------------------------------------
      COMPLEX A(*), B(*), ZERO
      INTEGER IA(*), JA(*), IB(*), JB(*)
      DATA ZERO /(0.0,0.0)/
C
      L = 1
      DO 20 I = 1,M
         IB(I) = L
         IBEG = IA(I)
         IEND = IA(I+1) - 1
         IF (IBEG .GT. IEND) GO TO 20
         DO 10 IP = IBEG,IEND
            IF (A(IP) .EQ. ZERO) GO TO 10
            B(L) = A(IP)
            JB(L) = JA(IP)
            L = L + 1
   10    CONTINUE
   20 CONTINUE
      IB(M + 1) = L
      RETURN
      END
      SUBROUTINE SCONJ (A, IA, JA, B, IB, JB, M)
C-----------------------------------------------------------------------
C     COMPUTATION OF THE CONJUGATE OF A SPARSE COMPLEX MATRIX
C-----------------------------------------------------------------------
      COMPLEX A(*), B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
      MP1 = M + 1
      L = IA(1) - 1
      DO 10 I = 1,MP1
         IB(I) = IA(I) - L
   10 CONTINUE
C
      IBEG = IA(1)
      IEND = IA(MP1) - 1
      IF (IBEG .GT. IEND) RETURN
      L = 1
      DO 20 IP = IBEG,IEND
         B(L) = CONJG(A(IP))
         JB(L) = JA(IP)
         L = L + 1
   20 CONTINUE
      RETURN
      END
      SUBROUTINE RPOSE (A, IA, JA, B, IB, JB, M, N)
C-----------------------------------------------------------------------
C                 TRANSPOSING A SPARSE REAL MATRIX
C-----------------------------------------------------------------------
      REAL A(*), B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
C           COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN
C                 OF A AND STORE THE RESULTS IN IB
C
      IPMIN = IA(1)
      IPMAX = IA(M+1) - 1
      IF (IPMIN .GT. IPMAX) GO TO 40
      DO 10 J = 1,N
         IB(J) = 0
   10 CONTINUE
      DO 11 IP = IPMIN,IPMAX
         J = JA(IP)
         IB(J) = IB(J) + 1
   11 CONTINUE
C
C          COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX
C                AND STORE THEM IN IB(2),...,IB(N+1)
C
      NUM = IA(M+1) - IA(1) + 1
      J = N
      DO 20 JJ = 1,N
         NUM = NUM - IB(J)
         IB(J+1) = NUM
         J = J - 1
   20 CONTINUE
C
C                STORE THE I-TH ROW OF A IN B AND JB
C                  AND UPDATE THE POINTERS IN IB
C
      DO 31 I = 1,M
         IPMIN = IA(I)
         IPMAX = IA(I+1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 31
         DO 30 IP = IPMIN,IPMAX
            J = JA(IP)
            JP = IB(J+1)
            JB(JP) = I
            B(JP) = A(IP)
            IB(J+1) = JP + 1
   30    CONTINUE
   31 CONTINUE
      IB(1) = 1
      RETURN
C
C                    TRANSPOSE A ZERO MATRIX A
C
   40 NP1 = N + 1
      DO 41 J = 1,NP1
         IB(J) = 1
   41 CONTINUE
      RETURN
      END
      SUBROUTINE RPOSE1 (P, A, IA, JA, B, IB, JB, M, N)
C-----------------------------------------------------------------------
C                 TRANSPOSING A SPARSE REAL MATRIX
C                 WHERE THE ROWS ARE INTERCHANGED
C-----------------------------------------------------------------------
      INTEGER P(M)
      REAL A(*), B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
C           COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN
C                 OF A AND STORE THE RESULTS IN IB
C
      IPMIN = IA(1)
      IPMAX = IA(M+1) - 1
      IF (IPMIN .GT. IPMAX) GO TO 40
      DO 10 J = 1,N
         IB(J) = 0
   10 CONTINUE
      DO 11 IP = IPMIN,IPMAX
         J = JA(IP)
         IB(J) = IB(J) + 1
   11 CONTINUE
C
C          COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX
C                AND STORE THEM IN IB(2),...,IB(N+1)
C
      NUM = IA(M+1) - IA(1) + 1
      J = N
      DO 20 JJ = 1,N
         NUM = NUM - IB(J)
         IB(J+1) = NUM
         J = J - 1
   20 CONTINUE
C
C                STORE THE I-TH ROW OF A IN B AND JB
C                  AND UPDATE THE POINTERS IN IB
C
      DO 31 I = 1,M
         II = P(I)
         IPMIN = IA(II)
         IPMAX = IA(II+1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 31
         DO 30 IP = IPMIN,IPMAX
            J = JA(IP)
            JP = IB(J+1)
            JB(JP) = I
            B(JP) = A(IP)
            IB(J+1) = JP + 1
   30    CONTINUE
   31 CONTINUE
      IB(1) = 1
      RETURN
C
C                    TRANSPOSE A ZERO MATRIX A
C
   40 NP1 = N + 1
      DO 41 J = 1,NP1
         IB(J) = 1
   41 CONTINUE
      RETURN
      END
      SUBROUTINE DPOSE (A, IA, JA, B, IB, JB, M, N)
C-----------------------------------------------------------------------
C           TRANSPOSING A SPARSE DOUBLE PRECISION MATRIX
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
C           COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN
C                 OF A AND STORE THE RESULTS IN IB
C
      IPMIN = IA(1)
      IPMAX = IA(M+1) - 1
      IF (IPMIN .GT. IPMAX) GO TO 40
      DO 10 J = 1,N
         IB(J) = 0
   10 CONTINUE
      DO 11 IP = IPMIN,IPMAX
         J = JA(IP)
         IB(J) = IB(J) + 1
   11 CONTINUE
C
C          COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX
C                AND STORE THEM IN IB(2),...,IB(N+1)
C
      NUM = IA(M+1) - IA(1) + 1
      J = N
      DO 20 JJ = 1,N
         NUM = NUM - IB(J)
         IB(J+1) = NUM
         J = J - 1
   20 CONTINUE
C
C                STORE THE I-TH ROW OF A IN B AND JB
C                  AND UPDATE THE POINTERS IN IB
C
      DO 31 I = 1,M
         IPMIN = IA(I)
         IPMAX = IA(I+1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 31
         DO 30 IP = IPMIN,IPMAX
            J = JA(IP)
            JP = IB(J+1)
            JB(JP) = I
            B(JP) = A(IP)
            IB(J+1) = JP + 1
   30    CONTINUE
   31 CONTINUE
      IB(1) = 1
      RETURN
C
C                    TRANSPOSE A ZERO MATRIX A
C
   40 NP1 = N + 1
      DO 41 J = 1,NP1
         IB(J) = 1
   41 CONTINUE
      RETURN
      END
      SUBROUTINE DPOSE1 (P, A, IA, JA, B, IB, JB, M, N)
C-----------------------------------------------------------------------
C           TRANSPOSING A SPARSE DOUBLE PRECISION MATRIX
C                 WHERE THE ROWS ARE INTERCHANGED
C-----------------------------------------------------------------------
      INTEGER P(M)
      DOUBLE PRECISION A(*), B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
C           COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN
C                 OF A AND STORE THE RESULTS IN IB
C
      IPMIN = IA(1)
      IPMAX = IA(M+1) - 1
      IF (IPMIN .GT. IPMAX) GO TO 40
      DO 10 J = 1,N
         IB(J) = 0
   10 CONTINUE
      DO 11 IP = IPMIN,IPMAX
         J = JA(IP)
         IB(J) = IB(J) + 1
   11 CONTINUE
C
C          COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX
C                AND STORE THEM IN IB(2),...,IB(N+1)
C
      NUM = IA(M+1) - IA(1) + 1
      J = N
      DO 20 JJ = 1,N
         NUM = NUM - IB(J)
         IB(J+1) = NUM
         J = J - 1
   20 CONTINUE
C
C                STORE THE I-TH ROW OF A IN B AND JB
C                  AND UPDATE THE POINTERS IN IB
C
      DO 31 I = 1,M
         II = P(I)
         IPMIN = IA(II)
         IPMAX = IA(II+1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 31
         DO 30 IP = IPMIN,IPMAX
            J = JA(IP)
            JP = IB(J+1)
            JB(JP) = I
            B(JP) = A(IP)
            IB(J+1) = JP + 1
   30    CONTINUE
   31 CONTINUE
      IB(1) = 1
      RETURN
C
C                    TRANSPOSE A ZERO MATRIX A
C
   40 NP1 = N + 1
      DO 41 J = 1,NP1
         IB(J) = 1
   41 CONTINUE
      RETURN
      END
      SUBROUTINE CPOSE (A, IA, JA, B, IB, JB, M, N)
C-----------------------------------------------------------------------
C               TRANSPOSING A SPARSE COMPLEX MATRIX
C-----------------------------------------------------------------------
      COMPLEX A(*), B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
C           COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN
C                 OF A AND STORE THE RESULTS IN IB
C
      IPMIN = IA(1)
      IPMAX = IA(M+1) - 1
      IF (IPMIN .GT. IPMAX) GO TO 40
      DO 10 J = 1,N
         IB(J) = 0
   10 CONTINUE
      DO 11 IP = IPMIN,IPMAX
         J = JA(IP)
         IB(J) = IB(J) + 1
   11 CONTINUE
C
C          COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX
C                AND STORE THEM IN IB(2),...,IB(N+1)
C
      NUM = IA(M+1) - IA(1) + 1
      J = N
      DO 20 JJ = 1,N
         NUM = NUM - IB(J)
         IB(J+1) = NUM
         J = J - 1
   20 CONTINUE
C
C                STORE THE I-TH ROW OF A IN B AND JB
C                  AND UPDATE THE POINTERS IN IB
C
      DO 31 I = 1,M
         IPMIN = IA(I)
         IPMAX = IA(I+1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 31
         DO 30 IP = IPMIN,IPMAX
            J = JA(IP)
            JP = IB(J+1)
            JB(JP) = I
            B(JP) = A(IP)
            IB(J+1) = JP + 1
   30    CONTINUE
   31 CONTINUE
      IB(1) = 1
      RETURN
C
C                    TRANSPOSE A ZERO MATRIX A
C
   40 NP1 = N + 1
      DO 41 J = 1,NP1
         IB(J) = 1
   41 CONTINUE
      RETURN
      END
      SUBROUTINE CPOSE1 (P, A, IA, JA, B, IB, JB, M, N)
C-----------------------------------------------------------------------
C               TRANSPOSING A SPARSE COMPLEX MATRIX
C                 WHERE THE ROWS ARE INTERCHANGED
C-----------------------------------------------------------------------
      INTEGER P(M)
      COMPLEX A(*), B(*)
      INTEGER IA(*), JA(*), IB(*), JB(*)
C
C           COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN
C                 OF A AND STORE THE RESULTS IN IB
C
      IPMIN = IA(1)
      IPMAX = IA(M+1) - 1
      IF (IPMIN .GT. IPMAX) GO TO 40
      DO 10 J = 1,N
         IB(J) = 0
   10 CONTINUE
      DO 11 IP = IPMIN,IPMAX
         J = JA(IP)
         IB(J) = IB(J) + 1
   11 CONTINUE
C
C          COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX
C                AND STORE THEM IN IB(2),...,IB(N+1)
C
      NUM = IA(M+1) - IA(1) + 1
      J = N
      DO 20 JJ = 1,N
         NUM = NUM - IB(J)
         IB(J+1) = NUM
         J = J - 1
   20 CONTINUE
C
C                STORE THE I-TH ROW OF A IN B AND JB
C                  AND UPDATE THE POINTERS IN IB
C
      DO 31 I = 1,M
         II = P(I)
         IPMIN = IA(II)
         IPMAX = IA(II+1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 31
         DO 30 IP = IPMIN,IPMAX
            J = JA(IP)
            JP = IB(J+1)
            JB(JP) = I
            B(JP) = A(IP)
            IB(J+1) = JP + 1
   30    CONTINUE
   31 CONTINUE
      IB(1) = 1
      RETURN
C
C                    TRANSPOSE A ZERO MATRIX A
C
   40 NP1 = N + 1
      DO 41 J = 1,NP1
         IB(J) = 1
   41 CONTINUE
      RETURN
      END
      SUBROUTINE SADD (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C               ADDITION OF SPARSE REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(*), B(*), C(*), WK(N), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 J = 1,N
         WK(J) = 0.0
   10 CONTINUE
C
C                  COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 42 I = 1,M
         IC(I) = IP
         MINA = IA(I)
         MAXA = IA(I+1) - 1
         IF (MINA .GT. MAXA) GO TO 30
         DO 20 L = MINA,MAXA
            J = JA(L)
            WK(J) = A(L)
   20    CONTINUE
C
   30    MINB = IB(I)
         MAXB = IB(I+1) - 1
         IF (MINB .GT. MAXB) GO TO 40
         DO 31 L = MINB,MAXB
            J = JB(L)
            T = WK(J) + B(L)
            WK(J) = 0.0
            IF (T .EQ. 0.0) GO TO 31
            IF (IP .GT. NUM) GO TO 50
            C(IP) = T
            JC(IP) = J
            IP = IP + 1
   31    CONTINUE
C
   40    IF (MINA .GT. MAXA) GO TO 42
         DO 41 L = MINA,MAXA
            J = JA(L)
            IF (WK(J) .EQ. 0.0) GO TO 41
            IF (IP .GT. NUM) GO TO 50
            C(IP) = WK(J)
            WK(J) = 0.0
            JC(IP) = J
            IP = IP + 1
   41    CONTINUE
   42 CONTINUE
      IC(M + 1) = IP
      IERR = 0
      RETURN
C
C                        ERROR RETURN
C
   50 IERR = I
      RETURN
      END
      SUBROUTINE DSADD (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C         ADDITION OF SPARSE DOUBLE PRECISION MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*), C(*), WK(N), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 J = 1,N
         WK(J) = 0.D0
   10 CONTINUE
C
C                  COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 42 I = 1,M
         IC(I) = IP
         MINA = IA(I)
         MAXA = IA(I+1) - 1
         IF (MINA .GT. MAXA) GO TO 30
         DO 20 L = MINA,MAXA
            J = JA(L)
            WK(J) = A(L)
   20    CONTINUE
C
   30    MINB = IB(I)
         MAXB = IB(I+1) - 1
         IF (MINB .GT. MAXB) GO TO 40
         DO 31 L = MINB,MAXB
            J = JB(L)
            T = WK(J) + B(L)
            WK(J) = 0.D0
            IF (T .EQ. 0.D0) GO TO 31
            IF (IP .GT. NUM) GO TO 50
            C(IP) = T
            JC(IP) = J
            IP = IP + 1
   31    CONTINUE
C
   40    IF (MINA .GT. MAXA) GO TO 42
         DO 41 L = MINA,MAXA
            J = JA(L)
            IF (WK(J) .EQ. 0.D0) GO TO 41
            IF (IP .GT. NUM) GO TO 50
            C(IP) = WK(J)
            WK(J) = 0.D0
            JC(IP) = J
            IP = IP + 1
   41    CONTINUE
   42 CONTINUE
      IC(M + 1) = IP
      IERR = 0
      RETURN
C
C                        ERROR RETURN
C
   50 IERR = I
      RETURN
      END
      SUBROUTINE CSADD (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C              ADDITION OF SPARSE COMPLEX MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(*), B(*), C(*), WK(N), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 J = 1,N
         WK(J) = (0.0, 0.0)
   10 CONTINUE
C
C                  COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 42 I = 1,M
         IC(I) = IP
         MINA = IA(I)
         MAXA = IA(I+1) - 1
         IF (MINA .GT. MAXA) GO TO 30
         DO 20 L = MINA,MAXA
            J = JA(L)
            WK(J) = A(L)
   20    CONTINUE
C
   30    MINB = IB(I)
         MAXB = IB(I+1) - 1
         IF (MINB .GT. MAXB) GO TO 40
         DO 31 L = MINB,MAXB
            J = JB(L)
            T = WK(J) + B(L)
            WK(J) = (0.0, 0.0)
            IF (T .EQ. (0.0, 0.0)) GO TO 31
            IF (IP .GT. NUM) GO TO 50
            C(IP) = T
            JC(IP) = J
            IP = IP + 1
   31    CONTINUE
C
   40    IF (MINA .GT. MAXA) GO TO 42
         DO 41 L = MINA,MAXA
            J = JA(L)
            IF (WK(J) .EQ. (0.0, 0.0)) GO TO 41
            IF (IP .GT. NUM) GO TO 50
            C(IP) = WK(J)
            WK(J) = (0.0, 0.0)
            JC(IP) = J
            IP = IP + 1
   41    CONTINUE
   42 CONTINUE
      IC(M + 1) = IP
      IERR = 0
      RETURN
C
C                        ERROR RETURN
C
   50 IERR = I
      RETURN
      END
      SUBROUTINE SSUBT (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C             SUBTRACTION OF SPARSE REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(*), B(*), C(*), WK(N), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 J = 1,N
         WK(J) = 0.0
   10 CONTINUE
C
C                  COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 42 I = 1,M
         IC(I) = IP
         MINA = IA(I)
         MAXA = IA(I+1) - 1
         IF (MINA .GT. MAXA) GO TO 30
         DO 20 L = MINA,MAXA
            J = JA(L)
            WK(J) = A(L)
   20    CONTINUE
C
   30    MINB = IB(I)
         MAXB = IB(I+1) - 1
         IF (MINB .GT. MAXB) GO TO 40
         DO 31 L = MINB,MAXB
            J = JB(L)
            T = WK(J) - B(L)
            WK(J) = 0.0
            IF (T .EQ. 0.0) GO TO 31
            IF (IP .GT. NUM) GO TO 50
            C(IP) = T
            JC(IP) = J
            IP = IP + 1
   31    CONTINUE
C
   40    IF (MINA .GT. MAXA) GO TO 42
         DO 41 L = MINA,MAXA
            J = JA(L)
            IF (WK(J) .EQ. 0.0) GO TO 41
            IF (IP .GT. NUM) GO TO 50
            C(IP) = WK(J)
            WK(J) = 0.0
            JC(IP) = J
            IP = IP + 1
   41    CONTINUE
   42 CONTINUE
      IC(M + 1) = IP
      IERR = 0
      RETURN
C
C                        ERROR RETURN
C
   50 IERR = I
      RETURN
      END
      SUBROUTINE DSSUBT (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C        SUBTRACTION OF SPARSE DOUBLE PRECISION MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*), C(*), WK(N), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 J = 1,N
         WK(J) = 0.D0
   10 CONTINUE
C
C                  COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 42 I = 1,M
         IC(I) = IP
         MINA = IA(I)
         MAXA = IA(I+1) - 1
         IF (MINA .GT. MAXA) GO TO 30
         DO 20 L = MINA,MAXA
            J = JA(L)
            WK(J) = A(L)
   20    CONTINUE
C
   30    MINB = IB(I)
         MAXB = IB(I+1) - 1
         IF (MINB .GT. MAXB) GO TO 40
         DO 31 L = MINB,MAXB
            J = JB(L)
            T = WK(J) - B(L)
            WK(J) = 0.D0
            IF (T .EQ. 0.D0) GO TO 31
            IF (IP .GT. NUM) GO TO 50
            C(IP) = T
            JC(IP) = J
            IP = IP + 1
   31    CONTINUE
C
   40    IF (MINA .GT. MAXA) GO TO 42
         DO 41 L = MINA,MAXA
            J = JA(L)
            IF (WK(J) .EQ. 0.D0) GO TO 41
            IF (IP .GT. NUM) GO TO 50
            C(IP) = WK(J)
            WK(J) = 0.D0
            JC(IP) = J
            IP = IP + 1
   41    CONTINUE
   42 CONTINUE
      IC(M + 1) = IP
      IERR = 0
      RETURN
C
C                        ERROR RETURN
C
   50 IERR = I
      RETURN
      END
      SUBROUTINE CSSUBT (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C            SUBTRACTION OF SPARSE COMPLEX MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(*), B(*), C(*), WK(N), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 J = 1,N
         WK(J) = (0.0, 0.0)
   10 CONTINUE
C
C                  COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 42 I = 1,M
         IC(I) = IP
         MINA = IA(I)
         MAXA = IA(I+1) - 1
         IF (MINA .GT. MAXA) GO TO 30
         DO 20 L = MINA,MAXA
            J = JA(L)
            WK(J) = A(L)
   20    CONTINUE
C
   30    MINB = IB(I)
         MAXB = IB(I+1) - 1
         IF (MINB .GT. MAXB) GO TO 40
         DO 31 L = MINB,MAXB
            J = JB(L)
            T = WK(J) - B(L)
            WK(J) = (0.0, 0.0)
            IF (T .EQ. (0.0, 0.0)) GO TO 31
            IF (IP .GT. NUM) GO TO 50
            C(IP) = T
            JC(IP) = J
            IP = IP + 1
   31    CONTINUE
C
   40    IF (MINA .GT. MAXA) GO TO 42
         DO 41 L = MINA,MAXA
            J = JA(L)
            IF (WK(J) .EQ. (0.0, 0.0)) GO TO 41
            IF (IP .GT. NUM) GO TO 50
            C(IP) = WK(J)
            WK(J) = (0.0, 0.0)
            JC(IP) = J
            IP = IP + 1
   41    CONTINUE
   42 CONTINUE
      IC(M + 1) = IP
      IERR = 0
      RETURN
C
C                        ERROR RETURN
C
   50 IERR = I
      RETURN
      END
      SUBROUTINE SPROD (A,IA,JA,B,IB,JB,C,IC,JC,L,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C               MULTIPLICATION OF SPARSE REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(*), B(*), C(*), WK(N), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 K = 1,N
         WK(K) = 0.0
   10 CONTINUE
C
C                     COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 31 I = 1,L
         IC(I) = IP
         JPMIN = IA(I)
         JPMAX = IA(I+1) - 1
         IF (JPMIN .GT. JPMAX) GO TO 31
C
         DO 21 JP = JPMIN,JPMAX
            T = A(JP)
            IF (T .EQ. 0.0) GO TO 21
            J = JA(JP)
            KPMIN = IB(J)
            KPMAX = IB(J+1) - 1
            IF (KPMIN .GT. KPMAX) GO TO 21
            DO 20 KP = KPMIN,KPMAX
               K = JB(KP)
               WK(K) = WK(K) + T*B(KP)
   20       CONTINUE
   21    CONTINUE
C
         DO 30 K = 1,N
            IF (WK(K) .EQ. 0.0) GO TO 30
            IF (IP .GT. NUM) GO TO 40
            C(IP) = WK(K)
            WK(K) = 0.0
            JC(IP) = K
            IP = IP + 1
   30    CONTINUE
   31 CONTINUE
      IC(L + 1) = IP
      IERR = 0
      RETURN
C
C                           ERROR RETURN
C
   40 IERR = I
      RETURN
      END
      SUBROUTINE DSPROD (A,IA,JA,B,IB,JB,C,IC,JC,L,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C         MULTIPLICATION OF SPARSE DOUBLE PRECISION MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(*), C(*), WK(N), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 K = 1,N
         WK(K) = 0.D0
   10 CONTINUE
C
C                     COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 31 I = 1,L
         IC(I) = IP
         JPMIN = IA(I)
         JPMAX = IA(I+1) - 1
         IF (JPMIN .GT. JPMAX) GO TO 31
C
         DO 21 JP = JPMIN,JPMAX
            T = A(JP)
            IF (T .EQ. 0.D0) GO TO 21
            J = JA(JP)
            KPMIN = IB(J)
            KPMAX = IB(J+1) - 1
            IF (KPMIN .GT. KPMAX) GO TO 21
            DO 20 KP = KPMIN,KPMAX
               K = JB(KP)
               WK(K) = WK(K) + T*B(KP)
   20       CONTINUE
   21    CONTINUE
C
         DO 30 K = 1,N
            IF (WK(K) .EQ. 0.D0) GO TO 30
            IF (IP .GT. NUM) GO TO 40
            C(IP) = WK(K)
            WK(K) = 0.D0
            JC(IP) = K
            IP = IP + 1
   30    CONTINUE
   31 CONTINUE
      IC(L + 1) = IP
      IERR = 0
      RETURN
C
C                           ERROR RETURN
C
   40 IERR = I
      RETURN
      END
      SUBROUTINE CSPROD (A,IA,JA,B,IB,JB,C,IC,JC,L,M,N,NUM,WK,IERR)
C-----------------------------------------------------------------------
C             MULTIPLICATION OF SPARSE COMPLEX MATRICES
C-----------------------------------------------------------------------
      COMPLEX A(*), B(*), C(*), WK(N), T
      INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*)
C-------------------------
      DO 10 K = 1,N
         WK(K) = (0.0, 0.0)
   10 CONTINUE
C
C                     COMPUTE THE I-TH ROW OF C
C
      IP = 1
      DO 31 I = 1,L
         IC(I) = IP
         JPMIN = IA(I)
         JPMAX = IA(I+1) - 1
         IF (JPMIN .GT. JPMAX) GO TO 31
C
         DO 21 JP = JPMIN,JPMAX
            T = A(JP)
            IF (T .EQ. (0.0, 0.0)) GO TO 21
            J = JA(JP)
            KPMIN = IB(J)
            KPMAX = IB(J+1) - 1
            IF (KPMIN .GT. KPMAX) GO TO 21
            DO 20 KP = KPMIN,KPMAX
               K = JB(KP)
               WK(K) = WK(K) + T*B(KP)
   20       CONTINUE
   21    CONTINUE
C
         DO 30 K = 1,N
            IF (WK(K) .EQ. (0.0, 0.0)) GO TO 30
            IF (IP .GT. NUM) GO TO 40
            C(IP) = WK(K)
            WK(K) = (0.0, 0.0)
            JC(IP) = K
            IP = IP + 1
   30    CONTINUE
   31 CONTINUE
      IC(L + 1) = IP
      IERR = 0
      RETURN
C
C                           ERROR RETURN
C
   40 IERR = I
      RETURN
      END
      SUBROUTINE MVPRD (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C              PRODUCT OF A SPARSE MATRIX AND A VECTOR
C-----------------------------------------------------------------------
      REAL A(*), X(N), Y(M), SUM
      INTEGER IA(*), JA(*)
C
      DO 11 I = 1,M
         SUM = 0.0
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            J = JA(L)
            SUM = SUM + A(L)*X(J)
   10    CONTINUE
   11 Y(I) = SUM
      RETURN
      END
      SUBROUTINE MVPRD1 (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C     SET Y = A*X + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS
C-----------------------------------------------------------------------
      REAL A(*), X(N), Y(M), SUM
      INTEGER IA(*), JA(*)
C
      DO 11 I = 1,M
         SUM = Y(I)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            J = JA(L)
            SUM = SUM + A(L)*X(J)
   10    CONTINUE
   11 Y(I) = SUM
      RETURN
      END
      SUBROUTINE MTPRD (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C              PRODUCT OF A VECTOR AND A SPARSE MATRIX
C-----------------------------------------------------------------------
      REAL A(*), X(M), Y(N), T
      INTEGER IA(*), JA(*)
C
      DO 10 J = 1,N
         Y(J) = 0.0
   10 CONTINUE
C
      DO 21 I = 1,M
         T = X(I)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 21
         DO 20 L = LMIN,LMAX
            J = JA(L)
            Y(J) = Y(J) + T*A(L)
   20    CONTINUE
   21 CONTINUE
      RETURN
      END
      SUBROUTINE MTPRD1 (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C     SET Y = X*A + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS
C-----------------------------------------------------------------------
      REAL A(*), X(M), Y(N), T
      INTEGER IA(*), JA(*)
C
      DO 11 I = 1,M
         T = X(I)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            J = JA(L)
            Y(J) = Y(J) + T*A(L)
   10    CONTINUE
   11 CONTINUE
      RETURN
      END
      SUBROUTINE DVPRD (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C              PRODUCT OF A SPARSE MATRIX AND A VECTOR
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), X(N), Y(M), SUM
      INTEGER IA(*), JA(*)
C
      DO 11 I = 1,M
         SUM = 0.D0
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            J = JA(L)
            SUM = SUM + A(L)*X(J)
   10    CONTINUE
   11 Y(I) = SUM
      RETURN
      END
      SUBROUTINE DVPRD1 (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C     SET Y = A*X + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), X(N), Y(M), SUM
      INTEGER IA(*), JA(*)
C
      DO 11 I = 1,M
         SUM = Y(I)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            J = JA(L)
            SUM = SUM + A(L)*X(J)
   10    CONTINUE
   11 Y(I) = SUM
      RETURN
      END
      SUBROUTINE DTPRD (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C              PRODUCT OF A VECTOR AND A SPARSE MATRIX
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), X(M), Y(N), T
      INTEGER IA(*), JA(*)
C
      DO 10 J = 1,N
         Y(J) = 0.D0
   10 CONTINUE
C
      DO 21 I = 1,M
         T = X(I)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 21
         DO 20 L = LMIN,LMAX
            J = JA(L)
            Y(J) = Y(J) + T*A(L)
   20    CONTINUE
   21 CONTINUE
      RETURN
      END
      SUBROUTINE DTPRD1 (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C     SET Y = X*A + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), X(M), Y(N), T
      INTEGER IA(*), JA(*)
C
      DO 11 I = 1,M
         T = X(I)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            J = JA(L)
            Y(J) = Y(J) + T*A(L)
   10    CONTINUE
   11 CONTINUE
      RETURN
      END
      SUBROUTINE CVPRD (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C              PRODUCT OF A SPARSE MATRIX AND A VECTOR
C-----------------------------------------------------------------------
      COMPLEX A(*), X(N), Y(M), SUM
      INTEGER IA(*), JA(*)
C
      DO 11 I = 1,M
         SUM = (0.0, 0.0)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            J = JA(L)
            SUM = SUM + A(L)*X(J)
   10    CONTINUE
   11 Y(I) = SUM
      RETURN
      END
      SUBROUTINE CVPRD1 (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C     SET Y = A*X + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS
C-----------------------------------------------------------------------
      COMPLEX A(*), X(N), Y(M), SUM
      INTEGER IA(*), JA(*)
C
      DO 11 I = 1,M
         SUM = Y(I)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            J = JA(L)
            SUM = SUM + A(L)*X(J)
   10    CONTINUE
   11 Y(I) = SUM
      RETURN
      END
      SUBROUTINE CTPRD (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C              PRODUCT OF A VECTOR AND A SPARSE MATRIX
C-----------------------------------------------------------------------
      COMPLEX A(*), X(M), Y(N), T
      INTEGER IA(*), JA(*)
C
      DO 10 J = 1,N
         Y(J) = (0.0, 0.0)
   10 CONTINUE
C
      DO 21 I = 1,M
         T = X(I)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 21
         DO 20 L = LMIN,LMAX
            J = JA(L)
            Y(J) = Y(J) + T*A(L)
   20    CONTINUE
   21 CONTINUE
      RETURN
      END
      SUBROUTINE CTPRD1 (M, N, A, IA, JA, X, Y)
C-----------------------------------------------------------------------
C     SET Y = X*A + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS
C-----------------------------------------------------------------------
      COMPLEX A(*), X(M), Y(N), T
      INTEGER IA(*), JA(*)
C
      DO 11 I = 1,M
         T = X(I)
         LMIN = IA(I)
         LMAX = IA(I+1) - 1
         IF (LMIN .GT. LMAX) GO TO 11
         DO 10 L = LMIN,LMAX
            J = JA(L)
            Y(J) = Y(J) + T*A(L)
   10    CONTINUE
   11 CONTINUE
      RETURN
      END
      REAL FUNCTION SNRM (A, IA, JA, M, N)
C-----------------------------------------------------------------------
C             COMPUTATION OF THE L-INFINITY NORM OF A
C                      REAL SPARSE MATRIX A
C-----------------------------------------------------------------------
      REAL A(*)
      INTEGER IA(*), JA(*)
C
      SNRM = 0.0
      DO 20 I = 1,M
         IPMIN = IA(I)
         IPMAX = IA(I + 1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 20
         SUM = 0.0
         DO 10 IP = IPMIN,IPMAX
            SUM = SUM + ABS(A(IP))
   10    CONTINUE
         SNRM = AMAX1(SNRM, SUM)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE S1NRM (A, IA, JA, M, N, ANORM, WK)
C-----------------------------------------------------------------------
C        COMPUTATION OF THE L1 NORM OF A REAL SPARSE MATRIX A
C-----------------------------------------------------------------------
      REAL A(*), WK(N)
      INTEGER IA(*), JA(*)
C
      ANORM = 0.0
      IPMIN = IA(1)
      IPMAX = IA(M + 1) - 1
      IF (IPMIN .GT. IPMAX) RETURN
C
C     COMPUTE THE L1 NORM OF A
C
      DO 10 J = 1,N
         WK(J) = 0.0
   10 CONTINUE
C
      DO 20 IP = IPMIN,IPMAX
         J = JA(IP)
         WK(J) = WK(J) + ABS(A(IP))
   20 CONTINUE
C
      DO 30 J = 1,N
         ANORM = AMAX1(ANORM,WK(J))
   30 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DSNRM (A, IA, JA, M, N)
C-----------------------------------------------------------------------
C             COMPUTATION OF THE L-INFINITY NORM OF A
C                DOUBLE PRECISION SPARSE MATRIX A
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), SUM
      INTEGER IA(*), JA(*)
C
      DSNRM = 0.D0
      DO 20 I = 1,M
         IPMIN = IA(I)
         IPMAX = IA(I + 1) - 1
         IF (IPMIN .GT. IPMAX) GO TO 20
         SUM = 0.D0
         DO 10 IP = IPMIN,IPMAX
            SUM = SUM + DABS(A(IP))
   10    CONTINUE
         DSNRM = DMAX1(DSNRM, SUM)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE DS1NRM (A, IA, JA, M, N, ANORM, WK)
C-----------------------------------------------------------------------
C               COMPUTATION OF THE L1 NORM OF A SPARSE
C                     DOUBLE PRECISION MATRIX A
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), ANORM, WK(N)
      INTEGER IA(*), JA(*)
C
      ANORM = 0.D0
      IPMIN = IA(1)
      IPMAX = IA(M + 1) - 1
      IF (IPMIN .GT. IPMAX) RETURN
C
C     COMPUTE THE L1 NORM OF A
C
      DO 10 J = 1,N
         WK(J) = 0.D0
   10 CONTINUE
C
      DO 20 IP = IPMIN,IPMAX
         J = JA(IP)
         WK(J) = WK(J) + DABS(A(IP))
   20 CONTINUE
C
      DO 30 J = 1,N
         ANORM = DMAX1(ANORM,WK(J))
   30 CONTINUE
      RETURN
      END
      SUBROUTINE SPORD (M, N, IA, R, IWK)
C-----------------------------------------------------------------------
C        SPORD ORDERS THE ROWS OF AN MXN SPARSE MATRIX A,IA,JA
C        BY INCREASING LENGTH. THE ROW ORDERING IS GIVEN IN R.
C-----------------------------------------------------------------------
C     IWK IS A WORK SPACE OF DIMENSION M + N + 1.
C----------------------
      INTEGER IA(*), R(M), IWK(*)
C
      NP1 = N + 1
      DO 10 I = 1,NP1
         IWK(I) = 0
   10 CONTINUE
C
      I = M
      DO 20 II = 1,M
         NUM = IA(I+1) - IA(I) + 1
         L = NP1 + I
         IWK(L) = IWK(NUM)
         IWK(NUM) = I
         I = I - 1
   20 CONTINUE
C
      NUM = 1
      K = IWK(NUM)
      DO 32 I = 1,M
   30    IF (K .NE. 0) GO TO 31
            NUM = NUM + 1
            K = IWK(NUM)
            GO TO 30
   31    R(I) = K
         L = NP1 + K
         K = IWK(L)
   32 CONTINUE
      RETURN
      END
      SUBROUTINE BLKORD (N, IA, JA, R, C, IB, NUM, IWK, IERR)
C-----------------------------------------------------------------------
C        REORDERING A SPARSE MATRIX INTO BLOCK TRIANGULAR FORM
C-----------------------------------------------------------------------
      INTEGER IA(*), JA(*), R(N), C(N), IB(N)
C     INTEGER IWK(5*N)
      INTEGER IWK(*)
C
      NP1 = N + 1
      LENGTH = IA(NP1) - IA(1)
      DO 10 I = 1,N
         IWK(I) = IA(I+1) - IA(I)
   10 CONTINUE
      CALL MC21A(N,JA,LENGTH,IA,IWK(1),R,NUM,IWK(NP1))
      IERR = N - NUM
      IF (IERR .NE. 0) RETURN
C
      DO 20 I = 1,N
         LI = R(I)
         IWK(I) = IA(LI)
         NPI = N + I
         IWK(NPI) = IA(LI+1) - IA(LI)
   20 CONTINUE
      CALL MC13D(N,JA,LENGTH,IWK(1),IWK(NP1),C,IB,NUM,IWK(2*N+1))
C
      DO 30 I = 1,N
         LI = C(I)
         IWK(I) = R(LI)
   30 CONTINUE
      DO 31 I = 1,N
         R(I) = IWK(I)
   31 CONTINUE
      RETURN
      END
      SUBROUTINE MC21A (N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW)
C-----------------------------------------------------------------------
C DESCRIPTION OF PARAMETERS.
C INPUT VARIABLES   N,ICN,LICN,IP,LENR
C OUTPUT VARIABLES  IPERM,NUMNZ
C
C N   ORDER OF MATRIX.
C ICN ARRAY CONTAINING THE COLUMN INDICES OF THE NON-ZEROS.  THOSE
C     BELONGING TO A SINGLE ROW MUST BE CONTIGUOUS BUT THE ORDERING
C     OF COLUMN INDICES WITHIN EACH ROW IS UNIMPORTANT AND WASTED
C     SPACE BETWEEN ROWS IS PERMITTED.
C LICN  LENGTH OF ARRAY ICN.
C IP  IP(I), I=1,2,...N, IS THE POSITION IN ARRAY ICN OF THE FIRST
C     COLUMN INDEX OF A NON-ZERO IN ROW I.
C LENR  LENR(I) IS THE NUMBER OF NON-ZEROS IN ROW I, I=1,2,..N.
C IPERM CONTAINS PERMUTATION TO MAKE DIAGONAL HAVE THE SMALLEST
C     NUMBER OF ZEROS ON IT.  ELEMENTS (IPERM(I),I) I=1, ... N ARE
C     NON-ZERO AT THE END OF THE ALGORITHM UNLESS MATRIX
C     IS STRUCTURALLY SINGULAR.  IN THIS CASE, (IPERM(I),I) WILL
C     BE ZERO FOR N-NUMNZ ENTRIES.
C NUMNZ NUMBER OF NON-ZEROS ON DIAGONAL OF PERMUTED MATRIX.
C IW  WORK ARRAY  ..  SEE LATER COMMENTS.
C-----------------------------------------------------------------------
      INTEGER IP(N)
      INTEGER ICN(LICN), LENR(N), IPERM(N), IW(N,4)
C
      CALL MC21B (N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW(1,1),IW(1,2),
     *            IW(1,3),IW(1,4))
      RETURN
      END
      SUBROUTINE MC21B (N,ICN,LICN,IP,LENR,IPERM,NUMNZ,PR,ARP,CV,OUT)
C-----------------------------------------------------------------------
C     DIVISION OF WORK ARRAY IS NOW DESCRIBED.
C
C PR(I) IS THE PREVIOUS ROW TO I IN THE DEPTH FIRST SEARCH.
C ARP(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I
C     WHICH HAVE NOT BEEN SCANNED WHEN LOOKING FOR A CHEAP ASSIGNMENT.
C CV(I) IS THE MOST RECENT ROW EXTENSION AT WHICH COLUMN I
C     WAS VISITED.
C OUT(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I
C     WHICH HAVE NOT BEEN SCANNED DURING ONE PASS THROUGH THE
C     MAIN LOOP.
C-----------------------------------------------------------------------
      INTEGER IP(N), ICN(LICN), LENR(N), IPERM(N), PR(N), CV(N),
     *        ARP(N), OUT(N)
C
C     INITIALIZATION OF ARRAYS
C
      DO 10 I = 1,N
         ARP(I) = LENR(I) - 1
         CV(I) = 0
         IPERM(I) = 0
   10 CONTINUE
      NUMNZ = 0
C
C     MAIN LOOP.
C     EACH PASS ROUND THIS LOOP EITHER RESULTS IN A NEW ASSIGNMENT
C     OR GIVES A ROW WITH NO ASSIGNMENT.
C
      DO 130 JORD = 1,N
      J = JORD
      PR(J) = -1
      DO 100 K = 1,JORD
C
C     LOOK FOR A CHEAP ASSIGNMENT
C
      IN1 = ARP(J)
      IF (IN1 .LT. 0) GO TO 60
      IN2 = IP(J) + LENR(J) - 1
      IN1 = IN2 - IN1
      DO 50 II = IN1,IN2
         I = ICN(II)
         IF (IPERM(I) .EQ. 0) GO TO 110
   50 CONTINUE
C
C     NO CHEAP ASSIGNMENT IN ROW
C
      ARP(J) = -1
C
C     BEGIN LOOKING FOR ASSIGNMENT CHAIN STARTING WITH ROW J
C
   60 OUT(J) = LENR(J) - 1
C
C     INNER LOOP.  EXTENDS CHAIN BY ONE OR BACKTRACKS.
C
      DO 90 KK = 1,JORD
         IN1 = OUT(J)
         IF (IN1 .LT. 0) GO TO 80
         IN2 = IP(J) + LENR(J) - 1
         IN1 = IN2 - IN1
C
C        FORWARD SCAN
C
         DO 70 II = IN1,IN2
            I = ICN(II)
            IF (CV(I) .EQ. JORD) GO TO 70
C
C           COLUMN I HAS NOT YET BEEN ACCESSED DURING THIS PASS
C
            J1 = J
            J = IPERM(I)
            CV(I) = JORD
            PR(J) = J1
            OUT(J1) = IN2 - II - 1
            GO TO 100
   70    CONTINUE
C
C        BACKTRACKING STEP
C
   80    J = PR(J)
         IF (J .EQ. -1) GO TO 130
   90 CONTINUE
C
  100 CONTINUE
C
C     NEW ASSIGNMENT IS MADE
C
  110 IPERM(I) = J
      ARP(J) = IN2 - II - 1
      NUMNZ = NUMNZ + 1
      DO 120 K = 1,JORD
         J = PR(J)
         IF (J .EQ. -1) GO TO 130
         II = IP(J) + LENR(J) - OUT(J) - 2
         I = ICN(II)
         IPERM(I) = J
  120 CONTINUE
C
  130 CONTINUE
C
C     IF MATRIX IS STRUCTURALLY SINGULAR, WE NOW COMPLETE THE
C     PERMUTATION IPERM.
C
      IF (NUMNZ .EQ. N) GO TO 500
      DO 140 I = 1,N
         ARP(I) = 0
  140 CONTINUE
      K = 0
      DO 160 I = 1,N
         IF (IPERM(I) .NE. 0) GO TO 150
            K = K + 1
            OUT(K) = I
            GO TO 160
  150    J = IPERM(I)
         ARP(J) = I
  160 CONTINUE
      K = 0
      DO 170 I = 1,N
         IF (ARP(I) .NE. 0) GO TO 170
         K = K + 1
         IOUTK = OUT(K)
         IPERM(IOUTK) = I
  170 CONTINUE
  500 RETURN
      END
      SUBROUTINE MC13D(N, ICN, LICN, IP, LENR, IOR, IB, NUM, IW)
C
C DESCRIPTION OF PARAMETERS.
C INPUT VARIABLES  .... N,ICN,LICN,IP,LENR.
C OUTPUT VARIABLES  IOR,IB,NUM.
C
C N   ORDER OF THE MATRIX.
C ICN ARRAY CONTAINING THE COLUMN INDICES OF THE NON-ZEROS.  THOSE
C     BELONGING TO A SINGLE ROW MUST BE CONTIGUOUS BUT THE ORDERING
C     OF COLUMN INDICES WITHIN EACH ROW IS UNIMPORTANT AND WASTED
C     SPACE BETWEEN ROWS IS PERMITTED.
C LICN  LENGTH OF ARRAY ICN.
C IP  IP(I), I=1,2,...N, IS THE POSITION IN ARRAY ICN OF THE FIRST
C     COLUMN INDEX OF A NON-ZERO IN ROW I.
C LENR  LENR(I) IS THE NUMBER OF NON-ZEROS IN ROW I, I=1,2,...N.
C IOR  IOR(I) GIVES THE POSITION IN THE ORIGINAL ORDERING OF THE ROW
C     OR COLUMN WHICH IS IN POSITION I IN THE PERMUTED FORM, I=1,2,..N.
C IB  IB(I) IS THE ROW NUMBER IN THE PERMUTED MATRIX OF THE BEGINNING
C     OF BLOCK I, I=1,2,...NUM.
C NUM NUMBER OF BLOCKS FOUND.
C IW  WORK ARRAY OF LENGTH 3*N.
C
      INTEGER IP(N)
      INTEGER ICN(LICN), LENR(N), IOR(N), IB(N), IW(N,3)
C
      CALL MC13E(N, ICN, LICN, IP, LENR, IOR, IB, NUM, IW(1,1),
     *  IW(1,2), IW(1,3))
      RETURN
      END
      SUBROUTINE MC13E(N, ICN, LICN, IP, LENR, ARP, IB, NUM, LOWL,
     *  NUMB, PREV)
      INTEGER STP, DUMMY
      INTEGER IP(N)
C
C ARP(I) IS ONE LESS THAN THE NUMBER OF UNSEARCHED EDGES LEAVING
C     NODE I.  AT THE END OF THE ALGORITHM IT IS SET TO A
C     PERMUTATION WHICH PUTS THE MATRIX IN BLOCK LOWER
C     TRIANGULAR FORM.
C IB(I) IS THE POSITION IN THE ORDERING OF THE START OF THE ITH
C     BLOCK.  IB(N+1-I) HOLDS THE NODE NUMBER OF THE ITH NODE
C     ON THE STACK.
C LOWL(I) IS THE SMALLEST STACK POSITION OF ANY NODE TO WHICH A PATH
C     FROM NODE I HAS BEEN FOUND.  IT IS SET TO N+1 WHEN NODE I
C     IS REMOVED FROM THE STACK.
C NUMB(I) IS THE POSITION OF NODE I IN THE STACK IF IT IS ON
C     IT, IS THE PERMUTED ORDER OF NODE I FOR THOSE NODES
C     WHOSE FINAL POSITION HAS BEEN FOUND AND IS OTHERWISE ZERO.
C PREV(I) IS THE NODE AT THE END OF THE PATH WHEN NODE I WAS
C     PLACED ON THE STACK.
C
      INTEGER ICN(LICN), LENR(N), ARP(N), IB(N), LOWL(N), NUMB(N),
     *  PREV(N)
C
C   ICNT IS THE NUMBER OF NODES WHOSE POSITIONS IN FINAL ORDERING HAVE
C     BEEN FOUND.
C
      ICNT = 0
C NUM IS THE NUMBER OF BLOCKS THAT HAVE BEEN FOUND.
      NUM = 0
      NNM1 = N + N - 1
C
C INITIALIZATION OF ARRAYS.
C
      DO 10 J=1,N
        NUMB(J) = 0
        ARP(J) = LENR(J) - 1
   10 CONTINUE
C
C
      DO 90 ISN=1,N
C LOOK FOR A STARTING NODE
        IF (NUMB(ISN).NE.0) GO TO 90
        IV = ISN
C IST IS THE NUMBER OF NODES ON THE STACK ... IT IS THE STACK POINTER.
        IST = 1
C PUT NODE IV AT BEGINNING OF STACK.
        LOWL(IV) = 1
        NUMB(IV) = 1
        IB(N) = IV
C
C THE BODY OF THIS LOOP PUTS A NEW NODE ON THE STACK OR BACKTRACKS.
C
        DO 80 DUMMY=1,NNM1
          I1 = ARP(IV)
C HAVE ALL EDGES LEAVING NODE IV BEEN SEARCHED.
          IF (I1.LT.0) GO TO 30
          I2 = IP(IV) + LENR(IV) - 1
          I1 = I2 - I1
C
C LOOK AT EDGES LEAVING NODE IV UNTIL ONE ENTERS A NEW NODE OR
C     ALL EDGES ARE EXHAUSTED.
C
          DO 20 II=I1,I2
            IW = ICN(II)
C HAS NODE IW BEEN ON STACK ALREADY.
            IF (NUMB(IW).EQ.0) GO TO 70
C UPDATE VALUE OF LOWL(IV) IF NECESSARY.
            IF (LOWL(IW).LT.LOWL(IV)) LOWL(IV) = LOWL(IW)
   20     CONTINUE
C
C THERE ARE NO MORE EDGES LEAVING NODE IV.
C
          ARP(IV) = -1
C IS NODE IV THE ROOT OF A BLOCK.
   30     IF (LOWL(IV).LT.NUMB(IV)) GO TO 60
C
C ORDER NODES IN A BLOCK.
C
          NUM = NUM + 1
          IST1 = N + 1 - IST
          LCNT = ICNT + 1
C
C PEEL BLOCK OFF THE TOP OF THE STACK STARTING AT THE TOP AND
C     WORKING DOWN TO THE ROOT OF THE BLOCK.
C
          DO 40 STP=IST1,N
            IW = IB(STP)
            LOWL(IW) = N + 1
            ICNT = ICNT + 1
            NUMB(IW) = ICNT
            IF (IW.EQ.IV) GO TO 50
   40     CONTINUE
   50     IST = N - STP
          IB(NUM) = LCNT
C ARE THERE ANY NODES LEFT ON THE STACK.
          IF (IST.NE.0) GO TO 60
C HAVE ALL THE NODES BEEN ORDERED.
          IF (ICNT.LT.N) GO TO 90
          GO TO 100
C
C BACKTRACK TO PREVIOUS NODE ON PATH.
C
   60     IW = IV
          IV = PREV(IV)
C UPDATE VALUE OF LOWL(IV) IF NECESSARY.
          IF (LOWL(IW).LT.LOWL(IV)) LOWL(IV) = LOWL(IW)
          GO TO 80
C
C PUT NEW NODE ON THE STACK.
C
   70     ARP(IV) = I2 - II - 1
          PREV(IW) = IV
          IV = IW
          IST = IST + 1
          LOWL(IV) = IST
          NUMB(IV) = IST
          K = N + 1 - IST
          IB(K) = IV
   80   CONTINUE
C
   90 CONTINUE
C
C PUT PERMUTATION IN THE REQUIRED FORM.
C
  100 DO 110 I=1,N
        II = NUMB(I)
        ARP(II) = I
  110 CONTINUE
      RETURN
      END
      SUBROUTINE SPSLV (N,A,IA,JA,B,R,C,MAX,X,ITEMP,RTEMP,IERR)
C-----------------------------------------------------------------------
C                 SOLUTION OF REAL SPARSE EQUATIONS
C-----------------------------------------------------------------------
C  SPSLV CALLS NSPIV1 WHICH USES SPARSE GAUSSIAN ELIMINATION WITH
C  COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B.  THE
C  ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN
C  A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y.  THE SOLUTION
C  PHASE SOLVES U X = Y.
C
C  INPUT ARGUMENTS---
C
C  N      INTEGER NUMBER OF EQUATIONS AND UNKNOWNS
C
C  A      REAL ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING THE
C         ACTUAL NONZEROS.  (SEE MATRIX STORAGE DESCRIPTION BELOW)
C
C  IA     INTEGER ARRAY OF N+1 ENTRIES CONTAINING ROW POINTERS TO A
C         (SEE MATRIX STORAGE DESCRIPTION BELOW)
C
C  JA     INTEGER ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING
C         COLUMN NUMBERS OF THE NONZEROS OF A.  (SEE MATRIX STORAGE
C         DESCRIPTION BELOW)
C
C  B      REAL ARRAY OF N ENTRIES CONTAINING RIGHT HAND SIDE DATA
C
C  R      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
C         ROWS OF A (I.E., THE ELIMINATION ORDER FOR THE EQUATIONS)
C
C  C      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
C         COLUMNS OF A.  C IS ALSO AN OUTPUT ARGUMENT
C
C  MAX    INTEGER NUMBER SPECIFYING MAXIMUM NUMBER OF OFF-DIAGONAL
C         NONZERO ENTRIES OF U WHICH MAY BE STORED
C
C  ITEMP  INTEGER ARRAY OF 3*N + MAX + 2 ENTRIES, FOR INTERNAL USE
C
C  RTEMP  REAL ARRAY OF N + MAX ENTRIES FOR INTERNAL USE
C
C
C  OUTPUT ARGUMENTS---
C
C  C      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
C         COLUMNS OF U.  C IS ALSO AN INPUT ARGUMENT
C
C  X      REAL ARRAY OF N ENTRIES CONTAINING THE SOLUTION VECTOR
C
C  IERR   INTEGER NUMBER WHICH INDICATES ERROR CONDITIONS OR
C         THE ACTUAL NUMBER OF OFF-DIAGONAL ENTRIES IN U (FOR
C         SUCCESSFUL COMPLETION)
C
C         IERR VALUES ARE---
C
C         0 LT IERR             SUCCESSFUL COMPLETION. IERR=MAX(1,M)
C                               WHERE M IS THE NUMBER OF OFF-DIAGONAL
C                               NONZERO ENTRIES OF U.
C
C         IERR = 0              ERROR.  N IS LESS THAN OR EQUAL TO 0
C
C         -N LE IERR LT 0       ERROR.  ROW NUMBER IABS(IERR) OF A IS
C                               IS NULL
C
C         -2*N LE IERR LT -N    ERROR.  ROW NUMBER IABS(IERR+N) HAS A
C                               DUPLICATE ENTRY
C
C         -3*N LE IERR LT -2*N  ERROR.  ROW NUMBER IABS(IERR+2*N)
C                               HAS A ZERO PIVOT
C
C         -4*N LE IERR LT -3*N  ERROR.  ROW NUMBER IABS(IERR+3*N)
C                               EXCEEDS STORAGE
C
C
C  STORAGE OF SPARSE MATRICES---
C
C  THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A.
C  THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT
C  NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER.  THE ARRAY JA
C  CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED
C  IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN
C  COLUMN J, THEN JA(K) = J).  THE ARRAY IA CONTAINS POINTERS TO THE
C  ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E.,
C  A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA).
C  IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZERO
C  ELEMENTS IN A.
C------------------------
      REAL A(*), B(N), X(N), RTEMP(*)
      INTEGER IA(*), JA(*), R(N), C(N), ITEMP(*)
      INTEGER IU, JU, U, Y, P
C
      IERR = 0
      IF (N .LE. 0) RETURN
C
C  SET INDICES TO DIVIDE TEMPORARY STORAGE FOR NSPIV1
C
      Y = 1
      U = Y + N
      P = N + 1
      IU = P + N + 1
      JU = IU + N + 1
C
C  COMPUTE THE INVERSE PERMUTATION OF C
C
      DO 10 K = 1,N
         L = C(K)
         ITEMP(L) = K
   10 CONTINUE
C
C  CALL NSPIV1 TO PERFORM COMPUTATIONS
C
      CALL NSPIV1 (N,IA,JA,A,B,MAX,R,C,ITEMP(1),X,RTEMP(Y),ITEMP(P),
     *             ITEMP(IU),ITEMP(JU),RTEMP(U),IERR)
      IF (IERR .EQ. 0) IERR = 1
      RETURN
      END
      SUBROUTINE NSPIV1 (N,IA,JA,A,B,MAX,R,C,IC,X,Y,P,IU,JU,U,IERR)
C
C
C  NSPIV1 USES SPARSE GAUSSIAN ELIMINATION WITH
C  COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B.  THE
C  ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN
C  A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y.  THE SOLUTION
C  PHASE SOLVES U X = Y.
C
C
C  SEE SPSLV FOR DESCRIPTIONS OF ALL INPUT AND OUTPUT ARGUMENTS
C  OTHER THAN THOSE DESCRIBED BELOW
C
C  IC  INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C
C      (I.E., IC(C(I)) = I). IC IS BOTH AN INPUT AND OUTPUT
C      ARGUMENT.
C
C  INPUT ARGUMENTS (USED INTERNALLY ONLY)---
C
C  Y   REAL ARRAY OF N ENTRIES USED TO COMPUTE THE UPDATED
C      RIGHT HAND SIDE
C
C  P   INTEGER ARRAY OF N+1 ENTRIES USED FOR A LINKED LIST.
C      P(N+1) IS THE LIST HEADER, AND THE ENTRY FOLLOWING
C      P(K) IS IN P(P(K)).  THUS, P(N+1) IS THE FIRST DATA
C      ITEM, P(P(N+1)) IS THE SECOND, ETC.  A POINTER OF
C      N+1 MARKS THE END OF THE LIST
C
C  IU  INTEGER ARRAY OF N+1 ENTRIES USED FOR ROW POINTERS TO U
C      (SEE MATRIX STORAGE DESCRIPTION BELOW)
C
C  JU  INTEGER ARRAY OF MAX ENTRIES USED FOR COLUMN NUMBERS OF
C      THE NONZEROS IN THE STRICT UPPER TRIANGLE OF U.  (SEE
C      MATRIX STORAGE DESCRIPTION BELOW)
C
C  U   REAL ARRAY OF MAX ENTRIES USED FOR THE ACTUAL NONZEROS IN
C      THE STRICT UPPER TRIANGLE OF U.  (SEE MATRIX STORAGE
C      DESCRIPTION BELOW)
C
C
C  STORAGE OF SPARSE MATRICES---
C
C  THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A.
C  THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT
C  NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER.  THE ARRAY JA
C  CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED
C  IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN
C  COLUMN J, THEN JA(K) = J).  THE ARRAY IA CONTAINS POINTERS TO THE
C  ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E.,
C  A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA).
C  IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZEROS IN
C  A.  IU, JU, AND U ARE USED IN A SIMILAR WAY TO STORE THE STRICT UPPER
C  TRIANGLE OF U, EXCEPT THAT JU ACTUALLY CONTAINS C(J) INSTEAD OF J
C
C
      REAL A(*), B(N), U(MAX), X(N), Y(N)
      REAL DK, LKI, XPV, XPVMAX, YK
      INTEGER C(N), IA(*), IC(N), IU(*), JA(*), JU(MAX), P(*), R(N)
      INTEGER CK, PK, PPK, PV, V, VI, VJ, VK
C
C  INITIALIZE WORK STORAGE AND POINTERS TO JU
C
      DO 10 J = 1,N
        X(J) = 0.0
 10   CONTINUE
      IU(1) = 1
      JUPTR = 0
C
C  PERFORM SYMBOLIC AND NUMERIC FACTORIZATION ROW BY ROW
C  VK (VI,VJ) IS THE GRAPH VERTEX FOR ROW K (I,J) OF U
C
      DO 170 K = 1,N
C
C  INITIALIZE LINKED LIST AND FREE STORAGE FOR THIS ROW
C  THE R(K)-TH ROW OF A BECOMES THE K-TH ROW OF U.
C
        P(N+1) = N+1
        VK = R(K)
C
C  SET UP ADJACENCY LIST FOR VK, ORDERED IN
C  CURRENT COLUMN ORDER OF U.  THE LOOP INDEX
C  GOES DOWNWARD TO EXPLOIT ANY COLUMNS
C  FROM A IN CORRECT RELATIVE ORDER
C
        JMIN = IA(VK)
        JMAX = IA(VK+1) - 1
        IF (JMIN .GT. JMAX)  GO TO 1002
        J = JMAX
 20       JAJ = JA(J)
          VJ = IC(JAJ)
C
C  STORE A(K,J) IN WORK VECTOR
C
          X(VJ) = A(J)
C  THIS CODE INSERTS VJ INTO ADJACENCY LIST OF VK
          PPK = N+1
 30       PK = PPK
          PPK = P(PK)
          IF (PPK - VJ)  30,1003,40
 40       P(VJ) = PPK
          P(PK) = VJ
          J = J - 1
          IF (J .GE. JMIN) GO TO 20
C
C  THE FOLLOWING CODE COMPUTES THE K-TH ROW OF U
C
        VI = N+1
        YK = B(VK)
 50     VI = P(VI)
        IF (VI .GE. K) GO TO 110
C
C  VI LT VK -- PROCESS THE L(K,I) ELEMENT AND MERGE THE
C  ADJACENCY OF VI WITH THE ORDERED ADJACENCY OF VK
C
        LKI = - X(VI)
        X(VI) = 0.0
C
C  ADJUST RIGHT HAND SIDE TO REFLECT ELIMINATION
C
        YK = YK + LKI * Y(VI)
        PPK = VI
        JMIN = IU(VI)
        JMAX = IU(VI+1) - 1
        IF (JMIN .GT. JMAX)  GO TO 50
        DO 100 J = JMIN,JMAX
          JUJ = JU(J)
          VJ = IC(JUJ)
C
C  IF VJ IS ALREADY IN THE ADJACENCY OF VK,
C  SKIP THE INSERTION
C
          IF (X(VJ) .NE. 0.0)  GO TO 90
C
C  INSERT VJ IN ADJACENCY LIST OF VK.
C  RESET PPK TO VI IF WE HAVE PASSED THE CORRECT
C  INSERTION SPOT.  (THIS HAPPENS WHEN THE ADJACENCY OF
C  VI IS NOT IN CURRENT COLUMN ORDER DUE TO PIVOTING.)
C
          IF (VJ - PPK) 60,90,70
 60       PPK = VI
 70       PK = PPK
          PPK = P(PK)
          IF (PPK - VJ)  70,90,80
 80       P(VJ) = PPK
          P(PK) = VJ
          PPK = VJ
C
C  COMPUTE L(K,J) = L(K,J) - L(K,I)*U(I,J) FOR L(K,I) NONZERO
C  COMPUTE U*(K,J) = U*(K,J) - L(K,I)*U(I,J) FOR U(K,J) NONZERO
C  (U*(K,J) = U(K,J)*D(K,K))
C
 90       X(VJ) = X(VJ) + LKI * U(J)
 100    CONTINUE
        GO TO 50
C
C  PIVOT--INTERCHANGE LARGEST ENTRY OF K-TH ROW OF U WITH
C  THE DIAGONAL ENTRY.
C
C  FIND LARGEST ENTRY, COUNTING OFF-DIAGONAL NONZEROS
C
 110    IF (VI .GT. N) GO TO 1004
        XPVMAX = ABS(X(VI))
        MAXC = VI
        NZCNT = 0
        PV = VI
 120      V = PV
          PV = P(PV)
          IF (PV .GT. N) GO TO 130
          NZCNT = NZCNT + 1
          XPV = ABS(X(PV))
          IF (XPV .LE. XPVMAX) GO TO 120
          XPVMAX = XPV
          MAXC = PV
          MAXCL = V
          GO TO 120
 130    IF (XPVMAX .EQ. 0.0) GO TO 1004
C
C  IF VI = K, THEN THERE IS AN ENTRY FOR DIAGONAL
C  WHICH MUST BE DELETED.  OTHERWISE, DELETE THE
C  ENTRY WHICH WILL BECOME THE DIAGONAL ENTRY
C
        IF (VI .EQ. K) GO TO 140
        IF (VI .EQ. MAXC) GO TO 140
        P(MAXCL) = P(MAXC)
        GO TO 150
 140    VI = P(VI)
C
C  COMPUTE D(K) = 1/L(K,K) AND PERFORM INTERCHANGE.
C
 150    DK = 1.0 / X(MAXC)
        X(MAXC) = X(K)
        I = C(K)
        C(K) = C(MAXC)
        C(MAXC) = I
        CK = C(K)
        IC(CK) = K
        IC(I) = MAXC
        X(K) = 0.0
C
C  UPDATE RIGHT HAND SIDE.
C
        Y(K) = YK * DK
C
C  COMPUTE VALUE FOR IU(K+1) AND CHECK FOR STORAGE OVERFLOW
C
        IU(K+1) = IU(K) + NZCNT
        IF (IU(K+1) .GT. MAX+1) GO TO 1005
C
C  MOVE COLUMN INDICES FROM LINKED LIST TO JU.
C  COLUMNS ARE STORED IN CURRENT ORDER WITH ORIGINAL
C  COLUMN NUMBER (C(J)) STORED FOR CURRENT COLUMN J
C
        IF (VI .GT. N)  GO TO 170
        J = VI
 160      JUPTR = JUPTR + 1
          JU(JUPTR) = C(J)
          U(JUPTR) = X(J) * DK
          X(J) = 0.0
          J = P(J)
          IF (J .LE. N) GO TO 160
 170    CONTINUE
C
C  BACKSOLVE U X = Y, AND REORDER X TO CORRESPOND WITH A
C
      K = N
      DO 200 I = 1,N
        YK = Y(K)
        JMIN = IU(K)
        JMAX = IU(K+1) - 1
        IF (JMIN .GT. JMAX)  GO TO 190
        DO 180 J = JMIN,JMAX
          JUJ = JU(J)
          JUJ = IC(JUJ)
          YK = YK - U(J) * Y(JUJ)
 180    CONTINUE
 190    Y(K) = YK
        CK = C(K)
        X(CK) = YK
        K = K - 1
 200  CONTINUE
C
C  RETURN WITH IERR = NUMBER OF OFF-DIAGONAL NONZEROS IN U
C
      IERR = IU(N+1) - IU(1)
      RETURN
C
C  ERROR RETURNS
C
C  ROW K OF A IS NULL
C
 1002 IERR = -K
      RETURN
C
C  ROW K OF A HAS A DUPLICATE ENTRY
C
 1003 IERR = -(N+K)
      RETURN
C
C  ZERO PIVOT IN ROW K
C
 1004 IERR = -(2*N+K)
      RETURN
C
C  STORAGE FOR U EXCEEDED ON ROW K
C
 1005 IERR = -(3*N+K)
      RETURN
      END
      SUBROUTINE RSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR)
C-----------------------------------------------------------------------
C                 SOLUTION OF REAL SPARSE EQUATIONS
C-----------------------------------------------------------------------
C     RSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO
C     SOLVE THE NXN LINEAR SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES
C     IF RSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO-
C     SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR
C     MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS
C     (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION
C     OBTAINED ON THE INITIAL CALL TO RSLV.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     N        NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     A,IA,JA  THE MATRIX A STORED IN SPARSE FORM.
C
C     B        ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND SIDE DATA.
C
C     R        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE ROWS OF A.
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED
C              ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT.
C
C     MAX      INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL
C              NONZERO ENTRIES OF L AND U WHICH MAY BE STORED.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE COLUMNS THAT WAS SELECTED BY THE ROUTINE.
C
C     X        REAL ARRAY OF N ENTRIES CONTAINING THE SOLUTION.
C              B AND X MAY SHARE THE SAME STORAGE AREA.
C
C     IERR     INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE
C              SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M)
C              WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO
C              ENTRIES OF L AND U. OTHERWISE IERR.LE.0.
C
C
C     GENERAL STORAGE AREAS ---
C
C     IWK      INTEGER ARRAY OF DIMENSION 4*N + MAX + 2.
C
C     WK       REAL ARRAY OF DIMENSION 2*N + MAX.
C
C
C     AFTER AN INITIAL CALL TO RSLV, THE ROUTINE MAY BE RECALLED WITH
C     M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA,
C     R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU
C     DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO RSLV
C     AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE A,IA,JA,MAX,
C     AND IERR ARE NOT REFERENCED.
C-----------------------------------------------------------------------
      REAL A(*), B(N), X(N), WK(*)
      INTEGER IA(*), JA(*), IWK(*)
      INTEGER R(N), C(N), Y, T, P
C
C     SET INDICES TO DIVIDE TEMPORARY STORAGE
C
      Y = N + 1
      T = Y + N
      P = N + 1
      IT = P + N + 1
      IU = IT + N + 1
      JT = IU + N
      IF (M0 .NE. 0) GO TO 20
C
C     COMPUTE THE INVERSE PERMUTATION OF C
C
      IERR = 0
      IF (N .LE. 0) RETURN
      DO 10 K = 1,N
         L = C(K)
         IWK(L) = K
   10 CONTINUE
C
C     OBTAIN THE LU DECOMPOSITION OF A
C
      CALL SPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT),
     *             IWK(IU),WK(Y),IWK(P),IERR)
      IF (IERR .LT. 0) RETURN
      IERR = MAX0(1,IERR)
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   20 CALL RSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU),
     *                  B,X,WK(Y))
      RETURN
      END
      SUBROUTINE RSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y)
      INTEGER R(N), C(N), IC(N)
      INTEGER IT(*), JT(*), IU(N)
      REAL B(N), D(N), T(*), X(N), Y(N), SUM
C
C            SOLVE LY = B BY FORWARD SUBSTITUTION
C
      DO 11 K = 1,N
         LK = R(K)
         SUM = B(LK)
         JMIN = IT(K)
         JMAX = IU(K) - 1
         IF (JMIN .GT. JMAX) GO TO 11
         DO 10 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            SUM = SUM - T(JJ)*Y(J)
   10    CONTINUE
   11 Y(K) = SUM/D(K)
C
C            SOLVE UX = B BY BACKWARD SUBSTITUTION
C             AND REORDER X TO CORRESPOND WITH A
C
      K = N
      DO 22 I = 1,N
         SUM = Y(K)
         JMIN = IU(K)
         JMAX = IT(K+1) - 1
         IF (JMIN .GT. JMAX) GO TO 21
         DO 20 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            SUM = SUM - T(JJ)*Y(J)
   20    CONTINUE
   21    Y(K) = SUM
         LK = C(K)
         X(LK) = Y(K)
         K = K - 1
   22 CONTINUE
      RETURN
      END
      SUBROUTINE TSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR)
C-----------------------------------------------------------------------
C                 SOLUTION OF REAL SPARSE EQUATIONS
C-----------------------------------------------------------------------
C     TSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO
C     SOLVE THE NXN LINEAR SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES
C     IF TSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO-
C     SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR
C     MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS
C     (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION
C     OBTAINED ON THE INITIAL CALL TO TSLV.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     N        NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     A,IA,JA  THE MATRIX A STORED IN SPARSE FORM.
C
C     B        ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND SIDE DATA.
C
C     R        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE ROWS OF A.
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED
C              ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT.
C
C     MAX      INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL
C              NONZERO ENTRIES OF L AND U WHICH MAY BE STORED.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE COLUMNS THAT WAS SELECTED BY THE ROUTINE.
C
C     X        REAL ARRAY OF N ENTRIES CONTAINING THE SOLUTION.
C              B AND X MAY SHARE THE SAME STORAGE AREA.
C
C     IERR     INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE
C              SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M)
C              WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO
C              ENTRIES OF L AND U. OTHERWISE IERR.LE.0.
C
C
C     GENERAL STORAGE AREAS ---
C
C     IWK      INTEGER ARRAY OF DIMENSION 4*N + MAX + 2.
C
C     WK       REAL ARRAY OF DIMENSION 2*N + MAX.
C
C
C     AFTER AN INITIAL CALL TO TSLV, THE ROUTINE MAY BE RECALLED WITH
C     M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA,
C     R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU
C     DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO TSLV
C     AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE A,IA,JA,MAX,
C     AND IERR ARE NOT REFERENCED.
C-----------------------------------------------------------------------
      REAL A(*), B(N), X(N), WK(*)
      INTEGER IA(*), JA(*), IWK(*)
      INTEGER R(N), C(N), Y, T, P
C
C     SET INDICES TO DIVIDE TEMPORARY STORAGE
C
      Y = N + 1
      T = Y + N
      P = N + 1
      IT = P + N + 1
      IU = IT + N + 1
      JT = IU + N
      IF (M0 .NE. 0) GO TO 20
C
C     COMPUTE THE INVERSE PERMUTATION OF C
C
      IERR = 0
      IF (N .LE. 0) RETURN
      DO 10 K = 1,N
         L = C(K)
         IWK(L) = K
   10 CONTINUE
C
C     OBTAIN THE LU DECOMPOSITION OF A
C
      CALL SPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT),
     *             IWK(IU),WK(Y),IWK(P),IERR)
      IF (IERR .LT. 0) RETURN
      IERR = MAX0(1,IERR)
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   20 CALL TSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU),
     *                  B,X,WK(Y))
      RETURN
      END
      SUBROUTINE TSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y)
      INTEGER R(N), C(N), IC(N)
      INTEGER IT(*), JT(*), IU(N)
      REAL B(N), D(N), T(*), X(N), Y(N)
C
C            SOLVE YU = B BY FORWARD SUBSTITUTION
C
      DO 10 K = 1,N
         LK = C(K)
         Y(K) = B(LK)
   10 CONTINUE
C
      DO 21 K = 1,N
         IF (Y(K) .EQ. 0.0) GO TO 21
         JMIN = IU(K)
         JMAX = IT(K+1) - 1
         IF (JMIN .GT. JMAX) GO TO 21
         DO 20 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            Y(J) = Y(J) - T(JJ)*Y(K)
   20    CONTINUE
   21 CONTINUE
C
C            SOLVE XL = Y BY BACKWARD SUBSTITUTION
C
      X(N) = Y(N)/D(N)
      IF (N .EQ. 1) RETURN
C
      K = N
      Y(N) = X(N)
      DO 32 I = 2,N
         JMIN = IT(K)
         JMAX = IU(K) - 1
         IF (JMIN .GT. JMAX) GO TO 31
         DO 30 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            Y(J) = Y(J) - T(JJ)*Y(K)
   30    CONTINUE
   31    K = K - 1
         Y(K) = Y(K)/D(K)
   32 CONTINUE
C
      DO 40 K = 1,N
         LK = R(K)
         X(LK) = Y(K)
   40 CONTINUE
      RETURN
      END
      SUBROUTINE SPLU (A,IA,JA,R,C,IC,N,MAX,D,T,IT,JT,IU,W,P,IERR)
C-----------------------------------------------------------------------
C     SPLU EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES
C     TO PERFORM THE LU DECOMPOSITION OF A REAL SPARSE MATRIX.
C     U IS A UNIT UPPER TRIANGULAR MATRIX.
C
C
C     INPUT ARGUMENTS ---
C
C     A,IA,JA  THE SPARSE MATRIX TO BE DECOMPOSED.
C
C     R        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE ROWS OF A.
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED
C              ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT.
C
C     IC       INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C
C              (I.E., IC(C(I)) = I). IC IS ALSO AN OUTPUT ARGUMENT.
C
C     N        ORDER OF THE MATRIX A.
C
C     MAX      INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL
C              NONZERO ENTRIES OF L AND U WHICH MAY BE STORED.
C
C
C     OUTPUT ARGUMENTS ---
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE COLUMNS THAT WAS SELECTED BY THE ROUTINE.
C
C     IC       INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C.
C
C     D        REAL ARRAY CONTAINING THE N DIAGONAL ELEMENTS OF L.
C
C     T,IT,IU  T CONTAINS THE OFF-DIAGONAL NONZERO ELEMENTS OF L AND
C              U. FOR I = 1,...,N THE OFF-DIAGONAL NONZERO ELEMENTS
C              OF THE I-TH ROW OF L ARE STORED IN LOCATIONS
C              IT(I),...,IU(I)-1 OF T, AND THE OFF-DIAGONAL NONZERO
C              ELEMENTS OF THE I-TH ROW OF U ARE STORED IN LOCATIONS
C              IU(I),...,IT(I+1)-1 OF T.
C
C     JT       INTEGER ARRAY CONTAINING THE COLUMN INDICES (ACCORDING
C              TO THE ORGINAL COLUMN ORDERING) OF THE ELEMENTS OF T
C              (I.E., FOR EACH L(I,J) AND U(I,J) IN T, C(J) IS THE
C              CORRESPONDING COLUMN INDEX IN JT).
C
C     IERR     INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE
C              LU DECOMPOSITION IS OBTAINED THEN IERR = THE NUMBER
C              OF OFF-DIAGONAL ENTRIES OF L AND U WHICH WERE STORED
C              IN T. OTHERWISE IERR IS ASSIGNED A NEGATIVE VALUE.
C
C
C     WORK SPACES ---
C
C     W        REAL ARRAY OF DIMENSION N.
C
C     P        INTEGER ARRAY OF DIMENSION N+1.
C-----------------------------------------------------------------------
      REAL A(*), D(N), T(MAX), W(N)
      INTEGER IA(*), JA(*)
      INTEGER R(N), C(N), IC(N)
      INTEGER IT(*), JT(MAX), IU(N)
      INTEGER P(*), PM
      REAL CONST, WI, WMAX
C
      JPTR = 0
      IT(1) = 1
      DO 10 J = 1,N
         W(J) = 0.0
   10 CONTINUE
C
C     PERFORM THE LU FACTORIZATION OF THE R(K)-TH ROW OF A
C
      DO 100 K = 1,N
      LK = R(K)
      JMIN = IA(LK)
      JMAX = IA(LK+1) - 1
      IF (JMIN .GT. JMAX) GO TO 200
C
C     SET P TO THE REORDERED ROW OF A
C
      P(N+1) = N + 1
      JJ = JMAX
   20 LJ = JA(JJ)
      J = IC(LJ)
      W(J) = A(JJ)
      PM = N + 1
   21 M = PM
      PM = P(M)
      IF (PM - J) 21,210,22
   22 P(M) = J
      P(J) = PM
      JJ = JJ - 1
      IF (JJ .GE. JMIN) GO TO 20
C
C     PROCESS THE ENTRIES IN THE LOWER TRIANGLE OF A
C
      I = N + 1
   30 I = P(I)
      IF (I .GE. K) GO TO 50
      IF (W(I) .EQ. 0.0) GO TO 30
C
C     L(K,I) IS NONZERO. THEREFORE STORE IT IN L.
C
      JPTR = JPTR + 1
      IF (JPTR .GT. MAX) GO TO 230
      CONST = W(I)
      T(JPTR) = CONST
      JT(JPTR) = C(I)
      W(I) = 0.0
C
C     PERFORM ELIMINATION USING THE I-TH ROW OF U
C
      JMIN = IU(I)
      JMAX = IT(I+1) - 1
      IF (JMIN .GT. JMAX) GO TO 30
      PM = I
      DO 43 JJ = JMIN,JMAX
         LJ = JT(JJ)
         J = IC(LJ)
         IF (W(J) .NE. 0.0) GO TO 43
         IF (J - PM) 40,43,41
   40       PM = I
   41       M = PM
            PM = P(M)
            IF (PM - J) 41,43,42
   42       P(M) = J
            P(J) = PM
            PM = J
   43 W(J) = W(J) - CONST*T(JJ)
      GO TO 30
C
C     SEARCH FOR THE K-TH PIVOT ELEMENT
C
   50 IF (I .GT. N) GO TO 220
      WMAX = ABS(W(I))
      MAXI = I
      PM = I
   51 M = PM
      PM = P(M)
      IF (PM .GT. N) GO TO 60
      WI = ABS(W(PM))
      IF (WI .LE. WMAX) GO TO 51
         WMAX = WI
         MAXI = PM
         MAXIL = M
         GO TO 51
C
C     STORE THE PIVOT IN D
C
   60 IF (WMAX .EQ. 0.0) GO TO 220
      D(K) = W(MAXI)
C
C     PERFORM THE COLUMN INTERCHANGE
C
      IF (I .EQ. K) GO TO 70
      IF (I .EQ. MAXI) GO TO 70
         P(MAXIL) = P(MAXI)
         GO TO 80
   70 I = P(I)
C
   80 W(MAXI) = W(K)
      W(K) = 0.0
      LK = C(K)
      LL = C(MAXI)
      C(K) = LL
      C(MAXI) = LK
      IC(LK) = MAXI
      IC(LL) = K
C
C     THE REMAINING ELEMENTS OF P FORM THE K-TH ROW OF U
C
      IU(K) = JPTR + 1
   90 IF (I .GT. N) GO TO 100
      IF (W(I) .EQ. 0.0) GO TO 91
         JPTR = JPTR + 1
         IF (JPTR .GT. MAX) GO TO 230
         T(JPTR) = W(I)/D(K)
         JT(JPTR) = C(I)
         W(I) = 0.0
   91 I = P(I)
      GO TO 90
C
C     PREPARE FOR THE NEXT ROW
C
  100 IT(K+1) = JPTR + 1
C
      IERR = JPTR
      RETURN
C
C     -------------------- ERROR RETURN --------------------
C
C     ROW R(K) IS NULL
C
  200 IERR = -K
      RETURN
C
C     ROW R(K) HAS A DUPLICATE ENTRY
C
  210 IERR = -(N + K)
      RETURN
C
C     ZERO PIVOT IN ROW R(K)
C
  220 IERR = -(2*N + K)
      RETURN
C
C     STORAGE FOR L AND U EXCEEDED ON ROW R(K)
C
  230 IERR = -(3*N + K)
      RETURN
      END
      SUBROUTINE DSPSLV (N,A,IA,JA,B,R,C,MAX,X,ITEMP,RTEMP,IERR)
C-----------------------------------------------------------------------
C          SOLUTION OF DOUBLE PRECISION SPARSE EQUATIONS
C-----------------------------------------------------------------------
C  DSPSLV CALLS DNSPIV WHICH USES SPARSE GAUSSIAN ELIMINATION WITH
C  COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B.  THE
C  ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN
C  A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y.  THE SOLUTION
C  PHASE SOLVES U X = Y.
C
C  INPUT ARGUMENTS---
C
C  N      INTEGER NUMBER OF EQUATIONS AND UNKNOWNS
C
C  A      DOUBLE PRECISION ARRAY WITH ONE ENTRY PER NONZERO IN A,
C         CONTAINING THE ACTUAL NONZEROS. (SEE THE MATRIX STORAGE
C         DESCRIPTION BELOW)
C
C  IA     INTEGER ARRAY OF N+1 ENTRIES CONTAINING ROW POINTERS TO A
C         (SEE MATRIX STORAGE DESCRIPTION BELOW)
C
C  JA     INTEGER ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING
C         COLUMN NUMBERS OF THE NONZEROS OF A.  (SEE MATRIX STORAGE
C         DESCRIPTION BELOW)
C
C  B      DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE RIGHT
C         HAND SIDE DATA
C
C  R      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
C         ROWS OF A (I.E., THE ELIMINATION ORDER FOR THE EQUATIONS)
C
C  C      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
C         COLUMNS OF A.  C IS ALSO AN OUTPUT ARGUMENT
C
C  MAX    INTEGER NUMBER SPECIFYING MAXIMUM NUMBER OF OFF-DIAGONAL
C         NONZERO ENTRIES OF U WHICH MAY BE STORED
C
C  ITEMP  INTEGER ARRAY OF 3*N + MAX + 2 ENTRIES, FOR INTERNAL USE
C
C  RTEMP  DOUBLE PRECISION ARRAY OF N + MAX ENTRIES FOR INTERNAL USE
C
C
C  OUTPUT ARGUMENTS---
C
C  C      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
C         COLUMNS OF U.  C IS ALSO AN INPUT ARGUMENT
C
C  X      DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE
C         SOLUTION VECTOR
C
C  IERR   INTEGER NUMBER WHICH INDICATES ERROR CONDITIONS OR
C         THE ACTUAL NUMBER OF OFF-DIAGONAL ENTRIES IN U (FOR
C         SUCCESSFUL COMPLETION)
C
C         IERR VALUES ARE---
C
C         0 LT IERR             SUCCESSFUL COMPLETION. IERR=MAX(1,M)
C                               WHERE M IS THE NUMBER OF OFF-DIAGONAL
C                               NONZERO ENTRIES OF U.
C
C         IERR = 0              ERROR.  N IS LESS THAN OR EQUAL TO 0
C
C         -N LE IERR LT 0       ERROR.  ROW NUMBER IABS(IERR) OF A IS
C                               IS NULL
C
C         -2*N LE IERR LT -N    ERROR.  ROW NUMBER IABS(IERR+N) HAS A
C                               DUPLICATE ENTRY
C
C         -3*N LE IERR LT -2*N  ERROR.  ROW NUMBER IABS(IERR+2*N)
C                               HAS A ZERO PIVOT
C
C         -4*N LE IERR LT -3*N  ERROR.  ROW NUMBER IABS(IERR+3*N)
C                               EXCEEDS STORAGE
C
C
C  STORAGE OF SPARSE MATRICES---
C
C  THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A.
C  THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT
C  NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER.  THE ARRAY JA
C  CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED
C  IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN
C  COLUMN J, THEN JA(K) = J).  THE ARRAY IA CONTAINS POINTERS TO THE
C  ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E.,
C  A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA).
C  IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZERO
C  ELEMENTS IN A.
C------------------------
      DOUBLE PRECISION A(*), B(N), X(N), RTEMP(*)
      INTEGER IA(*), JA(*), R(N), C(N), ITEMP(*)
      INTEGER IU, JU, U, Y, P
C
      IERR = 0
      IF (N .LE. 0) RETURN
C
C  SET INDICES TO DIVIDE TEMPORARY STORAGE FOR DNSPIV
C
      Y = 1
      U = Y + N
      P = N + 1
      IU = P + N + 1
      JU = IU + N + 1
C
C  COMPUTE THE INVERSE PERMUTATION OF C
C
      DO 10 K = 1,N
         L = C(K)
         ITEMP(L) = K
   10 CONTINUE
C
C  CALL DNSPIV TO PERFORM COMPUTATIONS
C
      CALL DNSPIV (N,IA,JA,A,B,MAX,R,C,ITEMP(1),X,RTEMP(Y),ITEMP(P),
     *             ITEMP(IU),ITEMP(JU),RTEMP(U),IERR)
      IF (IERR .EQ. 0) IERR = 1
      RETURN
      END
      SUBROUTINE DNSPIV (N,IA,JA,A,B,MAX,R,C,IC,X,Y,P,IU,JU,U,IERR)
C
C
C  DNSPIV USES SPARSE GAUSSIAN ELIMINATION WITH
C  COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B.  THE
C  ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN
C  A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y.  THE SOLUTION
C  PHASE SOLVES U X = Y.
C
C
C  SEE DSPSLV FOR DESCRIPTIONS OF ALL INPUT AND OUTPUT ARGUMENTS
C  OTHER THAN THOSE DESCRIBED BELOW
C
C  IC  INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C
C      (I.E., IC(C(I)) = I). IC IS BOTH AN INPUT AND OUTPUT
C      ARGUMENT.
C
C  INPUT ARGUMENTS (USED INTERNALLY ONLY)---
C
C  Y   DOUBLE PRECISION ARRAY OF N ENTRIES USED TO COMPUTE
C      THE UPDATED RIGHT HAND SIDE
C
C  P   INTEGER ARRAY OF N+1 ENTRIES USED FOR A LINKED LIST.
C      P(N+1) IS THE LIST HEADER, AND THE ENTRY FOLLOWING
C      P(K) IS IN P(P(K)).  THUS, P(N+1) IS THE FIRST DATA
C      ITEM, P(P(N+1)) IS THE SECOND, ETC.  A POINTER OF
C      N+1 MARKS THE END OF THE LIST
C
C  IU  INTEGER ARRAY OF N+1 ENTRIES USED FOR ROW POINTERS TO U
C      (SEE MATRIX STORAGE DESCRIPTION BELOW)
C
C  JU  INTEGER ARRAY OF MAX ENTRIES USED FOR COLUMN NUMBERS OF
C      THE NONZEROS IN THE STRICT UPPER TRIANGLE OF U.  (SEE
C      MATRIX STORAGE DESCRIPTION BELOW)
C
C  U   DOUBLE PRECISION ARRAY OF MAX ENTRIES USED FOR THE ACTUAL
C      NONZEROS IN THE STRICT UPPER TRIANGLE OF U. (SEE MATRIX
C      STORAGE DESCRIPTION BELOW)
C
C
C  STORAGE OF SPARSE MATRICES---
C
C  THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A.
C  THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT
C  NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER.  THE ARRAY JA
C  CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED
C  IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN
C  COLUMN J, THEN JA(K) = J).  THE ARRAY IA CONTAINS POINTERS TO THE
C  ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E.,
C  A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA).
C  IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZEROS IN
C  A.  IU, JU, AND U ARE USED IN A SIMILAR WAY TO STORE THE STRICT UPPER
C  TRIANGLE OF U, EXCEPT THAT JU ACTUALLY CONTAINS C(J) INSTEAD OF J
C
C
      DOUBLE PRECISION A(*), B(N), U(MAX), X(N), Y(N)
      DOUBLE PRECISION DK, LKI, XPV, XPVMAX, YK
      INTEGER C(N), IA(*), IC(N), IU(*), JA(*), JU(MAX), P(*), R(N)
      INTEGER CK, PK, PPK, PV, V, VI, VJ, VK
C
C  INITIALIZE WORK STORAGE AND POINTERS TO JU
C
      DO 10 J = 1,N
        X(J) = 0.D0
 10   CONTINUE
      IU(1) = 1
      JUPTR = 0
C
C  PERFORM SYMBOLIC AND NUMERIC FACTORIZATION ROW BY ROW
C  VK (VI,VJ) IS THE GRAPH VERTEX FOR ROW K (I,J) OF U
C
      DO 170 K = 1,N
C
C  INITIALIZE LINKED LIST AND FREE STORAGE FOR THIS ROW
C  THE R(K)-TH ROW OF A BECOMES THE K-TH ROW OF U.
C
        P(N+1) = N+1
        VK = R(K)
C
C  SET UP ADJACENCY LIST FOR VK, ORDERED IN
C  CURRENT COLUMN ORDER OF U.  THE LOOP INDEX
C  GOES DOWNWARD TO EXPLOIT ANY COLUMNS
C  FROM A IN CORRECT RELATIVE ORDER
C
        JMIN = IA(VK)
        JMAX = IA(VK+1) - 1
        IF (JMIN .GT. JMAX)  GO TO 1002
        J = JMAX
 20       JAJ = JA(J)
          VJ = IC(JAJ)
C
C  STORE A(K,J) IN WORK VECTOR
C
          X(VJ) = A(J)
C  THIS CODE INSERTS VJ INTO ADJACENCY LIST OF VK
          PPK = N+1
 30       PK = PPK
          PPK = P(PK)
          IF (PPK - VJ)  30,1003,40
 40       P(VJ) = PPK
          P(PK) = VJ
          J = J - 1
          IF (J .GE. JMIN) GO TO 20
C
C  THE FOLLOWING CODE COMPUTES THE K-TH ROW OF U
C
        VI = N+1
        YK = B(VK)
 50     VI = P(VI)
        IF (VI .GE. K) GO TO 110
C
C  VI LT VK -- PROCESS THE L(K,I) ELEMENT AND MERGE THE
C  ADJACENCY OF VI WITH THE ORDERED ADJACENCY OF VK
C
        LKI = - X(VI)
        X(VI) = 0.D0
C
C  ADJUST RIGHT HAND SIDE TO REFLECT ELIMINATION
C
        YK = YK + LKI * Y(VI)
        PPK = VI
        JMIN = IU(VI)
        JMAX = IU(VI+1) - 1
        IF (JMIN .GT. JMAX)  GO TO 50
        DO 100 J = JMIN,JMAX
          JUJ = JU(J)
          VJ = IC(JUJ)
C
C  IF VJ IS ALREADY IN THE ADJACENCY OF VK,
C  SKIP THE INSERTION
C
          IF (X(VJ) .NE. 0.D0)  GO TO 90
C
C  INSERT VJ IN ADJACENCY LIST OF VK.
C  RESET PPK TO VI IF WE HAVE PASSED THE CORRECT
C  INSERTION SPOT.  (THIS HAPPENS WHEN THE ADJACENCY OF
C  VI IS NOT IN CURRENT COLUMN ORDER DUE TO PIVOTING.)
C
          IF (VJ - PPK) 60,90,70
 60       PPK = VI
 70       PK = PPK
          PPK = P(PK)
          IF (PPK - VJ)  70,90,80
 80       P(VJ) = PPK
          P(PK) = VJ
          PPK = VJ
C
C  COMPUTE L(K,J) = L(K,J) - L(K,I)*U(I,J) FOR L(K,I) NONZERO
C  COMPUTE U*(K,J) = U*(K,J) - L(K,I)*U(I,J) FOR U(K,J) NONZERO
C  (U*(K,J) = U(K,J)*D(K,K))
C
 90       X(VJ) = X(VJ) + LKI * U(J)
 100    CONTINUE
        GO TO 50
C
C  PIVOT--INTERCHANGE LARGEST ENTRY OF K-TH ROW OF U WITH
C  THE DIAGONAL ENTRY.
C
C  FIND LARGEST ENTRY, COUNTING OFF-DIAGONAL NONZEROS
C
 110    IF (VI .GT. N) GO TO 1004
        XPVMAX = DABS(X(VI))
        MAXC = VI
        NZCNT = 0
        PV = VI
 120      V = PV
          PV = P(PV)
          IF (PV .GT. N) GO TO 130
          NZCNT = NZCNT + 1
          XPV = DABS(X(PV))
          IF (XPV .LE. XPVMAX) GO TO 120
          XPVMAX = XPV
          MAXC = PV
          MAXCL = V
          GO TO 120
 130    IF (XPVMAX .EQ. 0.D0) GO TO 1004
C
C  IF VI = K, THEN THERE IS AN ENTRY FOR DIAGONAL
C  WHICH MUST BE DELETED.  OTHERWISE, DELETE THE
C  ENTRY WHICH WILL BECOME THE DIAGONAL ENTRY
C
        IF (VI .EQ. K) GO TO 140
        IF (VI .EQ. MAXC) GO TO 140
        P(MAXCL) = P(MAXC)
        GO TO 150
 140    VI = P(VI)
C
C  COMPUTE D(K) = 1/L(K,K) AND PERFORM INTERCHANGE.
C
 150    DK = 1.D0 / X(MAXC)
        X(MAXC) = X(K)
        I = C(K)
        C(K) = C(MAXC)
        C(MAXC) = I
        CK = C(K)
        IC(CK) = K
        IC(I) = MAXC
        X(K) = 0.D0
C
C  UPDATE RIGHT HAND SIDE.
C
        Y(K) = YK * DK
C
C  COMPUTE VALUE FOR IU(K+1) AND CHECK FOR STORAGE OVERFLOW
C
        IU(K+1) = IU(K) + NZCNT
        IF (IU(K+1) .GT. MAX+1) GO TO 1005
C
C  MOVE COLUMN INDICES FROM LINKED LIST TO JU.
C  COLUMNS ARE STORED IN CURRENT ORDER WITH ORIGINAL
C  COLUMN NUMBER (C(J)) STORED FOR CURRENT COLUMN J
C
        IF (VI .GT. N)  GO TO 170
        J = VI
 160      JUPTR = JUPTR + 1
          JU(JUPTR) = C(J)
          U(JUPTR) = X(J) * DK
          X(J) = 0.D0
          J = P(J)
          IF (J .LE. N) GO TO 160
 170    CONTINUE
C
C  BACKSOLVE U X = Y, AND REORDER X TO CORRESPOND WITH A
C
      K = N
      DO 200 I = 1,N
        YK = Y(K)
        JMIN = IU(K)
        JMAX = IU(K+1) - 1
        IF (JMIN .GT. JMAX)  GO TO 190
        DO 180 J = JMIN,JMAX
          JUJ = JU(J)
          JUJ = IC(JUJ)
          YK = YK - U(J) * Y(JUJ)
 180    CONTINUE
 190    Y(K) = YK
        CK = C(K)
        X(CK) = YK
        K = K - 1
 200  CONTINUE
C
C  RETURN WITH IERR = NUMBER OF OFF-DIAGONAL NONZEROS IN U
C
      IERR = IU(N+1) - IU(1)
      RETURN
C
C  ERROR RETURNS
C
C  ROW K OF A IS NULL
C
 1002 IERR = -K
      RETURN
C
C  ROW K OF A HAS A DUPLICATE ENTRY
C
 1003 IERR = -(N+K)
      RETURN
C
C  ZERO PIVOT IN ROW K
C
 1004 IERR = -(2*N+K)
      RETURN
C
C  STORAGE FOR U EXCEEDED ON ROW K
C
 1005 IERR = -(3*N+K)
      RETURN
      END
      SUBROUTINE DSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR)
C-----------------------------------------------------------------------
C          SOLUTION OF DOUBLE PRECISION SPARSE EQUATIONS
C-----------------------------------------------------------------------
C     DSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO
C     SOLVE THE NXN LINEAR SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES
C     IF DSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO-
C     SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR
C     MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS
C     (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION
C     OBTAINED ON THE INITIAL CALL TO DSLV.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     N        NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     A,IA,JA  THE DOUBLE PRECISION MATRIX A STORED IN SPARSE FORM.
C
C     B        DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE
C              RIGHT HAND SIDE DATA.
C
C     R        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE ROWS OF A.
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED
C              ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT.
C
C     MAX      INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL
C              NONZERO ENTRIES OF L AND U WHICH MAY BE STORED.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE COLUMNS THAT WAS SELECTED BY THE ROUTINE.
C
C     X        DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE
C              SOLUTION. B AND X MAY SHARE THE SAME STORAGE AREA.
C
C     IERR     INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE
C              SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M)
C              WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO
C              ENTRIES OF L AND U. OTHERWISE IERR.LE.0.
C
C
C     GENERAL STORAGE AREAS ---
C
C     IWK      INTEGER ARRAY OF DIMENSION 4*N + MAX + 2.
C
C     WK       DOUBLE PRECISION ARRAY OF DIMENSION 2*N + MAX.
C
C
C     AFTER AN INITIAL CALL TO DSLV, THE ROUTINE MAY BE RECALLED WITH
C     M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA,
C     R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU
C     DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO DSLV
C     AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE A,IA,JA,MAX,
C     AND IERR ARE NOT REFERENCED.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(N), X(N), WK(*)
      INTEGER IA(*), JA(*), IWK(*)
      INTEGER R(N), C(N), Y, T, P
C
C     SET INDICES TO DIVIDE TEMPORARY STORAGE
C
      Y = N + 1
      T = Y + N
      P = N + 1
      IT = P + N + 1
      IU = IT + N + 1
      JT = IU + N
      IF (M0 .NE. 0) GO TO 20
C
C     COMPUTE THE INVERSE PERMUTATION OF C
C
      IERR = 0
      IF (N .LE. 0) RETURN
      DO 10 K = 1,N
         L = C(K)
         IWK(L) = K
   10 CONTINUE
C
C     OBTAIN THE LU DECOMPOSITION OF A
C
      CALL DSPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT),
     *             IWK(IU),WK(Y),IWK(P),IERR)
      IF (IERR .LT. 0) RETURN
      IERR = MAX0(1,IERR)
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   20 CALL DSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU),
     *                  B,X,WK(Y))
      RETURN
      END
      SUBROUTINE DSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y)
      INTEGER R(N), C(N), IC(N)
      INTEGER IT(*), JT(*), IU(N)
      DOUBLE PRECISION B(N), D(N), T(*), X(N), Y(N), SUM
C
C            SOLVE LY = B BY FORWARD SUBSTITUTION
C
      DO 11 K = 1,N
         LK = R(K)
         SUM = B(LK)
         JMIN = IT(K)
         JMAX = IU(K) - 1
         IF (JMIN .GT. JMAX) GO TO 11
         DO 10 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            SUM = SUM - T(JJ)*Y(J)
   10    CONTINUE
   11 Y(K) = SUM/D(K)
C
C            SOLVE UX = B BY BACKWARD SUBSTITUTION
C             AND REORDER X TO CORRESPOND WITH A
C
      K = N
      DO 22 I = 1,N
         SUM = Y(K)
         JMIN = IU(K)
         JMAX = IT(K+1) - 1
         IF (JMIN .GT. JMAX) GO TO 21
         DO 20 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            SUM = SUM - T(JJ)*Y(J)
   20    CONTINUE
   21    Y(K) = SUM
         LK = C(K)
         X(LK) = Y(K)
         K = K - 1
   22 CONTINUE
      RETURN
      END
      SUBROUTINE DTSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR)
C-----------------------------------------------------------------------
C          SOLUTION OF DOUBLE PRECISION SPARSE EQUATIONS
C-----------------------------------------------------------------------
C     DTSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO
C     SOLVE THE NXN LINEAR SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES
C     IF DTSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO-
C     SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR
C     MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS
C     (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION
C     OBTAINED ON THE INITIAL CALL TO DTSLV.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     N        NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     A,IA,JA  THE DOUBLE PRECISION MATRIX A STORED IN SPARSE FORM.
C
C     B        DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE
C              RIGHT HAND SIDE DATA.
C
C     R        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE ROWS OF A.
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED
C              ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT.
C
C     MAX      INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL
C              NONZERO ENTRIES OF L AND U WHICH MAY BE STORED.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE COLUMNS THAT WAS SELECTED BY THE ROUTINE.
C
C     X        DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE
C              SOLUTION. B AND X MAY SHARE THE SAME STORAGE AREA.
C
C     IERR     INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE
C              SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M)
C              WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO
C              ENTRIES OF L AND U. OTHERWISE IERR.LE.0.
C
C
C     GENERAL STORAGE AREAS ---
C
C     IWK      INTEGER ARRAY OF DIMENSION 4*N + MAX + 2.
C
C     WK       DOUBLE PRECISION ARRAY OF DIMENSION 2*N + MAX.
C
C
C     AFTER AN INITIAL CALL TO DTSLV, THE ROUTINE MAY BE RECALLED WITH
C     M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA,
C     R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU
C     DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO DTSLV
C     AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE A,IA,JA,MAX,
C     AND IERR ARE NOT REFERENCED.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), B(N), X(N), WK(*)
      INTEGER IA(*), JA(*), IWK(*)
      INTEGER R(N), C(N), Y, T, P
C
C     SET INDICES TO DIVIDE TEMPORARY STORAGE
C
      Y = N + 1
      T = Y + N
      P = N + 1
      IT = P + N + 1
      IU = IT + N + 1
      JT = IU + N
      IF (M0 .NE. 0) GO TO 20
C
C     COMPUTE THE INVERSE PERMUTATION OF C
C
      IERR = 0
      IF (N .LE. 0) RETURN
      DO 10 K = 1,N
         L = C(K)
         IWK(L) = K
   10 CONTINUE
C
C     OBTAIN THE LU DECOMPOSITION OF A
C
      CALL DSPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT),
     *             IWK(IU),WK(Y),IWK(P),IERR)
      IF (IERR .LT. 0) RETURN
      IERR = MAX0(1,IERR)
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   20 CALL DTSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU),
     *                  B,X,WK(Y))
      RETURN
      END
      SUBROUTINE DTSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y)
      INTEGER R(N), C(N), IC(N)
      INTEGER IT(*), JT(*), IU(N)
      DOUBLE PRECISION B(N), D(N), T(*), X(N), Y(N)
C
C            SOLVE YU = B BY FORWARD SUBSTITUTION
C
      DO 10 K = 1,N
         LK = C(K)
         Y(K) = B(LK)
   10 CONTINUE
C
      DO 21 K = 1,N
         IF (Y(K) .EQ. 0.D0) GO TO 21
         JMIN = IU(K)
         JMAX = IT(K+1) - 1
         IF (JMIN .GT. JMAX) GO TO 21
         DO 20 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            Y(J) = Y(J) - T(JJ)*Y(K)
   20    CONTINUE
   21 CONTINUE
C
C            SOLVE XL = Y BY BACKWARD SUBSTITUTION
C
      X(N) = Y(N)/D(N)
      IF (N .EQ. 1) RETURN
C
      K = N
      Y(N) = X(N)
      DO 32 I = 2,N
         JMIN = IT(K)
         JMAX = IU(K) - 1
         IF (JMIN .GT. JMAX) GO TO 31
         DO 30 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            Y(J) = Y(J) - T(JJ)*Y(K)
   30    CONTINUE
   31    K = K - 1
         Y(K) = Y(K)/D(K)
   32 CONTINUE
C
      DO 40 K = 1,N
         LK = R(K)
         X(LK) = Y(K)
   40 CONTINUE
      RETURN
      END
      SUBROUTINE DSPLU (A,IA,JA,R,C,IC,N,MAX,D,T,IT,JT,IU,W,P,IERR)
C-----------------------------------------------------------------------
C     DSPLU EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES
C     TO PERFORM THE LU DECOMPOSITION OF A DOUBLE PRECISION SPARSE
C     MATRIX. U IS A UNIT UPPER TRIANGULAR MATRIX.
C
C
C     INPUT ARGUMENTS ---
C
C     A,IA,JA  THE SPARSE MATRIX TO BE DECOMPOSED.
C
C     R        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE ROWS OF A.
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED
C              ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT.
C
C     IC       INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C
C              (I.E., IC(C(I)) = I). IC IS ALSO AN OUTPUT ARGUMENT.
C
C     N        ORDER OF THE MATRIX A.
C
C     MAX      INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL
C              NONZERO ENTRIES OF L AND U WHICH MAY BE STORED.
C
C
C     OUTPUT ARGUMENTS ---
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE COLUMNS THAT WAS SELECTED BY THE ROUTINE.
C
C     IC       INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C.
C
C     D        DOUBLE PRECISION ARRAY CONTAINING THE N DIAGONAL
C              ELEMENTS OF L.
C
C     T,IT,IU  T CONTAINS THE OFF-DIAGONAL NONZERO ELEMENTS OF L AND
C              U. FOR I = 1,...,N THE OFF-DIAGONAL NONZERO ELEMENTS
C              OF THE I-TH ROW OF L ARE STORED IN LOCATIONS
C              IT(I),...,IU(I)-1 OF T, AND THE OFF-DIAGONAL NONZERO
C              ELEMENTS OF THE I-TH ROW OF U ARE STORED IN LOCATIONS
C              IU(I),...,IT(I+1)-1 OF T.
C
C     JT       INTEGER ARRAY CONTAINING THE COLUMN INDICES (ACCORDING
C              TO THE ORGINAL COLUMN ORDERING) OF THE ELEMENTS OF T
C              (I.E., FOR EACH L(I,J) AND U(I,J) IN T, C(J) IS THE
C              CORRESPONDING COLUMN INDEX IN JT).
C
C     IERR     INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE
C              LU DECOMPOSITION IS OBTAINED THEN IERR = THE NUMBER
C              OF OFF-DIAGONAL ENTRIES OF L AND U WHICH WERE STORED
C              IN T. OTHERWISE IERR IS ASSIGNED A NEGATIVE VALUE.
C
C
C     WORK SPACES ---
C
C     W        DOUBLE PRECISION ARRAY OF DIMENSION N.
C
C     P        INTEGER ARRAY OF DIMENSION N+1.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), D(N), T(MAX), W(N)
      INTEGER IA(*), JA(*)
      INTEGER R(N), C(N), IC(N)
      INTEGER IT(*), JT(MAX), IU(N)
      INTEGER P(*), PM
      DOUBLE PRECISION CONST, WI, WMAX
C
      JPTR = 0
      IT(1) = 1
      DO 10 J = 1,N
         W(J) = 0.D0
   10 CONTINUE
C
C     PERFORM THE LU FACTORIZATION OF THE R(K)-TH ROW OF A
C
      DO 100 K = 1,N
      LK = R(K)
      JMIN = IA(LK)
      JMAX = IA(LK+1) - 1
      IF (JMIN .GT. JMAX) GO TO 200
C
C     SET P TO THE REORDERED ROW OF A
C
      P(N+1) = N + 1
      JJ = JMAX
   20 LJ = JA(JJ)
      J = IC(LJ)
      W(J) = A(JJ)
      PM = N + 1
   21 M = PM
      PM = P(M)
      IF (PM - J) 21,210,22
   22 P(M) = J
      P(J) = PM
      JJ = JJ - 1
      IF (JJ .GE. JMIN) GO TO 20
C
C     PROCESS THE ENTRIES IN THE LOWER TRIANGLE OF A
C
      I = N + 1
   30 I = P(I)
      IF (I .GE. K) GO TO 50
      IF (W(I) .EQ. 0.D0) GO TO 30
C
C     L(K,I) IS NONZERO. THEREFORE STORE IT IN L.
C
      JPTR = JPTR + 1
      IF (JPTR .GT. MAX) GO TO 230
      CONST = W(I)
      T(JPTR) = CONST
      JT(JPTR) = C(I)
      W(I) = 0.D0
C
C     PERFORM ELIMINATION USING THE I-TH ROW OF U
C
      JMIN = IU(I)
      JMAX = IT(I+1) - 1
      IF (JMIN .GT. JMAX) GO TO 30
      PM = I
      DO 43 JJ = JMIN,JMAX
         LJ = JT(JJ)
         J = IC(LJ)
         IF (W(J) .NE. 0.D0) GO TO 43
         IF (J - PM) 40,43,41
   40       PM = I
   41       M = PM
            PM = P(M)
            IF (PM - J) 41,43,42
   42       P(M) = J
            P(J) = PM
            PM = J
   43 W(J) = W(J) - CONST*T(JJ)
      GO TO 30
C
C     SEARCH FOR THE K-TH PIVOT ELEMENT
C
   50 IF (I .GT. N) GO TO 220
      WMAX = DABS(W(I))
      MAXI = I
      PM = I
   51 M = PM
      PM = P(M)
      IF (PM .GT. N) GO TO 60
      WI = DABS(W(PM))
      IF (WI .LE. WMAX) GO TO 51
         WMAX = WI
         MAXI = PM
         MAXIL = M
         GO TO 51
C
C     STORE THE PIVOT IN D
C
   60 IF (WMAX .EQ. 0.D0) GO TO 220
      D(K) = W(MAXI)
C
C     PERFORM THE COLUMN INTERCHANGE
C
      IF (I .EQ. K) GO TO 70
      IF (I .EQ. MAXI) GO TO 70
         P(MAXIL) = P(MAXI)
         GO TO 80
   70 I = P(I)
C
   80 W(MAXI) = W(K)
      W(K) = 0.D0
      LK = C(K)
      LL = C(MAXI)
      C(K) = LL
      C(MAXI) = LK
      IC(LK) = MAXI
      IC(LL) = K
C
C     THE REMAINING ELEMENTS OF P FORM THE K-TH ROW OF U
C
      IU(K) = JPTR + 1
   90 IF (I .GT. N) GO TO 100
      IF (W(I) .EQ. 0.D0) GO TO 91
         JPTR = JPTR + 1
         IF (JPTR .GT. MAX) GO TO 230
         T(JPTR) = W(I)/D(K)
         JT(JPTR) = C(I)
         W(I) = 0.D0
   91 I = P(I)
      GO TO 90
C
C     PREPARE FOR THE NEXT ROW
C
  100 IT(K+1) = JPTR + 1
C
      IERR = JPTR
      RETURN
C
C     -------------------- ERROR RETURN --------------------
C
C     ROW R(K) IS NULL
C
  200 IERR = -K
      RETURN
C
C     ROW R(K) HAS A DUPLICATE ENTRY
C
  210 IERR = -(N + K)
      RETURN
C
C     ZERO PIVOT IN ROW R(K)
C
  220 IERR = -(2*N + K)
      RETURN
C
C     STORAGE FOR L AND U EXCEEDED ON ROW R(K)
C
  230 IERR = -(3*N + K)
      RETURN
      END
      SUBROUTINE S1CND (N, A, IA, JA, R, C, MAX, COND, IWK, WK, IERR)
C-----------------------------------------------------------------------
C              COMPUTATION OF THE L1 CONDITION NUMBER
C                       OF A SPARSE MATRIX A
C-----------------------------------------------------------------------
      REAL A(*), WK(*)
      INTEGER IA(*), JA(*), R(N), C(N), IWK(*)
C-----------------------
C     REAL WK(4*N + MAX)
C     INTEGER IWK(5*N + MAX + 2)
C-----------------------
      COND = 0.0
      CALL S1NRM (A, IA, JA, N, N, ANORM, WK)
      IF (ANORM .EQ. 0.0) GO TO 50
C
      IX = 2*N + MAX + 1
      IV = IX + N
      ISGN = 4*N + MAX + 3
C
      KASE = 0
      AINORM = 0.0
      CALL SONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE,
     *             ITER, J, JUMP)
      CALL RSLV (0, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX),
     *           IWK(1), WK(1), IERR)
C
C     CHECK IF A IS SINGULAR OR IF THERE ARE ERRORS
C
      IF (IERR .GT. 0) GO TO 20
      IF (IABS(IERR) .LE. N) GO TO 50
      IERR = IERR + N
      IF (IABS(IERR) .LE. N) RETURN
      IERR = IERR + N
      IF (IABS(IERR) .LE. N) GO TO 50
      RETURN
C
C     GENERAL LOOP TO ESTIMATE THE NORM  AINORM
C     OF THE INVERSE OF A
C
   20 CALL SONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE,
     *             ITER, J, JUMP)
      IF (KASE .EQ. 0) GO TO 40
      IF (KASE .NE. 1) GO TO 30
         CALL RSLV (1, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX),
     *              IWK(1), WK(1), IERR)
         GO TO 20
   30 CALL TSLV (1, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX),
     *           IWK(1), WK(1), IERR)
      GO TO 20
C
C     COMPUTE THE VALUE OF COND
C
   40 COND = ANORM*AINORM
      RETURN
C
C     SINGULAR CASE
C
   50 IERR = 0
      RETURN
      END
      SUBROUTINE DS1CND (N, A, IA, JA, R, C, MAX, COND, IWK, WK, IERR)
C-----------------------------------------------------------------------
C              COMPUTATION OF THE L1 CONDITION NUMBER
C                       OF A SPARSE MATRIX A
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), COND, WK(*), ANORM, AINORM
      INTEGER IA(*), JA(*), R(N), C(N), IWK(*)
C-----------------------
C     DOUBLE PRECISION WK(4*N + MAX)
C     INTEGER IWK(5*N + MAX + 2)
C-----------------------
      COND = 0.D0
      CALL DS1NRM (A, IA, JA, N, N, ANORM, WK)
      IF (ANORM .EQ. 0.D0) GO TO 50
C
      IX = 2*N + MAX + 1
      IV = IX + N
      ISGN = 4*N + MAX + 3
C
      KASE = 0
      AINORM = 0.D0
      CALL DONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE,
     *             ITER, J, JUMP)
      CALL DSLV (0, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX),
     *           IWK(1), WK(1), IERR)
C
C     CHECK IF A IS SINGULAR OR IF THERE ARE ERRORS
C
      IF (IERR .GT. 0) GO TO 20
      IF (IABS(IERR) .LE. N) GO TO 50
      IERR = IERR + N
      IF (IABS(IERR) .LE. N) RETURN
      IERR = IERR + N
      IF (IABS(IERR) .LE. N) GO TO 50
      RETURN
C
C     GENERAL LOOP TO ESTIMATE THE NORM  AINORM
C     OF THE INVERSE OF A
C
   20 CALL DONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE,
     *             ITER, J, JUMP)
      IF (KASE .EQ. 0) GO TO 40
      IF (KASE .NE. 1) GO TO 30
         CALL DSLV (1, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX),
     *              IWK(1), WK(1), IERR)
         GO TO 20
   30 CALL DTSLV (1, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX),
     *            IWK(1), WK(1), IERR)
      GO TO 20
C
C     COMPUTE THE VALUE OF COND
C
   40 COND = ANORM*AINORM
      RETURN
C
C     SINGULAR CASE
C
   50 IERR = 0
      RETURN
      END
      SUBROUTINE SONEST (N, V, X, ISGN, ANORM, KASE, ITER, J, JUMP)
      REAL V(N), X(N)
      INTEGER ISGN(N)
C-----------------------------------------------------------------------
C
C     SONEST ESTIMATES THE 1-NORM OF A SQUARE, REAL MATRIX  A.
C     REVERSE COMMUNICATION IS USED FOR EVALUATING
C     MATRIX-VECTOR PRODUCTS.
C
C     ON ENTRY
C
C        N       THE ORDER OF THE MATRIX.  N .GE. 1.
C
C        KASE    INTEGER  (= 0).
C
C     ON INTERMEDIATE RETURNS
C
C        KASE    = 1 OR 2.
C
C        X       MUST BE OVERWRITTEN BY
C
C                     A*X,             IF KASE = 1,
C                     TRANSPOSE(A)*X,  IF KASE = 2,
C
C                AND SONEST MUST BE RE-CALLED, WITH ALL THE OTHER
C                PARAMETERS UNCHANGED.
C
C        ITER    NUMBER OF THE CURRENT ITERATION.
C
C     ON FINAL RETURN
C
C        KASE    = 0.
C
C        ANORM   CONTAINS AN ESTIMATE (A LOWER BOUND) FOR NORM(A).
C
C        V       = A*W,   WHERE  ANORM = NORM(V)/NORM(W)
C                         (W  IS NOT RETURNED).
C
C        ITER    NUMBER OF INTERATIONS TAKEN.
C
C        WRITTEN BY NICK HIGHAM, UNIVERSITY OF MANCHESTER. MODIFIED
C        BY A.H. MORRIS (NSWC).
C
C     REFERENCE
C     N.J. HIGHAM (1987) FORTRAN CODES FOR ESTIMATING
C     THE 1-NORM OF A REAL OR COMPLEX MATRIX, WITH APPLICATIONS
C     TO CONDITION  ESTIMATION, NUMERICAL ANALYSIS REPORT NO. 135,
C     UNIVERSITY OF MANCHESTER, MANCHESTER M13 9PL, ENGLAND.
C
C-----------------------------------------------------------------------
      DATA ITMAX /5/
C
      IF (KASE .NE. 0) GO TO 20
         T = 1.0/FLOAT(N)
         DO 10 I = 1,N
            X(I) = T
   10    CONTINUE
         ITER = 0
         KASE = 1
         JUMP = 1
         RETURN
   20 GO TO (100, 200, 300, 400, 500), JUMP
C
C     ................ ENTRY   (JUMP = 1)
C     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
C
  100 ITER = 1
      IF (N .GT. 1) GO TO 110
         V(1) = X(1)
         ANORM = ABS(V(1))
         GO TO 510
C
  110 ANORM = SASUM(N,X,1)
      DO 120 I = 1,N
         ISGN(I) = 1
         IF (X(I) .LT. 0.0) ISGN(I) = -1
         X(I) = ISGN(I)
  120 CONTINUE
      KASE = 2
      JUMP = 2
      RETURN
C
C     ................ ENTRY   (JUMP = 2)
C     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
C
  200 ITER = 2
      J = ISAMAX(N,X,1)
C
C     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
C
  210 DO 220 I = 1,N
         X(I) = 0.0
  220 CONTINUE
      X(J) = 1.0
      KASE = 1
      JUMP = 3
      RETURN
C
C     ................ ENTRY   (JUMP = 3)
C     X HAS BEEN OVERWRITTEN BY A*X.
C
  300 CALL SCOPY (N,X,1,V,1)
      ANRM = ANORM
      ANORM = SASUM(N,V,1)
      DO 310 I = 1,N
         L = 1
         IF (X(I) .LT. 0.0) L = -1
         IF (L .NE. ISGN(I)) GO TO 320
  310 CONTINUE
C     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
      GO TO 410
C
C     TEST FOR CYCLING.
C
  320 IF (ANORM .LE. ANRM) GO TO 410
C
      DO 330 I = 1,N
         ISGN(I) = 1
         IF (X(I) .LT. 0.0) ISGN(I) = -1
         X(I) = ISGN(I)
  330 CONTINUE
      KASE = 2
      JUMP = 4
      RETURN
C
C     ................ ENTRY   (JUMP = 4)
C     X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
C
  400 JLAST = J
      J = ISAMAX(N,X,1)
      IF (X(JLAST) .EQ. ABS(X(J)) .OR.
     *    ITER .GE. ITMAX) GO TO 410
      ITER = ITER + 1
      GO TO 210
C
C     ITERATION COMPLETE.  FINAL STAGE.
C
  410 ALTSGN = 1.0
      DO 420 I = 1,N
         X(I) = ALTSGN * (1.0 + FLOAT(I-1)/FLOAT(N-1))
         ALTSGN = -ALTSGN
  420 CONTINUE
      KASE = 1
      JUMP = 5
      RETURN
C
C     ................ ENTRY   (JUMP = 5)
C     X HAS BEEN OVERWRITTEN BY A*X.
C
  500 ANRM = 2.0*SASUM(N,X,1)/FLOAT(3*N)
      IF (ANRM .LE. ANORM) GO TO 510
         CALL SCOPY (N,X,1,V,1)
         ANORM = ANRM
  510 KASE = 0
      RETURN
      END
      SUBROUTINE DONEST (N, V, X, ISGN, ANORM, KASE, ITER, J, JUMP)
      DOUBLE PRECISION ANORM, V(N), X(N)
      INTEGER ISGN(N)
      DOUBLE PRECISION ALTSGN, AN, ANM1, ANRM, T
      DOUBLE PRECISION DASUM
C-----------------------------------------------------------------------
C
C     DONEST ESTIMATES THE 1-NORM OF A SQUARE, REAL MATRIX  A.
C     REVERSE COMMUNICATION IS USED FOR EVALUATING
C     MATRIX-VECTOR PRODUCTS.
C
C     ON ENTRY
C
C        N       THE ORDER OF THE MATRIX.  N .GE. 1.
C
C        KASE    INTEGER  (= 0).
C
C     ON INTERMEDIATE RETURNS
C
C        KASE    = 1 OR 2.
C
C        X       MUST BE OVERWRITTEN BY
C
C                     A*X,             IF KASE = 1,
C                     TRANSPOSE(A)*X,  IF KASE = 2,
C
C                AND DONEST MUST BE RE-CALLED, WITH ALL THE OTHER
C                PARAMETERS UNCHANGED.
C
C        ITER    NUMBER OF THE CURRENT ITERATION.
C
C     ON FINAL RETURN
C
C        KASE    = 0.
C
C        ANORM   CONTAINS AN ESTIMATE (A LOWER BOUND) FOR NORM(A).
C
C        V       = A*W,   WHERE  ANORM = NORM(V)/NORM(W)
C                         (W  IS NOT RETURNED).
C
C        ITER    NUMBER OF INTERATIONS TAKEN.
C
C        WRITTEN BY NICK HIGHAM, UNIVERSITY OF MANCHESTER. MODIFIED
C        BY A.H. MORRIS (NSWC).
C
C     REFERENCE
C     N.J. HIGHAM (1987) FORTRAN CODES FOR ESTIMATING
C     THE 1-NORM OF A REAL OR COMPLEX MATRIX, WITH APPLICATIONS
C     TO CONDITION  ESTIMATION, NUMERICAL ANALYSIS REPORT NO. 135,
C     UNIVERSITY OF MANCHESTER, MANCHESTER M13 9PL, ENGLAND.
C
C-----------------------------------------------------------------------
      DATA ITMAX /5/
C
      AN = N
      ANM1 = N - 1
      IF (KASE .NE. 0) GO TO 20
         T = 1.D0/AN
         DO 10 I = 1,N
            X(I) = T
   10    CONTINUE
         ITER = 0
         KASE = 1
         JUMP = 1
         RETURN
   20 GO TO (100, 200, 300, 400, 500), JUMP
C
C     ................ ENTRY   (JUMP = 1)
C     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
C
  100 ITER = 1
      IF (N .GT. 1) GO TO 110
         V(1) = X(1)
         ANORM = DABS(V(1))
         GO TO 510
C
  110 ANORM = DASUM(N,X,1)
      DO 120 I = 1,N
         ISGN(I) = 1
         IF (X(I) .LT. 0.D0) ISGN(I) = -1
         X(I) = ISGN(I)
  120 CONTINUE
      KASE = 2
      JUMP = 2
      RETURN
C
C     ................ ENTRY   (JUMP = 2)
C     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
C
  200 ITER = 2
      J = IDAMAX(N,X,1)
C
C     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
C
  210 DO 220 I = 1,N
         X(I) = 0.D0
  220 CONTINUE
      X(J) = 1.D0
      KASE = 1
      JUMP = 3
      RETURN
C
C     ................ ENTRY   (JUMP = 3)
C     X HAS BEEN OVERWRITTEN BY A*X.
C
  300 CALL DCOPY (N,X,1,V,1)
      ANRM = ANORM
      ANORM = DASUM(N,V,1)
      DO 310 I = 1,N
         L = 1
         IF (X(I) .LT. 0.D0) L = -1
         IF (L .NE. ISGN(I)) GO TO 320
  310 CONTINUE
C     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
      GO TO 410
C
C     TEST FOR CYCLING.
C
  320 IF (ANORM .LE. ANRM) GO TO 410
C
      DO 330 I = 1,N
         ISGN(I) = 1
         IF (X(I) .LT. 0.D0) ISGN(I) = -1
         X(I) = ISGN(I)
  330 CONTINUE
      KASE = 2
      JUMP = 4
      RETURN
C
C     ................ ENTRY   (JUMP = 4)
C     X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
C
  400 JLAST = J
      J = IDAMAX(N,X,1)
      IF (X(JLAST) .EQ. DABS(X(J)) .OR.
     *    ITER .GE. ITMAX) GO TO 410
      ITER = ITER + 1
      GO TO 210
C
C     ITERATION COMPLETE.  FINAL STAGE.
C
  410 ALTSGN = 1.D0
      DO 420 I = 1,N
         T = I - 1
         X(I) = ALTSGN * (1.D0 + T/ANM1)
         ALTSGN = -ALTSGN
  420 CONTINUE
      KASE = 1
      JUMP = 5
      RETURN
C
C     ................ ENTRY   (JUMP = 5)
C     X HAS BEEN OVERWRITTEN BY A*X.
C
  500 ANRM = 2.D0*DASUM(N,X,1)/(3.D0*AN)
      IF (ANRM .LE. ANORM) GO TO 510
         CALL DCOPY (N,X,1,V,1)
         ANORM = ANRM
  510 KASE = 0
      RETURN
      END
      SUBROUTINE CSPSLV (N,A,IA,JA,B,R,C,MAX,X,ITEMP,RTEMP,IERR)
C-----------------------------------------------------------------------
C                 SOLUTION OF COMPLEX SPARSE MATRICES
C-----------------------------------------------------------------------
C  SPSLV CALLS CNSPIV WHICH USES SPARSE GAUSSIAN ELIMINATION WITH
C  COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B.  THE
C  ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN
C  A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y.  THE SOLUTION
C  PHASE SOLVES U X = Y.
C
C  INPUT ARGUMENTS---
C
C  N      INTEGER NUMBER OF EQUATIONS AND UNKNOWNS
C
C  A      COMPLEX ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING
C         THE ACTUAL NONZEROS.  (SEE STORAGE DESCRIPTION BELOW)
C
C  IA     INTEGER ARRAY OF N+1 ENTRIES CONTAINING ROW POINTERS TO A
C         (SEE MATRIX STORAGE DESCRIPTION BELOW)
C
C  JA     INTEGER ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING
C         COLUMN NUMBERS OF THE NONZEROS OF A.  (SEE MATRIX STORAGE
C         DESCRIPTION BELOW)
C
C  B      COMPLEX ARRAY OF N ENTRIES CONTAINING RIGHT HAND SIDE DATA
C
C  R      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
C         ROWS OF A (I.E., THE ELIMINATION ORDER FOR THE EQUATIONS)
C
C  C      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
C         COLUMNS OF A.  C IS ALSO AN OUTPUT ARGUMENT
C
C  MAX    INTEGER NUMBER SPECIFYING MAXIMUM NUMBER OF OFF-DIAGONAL
C         NONZERO ENTRIES OF U WHICH MAY BE STORED
C
C  ITEMP  INTEGER ARRAY OF 3*N + MAX + 2 ENTRIES, FOR INTERNAL USE
C
C  RTEMP  COMPLEX ARRAY OF N + MAX ENTRIES FOR INTERNAL USE
C
C
C  OUTPUT ARGUMENTS---
C
C  C      INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE
C         COLUMNS OF U.  C IS ALSO AN INPUT ARGUMENT
C
C  X      COMPLEX ARRAY OF N ENTRIES CONTAINING THE SOLUTION VECTOR
C
C  IERR   INTEGER NUMBER WHICH INDICATES ERROR CONDITIONS OR
C         THE ACTUAL NUMBER OF OFF-DIAGONAL ENTRIES IN U (FOR
C         SUCCESSFUL COMPLETION)
C
C         IERR VALUES ARE---
C
C         0 LT IERR             SUCCESSFUL COMPLETION. IERR=MAX(1,M)
C                               WHERE M IS THE NUMBER OF OFF-DIAGONAL
C                               NONZERO ENTRIES OF U.
C
C         IERR = 0              ERROR.  N IS LESS THAN OR EQUAL TO 0
C
C         -N LE IERR LT 0       ERROR.  ROW NUMBER IABS(IERR) OF A IS
C                               IS NULL
C
C         -2*N LE IERR LT -N    ERROR.  ROW NUMBER IABS(IERR+N) HAS A
C                               DUPLICATE ENTRY
C
C         -3*N LE IERR LT -2*N  ERROR.  ROW NUMBER IABS(IERR+2*N)
C                               HAS A ZERO PIVOT
C
C         -4*N LE IERR LT -3*N  ERROR.  ROW NUMBER IABS(IERR+3*N)
C                               EXCEEDS STORAGE
C
C
C  STORAGE OF SPARSE MATRICES---
C
C  THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A.
C  THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT
C  NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER.  THE ARRAY JA
C  CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED
C  IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN
C  COLUMN J, THEN JA(K) = J).  THE ARRAY IA CONTAINS POINTERS TO THE
C  ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E.,
C  A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA).
C  IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZERO
C  ELEMENTS IN A.
C------------------------
      COMPLEX A(*), B(N), X(N), RTEMP(*)
      INTEGER IA(*), JA(*), R(N), C(N), ITEMP(*)
      INTEGER IU, JU, U, Y, P
C
      IERR = 0
      IF (N .LE. 0) RETURN
C
C  SET INDICES TO DIVIDE TEMPORARY STORAGE FOR CNSPIV
C
      Y = 1
      U = Y + N
      P = N + 1
      IU = P + N + 1
      JU = IU + N + 1
C
C  COMPUTE THE INVERSE PERMUTATION OF C
C
      DO 10 K = 1,N
         L = C(K)
         ITEMP(L) = K
   10 CONTINUE
C
C  CALL CNSPIV TO PERFORM COMPUTATIONS
C
      CALL CNSPIV (N,IA,JA,A,B,MAX,R,C,ITEMP(1),X,RTEMP(Y),ITEMP(P),
     *             ITEMP(IU),ITEMP(JU),RTEMP(U),IERR)
      IF (IERR .EQ. 0) IERR = 1
      RETURN
      END
      SUBROUTINE CNSPIV (N,IA,JA,A,B,MAX,R,C,IC,X,Y,P,IU,JU,U,IERR)
C
C
C  CNSPIV USES SPARSE GAUSSIAN ELIMINATION WITH
C  COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B.  THE
C  ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN
C  A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y.  THE SOLUTION
C  PHASE SOLVES U X = Y.
C
C
C  SEE CSPSLV FOR DESCRIPTIONS OF ALL INPUT AND OUTPUT ARGUMENTS
C  OTHER THAN THOSE DESCRIBED BELOW
C
C  IC  INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C
C      (I.E., IC(C(I)) = I). IC IS BOTH AN INPUT AND OUTPUT
C      ARGUMENT.
C
C  INPUT ARGUMENTS (USED INTERNALLY ONLY)---
C
C  Y   COMPLEX ARRAY OF N ENTRIES USED TO COMPUTE THE UPDATED
C      RIGHT HAND SIDE
C
C  P   INTEGER ARRAY OF N+1 ENTRIES USED FOR A LINKED LIST.
C      P(N+1) IS THE LIST HEADER, AND THE ENTRY FOLLOWING
C      P(K) IS IN P(P(K)).  THUS, P(N+1) IS THE FIRST DATA
C      ITEM, P(P(N+1)) IS THE SECOND, ETC.  A POINTER OF
C      N+1 MARKS THE END OF THE LIST
C
C  IU  INTEGER ARRAY OF N+1 ENTRIES USED FOR ROW POINTERS TO U
C      (SEE MATRIX STORAGE DESCRIPTION BELOW)
C
C  JU  INTEGER ARRAY OF MAX ENTRIES USED FOR COLUMN NUMBERS OF
C      THE NONZEROS IN THE STRICT UPPER TRIANGLE OF U.  (SEE
C      MATRIX STORAGE DESCRIPTION BELOW)
C
C  U   COMPLEX ARRAY OF MAX ENTRIES USED FOR THE ACTUAL NONZEROS IN
C      THE STRICT UPPER TRIANGLE OF U.  (SEE MATRIX STORAGE
C      DESCRIPTION BELOW)
C
C
C  STORAGE OF SPARSE MATRICES---
C
C  THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A.
C  THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT
C  NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER.  THE ARRAY JA
C  CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED
C  IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN
C  COLUMN J, THEN JA(K) = J).  THE ARRAY IA CONTAINS POINTERS TO THE
C  ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E.,
C  A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA).
C  IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZEROS IN
C  A.  IU, JU, AND U ARE USED IN A SIMILAR WAY TO STORE THE STRICT UPPER
C  TRIANGLE OF U, EXCEPT THAT JU ACTUALLY CONTAINS C(J) INSTEAD OF J
C
C
      COMPLEX A(*), B(N), U(MAX), X(N), Y(N)
      COMPLEX DK, LKI, ONE, YK, ZERO
      REAL XPV, XPVMAX
      INTEGER C(N), IA(*), IC(N), IU(*), JA(*), JU(MAX), P(*), R(N)
      INTEGER CK, PK, PPK, PV, V, VI, VJ, VK
C
      ONE = (1.0,0.0)
      ZERO = (0.0,0.0)
C
C  INITIALIZE WORK STORAGE AND POINTERS TO JU
C
      DO 10 J = 1,N
        X(J) = ZERO
 10   CONTINUE
      IU(1) = 1
      JUPTR = 0
C
C  PERFORM SYMBOLIC AND NUMERIC FACTORIZATION ROW BY ROW
C  VK (VI,VJ) IS THE GRAPH VERTEX FOR ROW K (I,J) OF U
C
      DO 170 K = 1,N
C
C  INITIALIZE LINKED LIST AND FREE STORAGE FOR THIS ROW
C  THE R(K)-TH ROW OF A BECOMES THE K-TH ROW OF U.
C
        P(N+1) = N+1
        VK = R(K)
C
C  SET UP ADJACENCY LIST FOR VK, ORDERED IN
C  CURRENT COLUMN ORDER OF U.  THE LOOP INDEX
C  GOES DOWNWARD TO EXPLOIT ANY COLUMNS
C  FROM A IN CORRECT RELATIVE ORDER
C
        JMIN = IA(VK)
        JMAX = IA(VK+1) - 1
        IF (JMIN .GT. JMAX)  GO TO 1002
        J = JMAX
 20       JAJ = JA(J)
          VJ = IC(JAJ)
C
C  STORE A(K,J) IN WORK VECTOR
C
          X(VJ) = A(J)
C  THIS CODE INSERTS VJ INTO ADJACENCY LIST OF VK
          PPK = N+1
 30       PK = PPK
          PPK = P(PK)
          IF (PPK - VJ)  30,1003,40
 40       P(VJ) = PPK
          P(PK) = VJ
          J = J - 1
          IF (J .GE. JMIN) GO TO 20
C
C  THE FOLLOWING CODE COMPUTES THE K-TH ROW OF U
C
        VI = N+1
        YK = B(VK)
 50     VI = P(VI)
        IF (VI .GE. K) GO TO 110
C
C  VI LT VK -- PROCESS THE L(K,I) ELEMENT AND MERGE THE
C  ADJACENCY OF VI WITH THE ORDERED ADJACENCY OF VK
C
        LKI = - X(VI)
        X(VI) = ZERO
C
C  ADJUST RIGHT HAND SIDE TO REFLECT ELIMINATION
C
        YK = YK + LKI * Y(VI)
        PPK = VI
        JMIN = IU(VI)
        JMAX = IU(VI+1) - 1
        IF (JMIN .GT. JMAX)  GO TO 50
        DO 100 J = JMIN,JMAX
          JUJ = JU(J)
          VJ = IC(JUJ)
C
C  IF VJ IS ALREADY IN THE ADJACENCY OF VK,
C  SKIP THE INSERTION
C
          IF (X(VJ) .NE. ZERO)  GO TO 90
C
C  INSERT VJ IN ADJACENCY LIST OF VK.
C  RESET PPK TO VI IF WE HAVE PASSED THE CORRECT
C  INSERTION SPOT.  (THIS HAPPENS WHEN THE ADJACENCY OF
C  VI IS NOT IN CURRENT COLUMN ORDER DUE TO PIVOTING.)
C
          IF (VJ - PPK) 60,90,70
 60       PPK = VI
 70       PK = PPK
          PPK = P(PK)
          IF (PPK - VJ)  70,90,80
 80       P(VJ) = PPK
          P(PK) = VJ
          PPK = VJ
C
C  COMPUTE L(K,J) = L(K,J) - L(K,I)*U(I,J) FOR L(K,I) NONZERO
C  COMPUTE U*(K,J) = U*(K,J) - L(K,I)*U(I,J) FOR U(K,J) NONZERO
C  (U*(K,J) = U(K,J)*D(K,K))
C
 90       X(VJ) = X(VJ) + LKI * U(J)
 100    CONTINUE
        GO TO 50
C
C  PIVOT--INTERCHANGE LARGEST ENTRY OF K-TH ROW OF U WITH
C  THE DIAGONAL ENTRY.
C
C  FIND LARGEST ENTRY, COUNTING OFF-DIAGONAL NONZEROS
C
 110    IF (VI .GT. N) GO TO 1004
        XPVMAX = ABS(REAL(X(VI))) + ABS(AIMAG(X(VI)))
        MAXC = VI
        NZCNT = 0
        PV = VI
 120      V = PV
          PV = P(PV)
          IF (PV .GT. N) GO TO 130
          NZCNT = NZCNT + 1
          XPV = ABS(REAL(X(PV))) + ABS(AIMAG(X(PV)))
          IF (XPV .LE. XPVMAX) GO TO 120
          XPVMAX = XPV
          MAXC = PV
          MAXCL = V
          GO TO 120
 130    IF (XPVMAX .EQ. 0.0) GO TO 1004
C
C  IF VI = K, THEN THERE IS AN ENTRY FOR DIAGONAL
C  WHICH MUST BE DELETED.  OTHERWISE, DELETE THE
C  ENTRY WHICH WILL BECOME THE DIAGONAL ENTRY
C
        IF (VI .EQ. K) GO TO 140
        IF (VI .EQ. MAXC) GO TO 140
        P(MAXCL) = P(MAXC)
        GO TO 150
 140    VI = P(VI)
C
C  COMPUTE D(K) = 1/L(K,K) AND PERFORM INTERCHANGE.
C
 150    DK = ONE / X(MAXC)
        X(MAXC) = X(K)
        I = C(K)
        C(K) = C(MAXC)
        C(MAXC) = I
        CK = C(K)
        IC(CK) = K
        IC(I) = MAXC
        X(K) = ZERO
C
C  UPDATE RIGHT HAND SIDE.
C
        Y(K) = YK * DK
C
C  COMPUTE VALUE FOR IU(K+1) AND CHECK FOR STORAGE OVERFLOW
C
        IU(K+1) = IU(K) + NZCNT
        IF (IU(K+1) .GT. MAX+1) GO TO 1005
C
C  MOVE COLUMN INDICES FROM LINKED LIST TO JU.
C  COLUMNS ARE STORED IN CURRENT ORDER WITH ORIGINAL
C  COLUMN NUMBER (C(J)) STORED FOR CURRENT COLUMN J
C
        IF (VI .GT. N)  GO TO 170
        J = VI
 160      JUPTR = JUPTR + 1
          JU(JUPTR) = C(J)
          U(JUPTR) = X(J) * DK
          X(J) = ZERO
          J = P(J)
          IF (J .LE. N) GO TO 160
 170    CONTINUE
C
C  BACKSOLVE U X = Y, AND REORDER X TO CORRESPOND WITH A
C
      K = N
      DO 200 I = 1,N
        YK = Y(K)
        JMIN = IU(K)
        JMAX = IU(K+1) - 1
        IF (JMIN .GT. JMAX)  GO TO 190
        DO 180 J = JMIN,JMAX
          JUJ = JU(J)
          JUJ = IC(JUJ)
          YK = YK - U(J) * Y(JUJ)
 180    CONTINUE
 190    Y(K) = YK
        CK = C(K)
        X(CK) = YK
        K = K - 1
 200  CONTINUE
C
C  RETURN WITH IERR = NUMBER OF OFF-DIAGONAL NONZEROS IN U
C
      IERR = IU(N+1) - IU(1)
      RETURN
C
C  ERROR RETURNS
C
C  ROW K OF A IS NULL
C
 1002 IERR = -K
      RETURN
C
C  ROW K OF A HAS A DUPLICATE ENTRY
C
 1003 IERR = -(N+K)
      RETURN
C
C  ZERO PIVOT IN ROW K
C
 1004 IERR = -(2*N+K)
      RETURN
C
C  STORAGE FOR U EXCEEDED ON ROW K
C
 1005 IERR = -(3*N+K)
      RETURN
      END
      SUBROUTINE CSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR)
C-----------------------------------------------------------------------
C                 SOLUTION OF COMPLEX SPARSE MATRICES
C-----------------------------------------------------------------------
C     CSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO
C     SOLVE THE NXN COMPLEX SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES
C     IF CSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO-
C     SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR
C     MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS
C     (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION
C     OBTAINED ON THE INITIAL CALL TO CSLV.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     N        NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     A,IA,JA  THE COMPLEX MATRIX A STORED IN SPARSE FORM.
C
C     B        COMPLEX ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND
C              SIDE DATA.
C
C     R        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE ROWS OF A.
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED
C              ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT.
C
C     MAX      INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL
C              NONZERO ENTRIES OF L AND U WHICH MAY BE STORED.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE COLUMNS THAT WAS SELECTED BY THE ROUTINE.
C
C     X        COMPLEX ARRAY OF N ENTRIES CONTAINING THE SOLUTION.
C              B AND X MAY SHARE THE SAME STORAGE AREA.
C
C     IERR     INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE
C              SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M)
C              WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO
C              ENTRIES OF L AND U. OTHERWISE IERR.LE.0.
C
C
C     GENERAL STORAGE AREAS ---
C
C     IWK      INTEGER ARRAY OF DIMENSION 4*N + MAX + 2.
C
C     WK       COMPLEX ARRAY OF DIMENSION 2*N + MAX.
C
C
C     AFTER AN INITIAL CALL TO CSLV, THE ROUTINE MAY BE RECALLED WITH
C     M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA,
C     R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU
C     DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO CSLV
C     AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE A,IA,JA,MAX,
C     AND IERR ARE NOT REFERENCED.
C-----------------------------------------------------------------------
      COMPLEX A(*), B(N), X(N), WK(*)
      INTEGER IA(*), JA(*), IWK(*)
      INTEGER R(N), C(N), Y, T, P
C
C     SET INDICES TO DIVIDE TEMPORARY STORAGE
C
      Y = N + 1
      T = Y + N
      P = N + 1
      IT = P + N + 1
      IU = IT + N + 1
      JT = IU + N
      IF (M0 .NE. 0) GO TO 20
C
C     COMPUTE THE INVERSE PERMUTATION OF C
C
      IERR = 0
      IF (N .LE. 0) RETURN
      DO 10 K = 1,N
         L = C(K)
         IWK(L) = K
   10 CONTINUE
C
C     OBTAIN THE LU DECOMPOSITION OF A
C
      CALL CSPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT),
     *             IWK(IU),WK(Y),IWK(P),IERR)
      IF (IERR .LT. 0) RETURN
      IERR = MAX0(1,IERR)
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   20 CALL CSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU),
     *                  B,X,WK(Y))
      RETURN
      END
      SUBROUTINE CSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y)
      INTEGER R(N), C(N), IC(N)
      INTEGER IT(*), JT(*), IU(N)
      COMPLEX B(N), D(N), T(*), X(N), Y(N), SUM
C
C            SOLVE LY = B BY FORWARD SUBSTITUTION
C
      DO 11 K = 1,N
         LK = R(K)
         SUM = B(LK)
         JMIN = IT(K)
         JMAX = IU(K) - 1
         IF (JMIN .GT. JMAX) GO TO 11
         DO 10 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            SUM = SUM - T(JJ)*Y(J)
   10    CONTINUE
   11 Y(K) = SUM/D(K)
C
C            SOLVE UX = B BY BACKWARD SUBSTITUTION
C             AND REORDER X TO CORRESPOND WITH A
C
      K = N
      DO 22 I = 1,N
         SUM = Y(K)
         JMIN = IU(K)
         JMAX = IT(K+1) - 1
         IF (JMIN .GT. JMAX) GO TO 21
         DO 20 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            SUM = SUM - T(JJ)*Y(J)
   20    CONTINUE
   21    Y(K) = SUM
         LK = C(K)
         X(LK) = Y(K)
         K = K - 1
   22 CONTINUE
      RETURN
      END
      SUBROUTINE CTSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR)
C-----------------------------------------------------------------------
C                 SOLUTION OF COMPLEX SPARSE MATRICES
C-----------------------------------------------------------------------
C     CTSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO
C     SOLVE THE NXN COMPLEX SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES
C     IF CTSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING
C     RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED.
C     ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO-
C     SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR
C     MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS
C     (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION
C     OBTAINED ON THE INITIAL CALL TO CTSLV.
C
C
C     INPUT ARGUMENTS WHEN M0=0 ---
C
C     N        NUMBER OF EQUATIONS AND UNKNOWNS.
C
C     A,IA,JA  THE COMPLEX MATRIX A STORED IN SPARSE FORM.
C
C     B        COMPLEX ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND
C              SIDE DATA.
C
C     R        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE ROWS OF A.
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED
C              ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT.
C
C     MAX      INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL
C              NONZERO ENTRIES OF L AND U WHICH MAY BE STORED.
C
C
C     OUTPUT ARGUMENTS WHEN M0=0 ---
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE COLUMNS THAT WAS SELECTED BY THE ROUTINE.
C
C     X        COMPLEX ARRAY OF N ENTRIES CONTAINING THE SOLUTION.
C              B AND X MAY SHARE THE SAME STORAGE AREA.
C
C     IERR     INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE
C              SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M)
C              WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO
C              ENTRIES OF L AND U. OTHERWISE IERR.LE.0.
C
C
C     GENERAL STORAGE AREAS ---
C
C     IWK      INTEGER ARRAY OF DIMENSION 4*N + MAX + 2.
C
C     WK       COMPLEX ARRAY OF DIMENSION 2*N + MAX.
C
C
C     AFTER AN INITIAL CALL TO CTSLV, THE ROUTINE MAY BE RECALLED WITH
C     M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA,
C     R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU
C     DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO CTSLV
C     AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE A,IA,JA,MAX,
C     AND IERR ARE NOT REFERENCED.
C-----------------------------------------------------------------------
      COMPLEX A(*), B(N), X(N), WK(*)
      INTEGER IA(*), JA(*), IWK(*)
      INTEGER R(N), C(N), Y, T, P
C
C     SET INDICES TO DIVIDE TEMPORARY STORAGE
C
      Y = N + 1
      T = Y + N
      P = N + 1
      IT = P + N + 1
      IU = IT + N + 1
      JT = IU + N
      IF (M0 .NE. 0) GO TO 20
C
C     COMPUTE THE INVERSE PERMUTATION OF C
C
      IERR = 0
      IF (N .LE. 0) RETURN
      DO 10 K = 1,N
         L = C(K)
         IWK(L) = K
   10 CONTINUE
C
C     OBTAIN THE LU DECOMPOSITION OF A
C
      CALL CSPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT),
     *             IWK(IU),WK(Y),IWK(P),IERR)
      IF (IERR .LT. 0) RETURN
      IERR = MAX0(1,IERR)
C
C     SOLVE THE SYSTEM OF EQUATIONS
C
   20 CALL CTSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU),
     *                 B,X,WK(Y))
      RETURN
      END
      SUBROUTINE CTSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y)
      INTEGER R(N), C(N), IC(N)
      INTEGER IT(*), JT(*), IU(N)
      COMPLEX B(N), D(N), T(*), X(N), Y(N)
C
C            SOLVE YU = B BY FORWARD SUBSTITUTION
C
      DO 10 K = 1,N
         LK = C(K)
         Y(K) = B(LK)
   10 CONTINUE
C
      DO 21 K = 1,N
         IF (Y(K) .EQ. (0.0, 0.0)) GO TO 21
         JMIN = IU(K)
         JMAX = IT(K+1) - 1
         IF (JMIN .GT. JMAX) GO TO 21
         DO 20 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            Y(J) = Y(J) - T(JJ)*Y(K)
   20    CONTINUE
   21 CONTINUE
C
C            SOLVE XL = Y BY BACKWARD SUBSTITUTION
C
      X(N) = Y(N)/D(N)
      IF (N .EQ. 1) RETURN
C
      K = N
      Y(N) = X(N)
      DO 32 I = 2,N
         JMIN = IT(K)
         JMAX = IU(K) - 1
         IF (JMIN .GT. JMAX) GO TO 31
         DO 30 JJ = JMIN,JMAX
            LJ = JT(JJ)
            J = IC(LJ)
            Y(J) = Y(J) - T(JJ)*Y(K)
   30    CONTINUE
   31    K = K - 1
         Y(K) = Y(K)/D(K)
   32 CONTINUE
C
      DO 40 K = 1,N
         LK = R(K)
         X(LK) = Y(K)
   40 CONTINUE
      RETURN
      END
      SUBROUTINE CSPLU (A,IA,JA,R,C,IC,N,MAX,D,T,IT,JT,IU,W,P,IERR)
C-----------------------------------------------------------------------
C     CSPLU EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES
C     TO PERFORM THE LU DECOMPOSITION OF A COMPLEX SPARSE MATRIX.
C     U IS A UNIT UPPER TRIANGULAR MATRIX.
C
C
C     INPUT ARGUMENTS ---
C
C     A,IA,JA  THE COMPLEX SPARSE MATRIX TO BE DECOMPOSED.
C
C     R        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE ROWS OF A.
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED
C              ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT.
C
C     IC       INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C
C              (I.E., IC(C(I)) = I). IC IS ALSO AN OUTPUT ARGUMENT.
C
C     N        ORDER OF THE MATRIX A.
C
C     MAX      INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL
C              NONZERO ENTRIES OF L AND U WHICH MAY BE STORED.
C
C
C     OUTPUT ARGUMENTS ---
C
C     C        INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF
C              THE COLUMNS THAT WAS SELECTED BY THE ROUTINE.
C
C     IC       INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C.
C
C     D        COMPLEX ARRAY CONTAINING THE N DIAGONAL ELEMENTS OF L.
C
C     T,IT,IU  T CONTAINS THE OFF-DIAGONAL NONZERO ELEMENTS OF L AND
C              U. FOR I = 1,...,N THE OFF-DIAGONAL NONZERO ELEMENTS
C              OF THE I-TH ROW OF L ARE STORED IN LOCATIONS
C              IT(I),...,IU(I)-1 OF T, AND THE OFF-DIAGONAL NONZERO
C              ELEMENTS OF THE I-TH ROW OF U ARE STORED IN LOCATIONS
C              IU(I),...,IT(I+1)-1 OF T. T IS A COMPLEX ARRAY.
C
C     JT       INTEGER ARRAY CONTAINING THE COLUMN INDICES (ACCORDING
C              TO THE ORGINAL COLUMN ORDERING) OF THE ELEMENTS OF T
C              (I.E., FOR EACH L(I,J) AND U(I,J) IN T, C(J) IS THE
C              CORRESPONDING COLUMN INDEX IN JT).
C
C     IERR     INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE
C              LU DECOMPOSITION IS OBTAINED THEN IERR = THE NUMBER
C              OF OFF-DIAGONAL ENTRIES OF L AND U WHICH WERE STORED
C              IN T. OTHERWISE IERR IS ASSIGNED A NEGATIVE VALUE.
C
C
C     WORK SPACES ---
C
C     W        COMPLEX ARRAY OF DIMENSION N.
C
C     P        INTEGER ARRAY OF DIMENSION N+1.
C-----------------------------------------------------------------------
      COMPLEX A(*), D(N), T(MAX), W(N)
      INTEGER IA(*), JA(*)
      INTEGER R(N), C(N), IC(N)
      INTEGER IT(*), JT(MAX), IU(N)
      INTEGER P(*), PM
      COMPLEX CONST, ZERO
      REAL    WI, WMAX
C--------------------
      DATA ZERO /(0.0, 0.0)/
C--------------------
      JPTR = 0
      IT(1) = 1
      DO 10 J = 1,N
         W(J) = ZERO
   10 CONTINUE
C
C     PERFORM THE LU FACTORIZATION OF THE R(K)-TH ROW OF A
C
      DO 100 K = 1,N
      LK = R(K)
      JMIN = IA(LK)
      JMAX = IA(LK+1) - 1
      IF (JMIN .GT. JMAX) GO TO 200
C
C     SET P TO THE REORDERED ROW OF A
C
      P(N+1) = N + 1
      JJ = JMAX
   20 LJ = JA(JJ)
      J = IC(LJ)
      W(J) = A(JJ)
      PM = N + 1
   21 M = PM
      PM = P(M)
      IF (PM - J) 21,210,22
   22 P(M) = J
      P(J) = PM
      JJ = JJ - 1
      IF (JJ .GE. JMIN) GO TO 20
C
C     PROCESS THE ENTRIES IN THE LOWER TRIANGLE OF A
C
      I = N + 1
   30 I = P(I)
      IF (I .GE. K) GO TO 50
      IF (W(I) .EQ. ZERO) GO TO 30
C
C     L(K,I) IS NONZERO. THEREFORE STORE IT IN L.
C
      JPTR = JPTR + 1
      IF (JPTR .GT. MAX) GO TO 230
      CONST = W(I)
      T(JPTR) = CONST
      JT(JPTR) = C(I)
      W(I) = ZERO
C
C     PERFORM ELIMINATION USING THE I-TH ROW OF U
C
      JMIN = IU(I)
      JMAX = IT(I+1) - 1
      IF (JMIN .GT. JMAX) GO TO 30
      PM = I
      DO 43 JJ = JMIN,JMAX
         LJ = JT(JJ)
         J = IC(LJ)
         IF (W(J) .NE. ZERO) GO TO 43
         IF (J - PM) 40,43,41
   40       PM = I
   41       M = PM
            PM = P(M)
            IF (PM - J) 41,43,42
   42       P(M) = J
            P(J) = PM
            PM = J
   43 W(J) = W(J) - CONST*T(JJ)
      GO TO 30
C
C     SEARCH FOR THE K-TH PIVOT ELEMENT
C
   50 IF (I .GT. N) GO TO 220
      WMAX = ABS(REAL(W(I))) + ABS(AIMAG(W(I)))
      MAXI = I
      PM = I
   51 M = PM
      PM = P(M)
      IF (PM .GT. N) GO TO 60
      WI = ABS(REAL(W(PM))) + ABS(AIMAG(W(PM)))
      IF (WI .LE. WMAX) GO TO 51
         WMAX = WI
         MAXI = PM
         MAXIL = M
         GO TO 51
C
C     STORE THE PIVOT IN D
C
   60 IF (WMAX .EQ. 0.0) GO TO 220
      D(K) = W(MAXI)
C
C     PERFORM THE COLUMN INTERCHANGE
C
      IF (I .EQ. K) GO TO 70
      IF (I .EQ. MAXI) GO TO 70
         P(MAXIL) = P(MAXI)
         GO TO 80
   70 I = P(I)
C
   80 W(MAXI) = W(K)
      W(K) = ZERO
      LK = C(K)
      LL = C(MAXI)
      C(K) = LL
      C(MAXI) = LK
      IC(LK) = MAXI
      IC(LL) = K
C
C     THE REMAINING ELEMENTS OF P FORM THE K-TH ROW OF U
C
      IU(K) = JPTR + 1
   90 IF (I .GT. N) GO TO 100
      IF (W(I) .EQ. ZERO) GO TO 91
         JPTR = JPTR + 1
         IF (JPTR .GT. MAX) GO TO 230
         T(JPTR) = W(I)/D(K)
         JT(JPTR) = C(I)
         W(I) = ZERO
   91 I = P(I)
      GO TO 90
C
C     PREPARE FOR THE NEXT ROW
C
  100 IT(K+1) = JPTR + 1
C
      IERR = JPTR
      RETURN
C
C     -------------------- ERROR RETURN --------------------
C
C     ROW R(K) IS NULL
C
  200 IERR = -K
      RETURN
C
C     ROW R(K) HAS A DUPLICATE ENTRY
C
  210 IERR = -(N + K)
      RETURN
C
C     ZERO PIVOT IN ROW R(K)
C
  220 IERR = -(2*N + K)
      RETURN
C
C     STORAGE FOR L AND U EXCEEDED ON ROW R(K)
C
  230 IERR = -(3*N + K)
      RETURN
      END
      SUBROUTINE EIG (IBAL,A,KA,N,WR,WI,IERR)
C-----------------------------------------------------------------------
C                    EIGENVALUES OF REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), WR(N), WI(N)
C
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL BALANC (KA,N,A,LOW,IGH,WR)
      CALL ELMHS0 (KA,N,LOW,IGH,A,WR)
      CALL HQR (KA,N,LOW,IGH,A,WR,WI,IERR)
      RETURN
      END
      SUBROUTINE EIG1 (IBAL,A,KA,N,WR,WI,IERR)
C-----------------------------------------------------------------------
C                    EIGENVALUES OF REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), WR(N), WI(N)
C
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL BALANC (KA,N,A,LOW,IGH,WR)
      CALL ORTHES (KA,N,LOW,IGH,A,WR)
      CALL HQR (KA,N,LOW,IGH,A,WR,WI,IERR)
      RETURN
      END
      SUBROUTINE EIGV (IBAL,A,KA,N,WR,WI,ZR,ZI,IERR)
C-----------------------------------------------------------------------
C           EIGENVALUES AND EIGENVECTORS OF REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), WR(N), WI(N), ZR(KA,N), ZI(KA,N)
C
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL BALANC (KA,N,A,LOW,IGH,ZI)
      CALL ELMHS0 (KA,N,LOW,IGH,A,WR)
      CALL ELTRN0 (KA,N,LOW,IGH,A,WR,ZR)
      CALL HQR2 (KA,N,LOW,IGH,A,WR,WI,ZR,IERR)
      IF (IERR .NE. 0) RETURN
      IF (IBAL .NE. 0) CALL BALBAK (KA,N,LOW,IGH,ZI,N,ZR)
C
      DO 30 K = 1,N
         IF (WI(K)) 30,10,20
   10    DO 11 J = 1,N
   11       ZI(J,K) = 0.0
         GO TO 30
   20    KP1 = K + 1
         DO 21 J = 1,N
            ZI(J,K) = ZR(J,KP1)
            ZR(J,KP1) = ZR(J,K)
   21       ZI(J,KP1) = -ZI(J,K)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE EIGV1 (IBAL,A,KA,N,WR,WI,ZR,ZI,IERR)
C-----------------------------------------------------------------------
C           EIGENVALUES AND EIGENVECTORS OF REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), WR(N), WI(N), ZR(KA,N), ZI(KA,N)
C
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL BALANC (KA,N,A,LOW,IGH,ZI)
      CALL ORTHES (KA,N,LOW,IGH,A,WR)
      CALL ORTRAN (KA,N,LOW,IGH,A,WR,ZR)
      CALL HQR2 (KA,N,LOW,IGH,A,WR,WI,ZR,IERR)
      IF (IERR .NE. 0) RETURN
      IF (IBAL .NE. 0) CALL BALBAK (KA,N,LOW,IGH,ZI,N,ZR)
C
      DO 30 K = 1,N
         IF (WI(K)) 30,10,20
   10    DO 11 J = 1,N
   11       ZI(J,K) = 0.0
         GO TO 30
   20    KP1 = K + 1
         DO 21 J = 1,N
            ZI(J,K) = ZR(J,KP1)
            ZR(J,KP1) = ZR(J,K)
   21       ZI(J,KP1) = -ZI(J,K)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE)
C
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
      REAL A(NM,N),SCALE(N)
      REAL C,F,G,R,S,B2,RADIX
      INTEGER IPMPAR
C     REAL ABS
      LOGICAL NOCONV
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES
C     EIGENVALUES WHENEVER POSSIBLE.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        A CONTAINS THE INPUT MATRIX TO BE BALANCED.
C
C     ON OUTPUT-
C
C        A CONTAINS THE BALANCED MATRIX,
C
C        LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J)
C          IS EQUAL TO ZERO IF
C           (1) I IS GREATER THAN J AND
C           (2) J=1,...,LOW-1 OR I=IGH+1,...,N,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE
C           PERMUTATIONS AND SCALING FACTORS USED.
C
C     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
C     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
C     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
C     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
C        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
C                 = D(J,J),      J = LOW,...,IGH
C                 = P(J)         J = IGH+1,...,N.
C     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
C     THEN 1 TO LOW-1.
C
C     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
C
C     THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN
C     BALANC  IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
C     K,L HAVE BEEN REVERSED.)
C
C-----------------------------------------------------------------------
C
C     ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION.
C
                 RADIX = IPMPAR(4)
C
C                **********
C
      B2 = RADIX * RADIX
      K = 1
      L = N
      GO TO 100
C     ********** IN-LINE PROCEDURE FOR ROW AND
C                COLUMN EXCHANGE **********
   20 SCALE(M) = J
      IF (J .EQ. M) GO TO 50
C
      DO 30 I = 1, L
         F = A(I,J)
         A(I,J) = A(I,M)
         A(I,M) = F
   30 CONTINUE
C
      DO 40 I = K, N
         F = A(J,I)
         A(J,I) = A(M,I)
         A(M,I) = F
   40 CONTINUE
C
   50 GO TO (80,130), IEXC
C     ********** SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C                AND PUSH THEM DOWN **********
   80 IF (L .EQ. 1) GO TO 280
      L = L - 1
C     ********** FOR J=L STEP -1 UNTIL 1 DO -- **********
  100 DO 120 JJ = 1, L
         J = L + 1 - JJ
C
         DO 110 I = 1, L
            IF (I .EQ. J) GO TO 110
            IF (A(J,I) .NE. 0.0) GO TO 120
  110    CONTINUE
C
         M = L
         IEXC = 1
         GO TO 20
  120 CONTINUE
C
      GO TO 140
C     ********** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C                AND PUSH THEM LEFT **********
  130 K = K + 1
C
  140 DO 170 J = K, L
C
         DO 150 I = K, L
            IF (I .EQ. J) GO TO 150
            IF (A(I,J) .NE. 0.0) GO TO 170
  150    CONTINUE
C
         M = K
         IEXC = 2
         GO TO 20
  170 CONTINUE
C     ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L **********
      DO 180 I = K, L
  180 SCALE(I) = 1.0
C     ********** ITERATIVE LOOP FOR NORM REDUCTION **********
  190 NOCONV = .FALSE.
C
      DO 270 I = K, L
         C = 0.0
         R = 0.0
C
         DO 200 J = K, L
            IF (J .EQ. I) GO TO 200
            C = C + ABS(A(J,I))
            R = R + ABS(A(I,J))
  200    CONTINUE
C     ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW **********
         IF (C .EQ. 0.0 .OR. R .EQ. 0.0) GO TO 270
         G = R / RADIX
         F = 1.0
         S = C + R
  210    IF (C .GE. G) GO TO 220
         F = F * RADIX
         C = C * B2
         GO TO 210
  220    G = R * RADIX
  230    IF (C .LT. G) GO TO 240
         F = F / RADIX
         C = C / B2
         GO TO 230
C     ********** NOW BALANCE **********
  240    IF ((C + R) / F .GE. 0.95 * S) GO TO 270
         G = 1.0 / F
         SCALE(I) = SCALE(I) * F
         NOCONV = .TRUE.
C
         DO 250 J = K, N
  250    A(I,J) = A(I,J) * G
C
         DO 260 J = 1, L
  260    A(J,I) = A(J,I) * F
C
  270 CONTINUE
C
      IF (NOCONV) GO TO 190
C
  280 LOW = K
      IGH = L
      RETURN
      END
      SUBROUTINE BALINV (NZ,N,Z,LOW,IGH,SCALE)
      INTEGER I,J,K,N,II,NZ,IGH,LOW
      REAL Z(NZ,N),SCALE(N)
      REAL S
C-----------------------------------------------------------------------
C        GIVEN A MATRIX A OF ORDER N. BALANC TRANSFORMS A INTO
C     THE MATRIX B BY THE SIMILARITY TRANSFORMATION
C             B = D**(-1)*TRANSPOSE(P)*A*P*D
C     WHERE D IS A DIAGONAL MATRIX AND P A PERMUTATION MATRIX.
C     THE INFORMATION CONCERNING D AND P IS STORED IN IGH, LOW,
C     AND SCALE. THE ORDER IN WHICH THE INTERCHANGES WERE MADE
C     IS N TO IGH + 1, AND THEN 1 TO LOW - 1.
C
C        Z IS A MATRIX OF ORDER N. BALINV TRANSFORMS Z INTO THE
C     MATRIX W USING THE INVERSE SIMILARITY TRANSFORM
C             W = P*D*Z*D**(-1)*TRANSPOSE(P)
C
C     ON INPUT-
C
C        NZ IS THE ROW DIMENSION OF THE MATRIX Z IN THE CALLING
C          PROGRAM,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY  BALANC,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
C          AND SCALING FACTORS USED BY  BALANC,
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMED MATRIX W
C
C-----------------------------------------------------------------------
C
      IF (IGH .EQ. LOW) GO TO 30
C
      DO 11 I = LOW, IGH
      S = SCALE(I)
         DO 10 J = 1, N
   10    Z(I,J) = Z(I,J) * S
   11 CONTINUE
C
      DO 21 J = LOW, IGH
      S = 1.0/SCALE(J)
         DO 20 I = 1, N
   20    Z(I,J) = Z(I,J) * S
   21 CONTINUE
C
C     ********- FOR I=LOW-1 STEP -1 UNTIL 1,
C               IGH+1 STEP 1 UNTIL N DO -- **********
C
   30 DO 60 II = 1, N
         I = II
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 60
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GO TO 60
C
         DO 40 J = 1, N
            S = Z(I,J)
            Z(I,J) = Z(K,J)
   40       Z(K,J) = S
C
         DO 50 J = 1, N
            S = Z(J,I)
            Z(J,I) = Z(J,K)
   50       Z(J,K) = S
   60 CONTINUE
      RETURN
      END
      SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT)
C
      INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
      REAL A(NM,N)
      REAL X,Y
C     REAL ABS
      INTEGER INT(IGH)
C-----------------------------------------------------------------------
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 TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        A CONTAINS THE INPUT MATRIX.
C
C     ON OUTPUT-
C
C        A CONTAINS THE HESSENBERG MATRIX.  THE MULTIPLIERS
C          WHICH WERE USED IN THE REDUCTION ARE STORED IN THE
C          REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX,
C
C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
C          INTERCHANGED IN THE REDUCTION.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C-----------------------------------------------------------------------
C
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         MM1 = M - 1
         X = 0.0
         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.0) GO TO 180
         MP1 = M + 1
C
         DO 160 I = MP1, IGH
            Y = A(I,MM1)
            IF (Y .EQ. 0.0) 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
      SUBROUTINE ELMHS0(NM,N,LOW,IGH,A,INT)
C
      INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
      REAL A(NM,N)
      REAL X,Y
C     REAL ABS
      REAL INT(IGH)
C-----------------------------------------------------------------------
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 TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        A CONTAINS THE INPUT MATRIX.
C
C     ON OUTPUT-
C
C        A CONTAINS THE HESSENBERG MATRIX.  THE MULTIPLIERS
C          WHICH WERE USED IN THE REDUCTION ARE STORED IN THE
C          REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX,
C
C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
C          INTERCHANGED IN THE REDUCTION.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C-----------------------------------------------------------------------
C
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         MM1 = M - 1
         X = 0.0
         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.0) GO TO 180
         MP1 = M + 1
C
         DO 160 I = MP1, IGH
            Y = A(I,MM1)
            IF (Y .EQ. 0.0) 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
      SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT)
C
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      REAL A(NM,N),ORT(IGH)
      REAL F,G,H,SCALE
C     REAL SQRT,ABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
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     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        A CONTAINS THE INPUT MATRIX.
C
C     ON OUTPUT-
C
C        A CONTAINS THE HESSENBERG MATRIX.  INFORMATION ABOUT
C          THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
C          IS STORED IN THE REMAINING TRIANGLE UNDER THE
C          HESSENBERG MATRIX,
C
C        ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C-----------------------------------------------------------------------
C
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         H = 0.0
         ORT(M) = 0.0
         SCALE = 0.0
C     ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) **********
         DO 90 I = M, IGH
   90    SCALE = SCALE + ABS(A(I,M-1))
C
         IF (SCALE .EQ. 0.0) GO TO 180
         MP = M + IGH
C     ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
         DO 100 II = M, IGH
            I = MP - II
            ORT(I) = A(I,M-1) / SCALE
            H = H + ORT(I) * ORT(I)
  100    CONTINUE
C
         G = SQRT(H)
         IF (ORT(M) .GE. 0.0) G = -G
         H = H - ORT(M) * G
         ORT(M) = ORT(M) - G
C     ********** FORM (I-(U*UT)/H) * A **********
         DO 130 J = M, N
            F = 0.0
C     ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
            DO 110 II = M, IGH
               I = MP - II
               F = F + ORT(I) * A(I,J)
  110       CONTINUE
C
            F = F / H
C
            DO 120 I = M, IGH
  120       A(I,J) = A(I,J) - F * ORT(I)
C
  130    CONTINUE
C     ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) **********
         DO 160 I = 1, IGH
            F = 0.0
C     ********** FOR J=IGH STEP -1 UNTIL M DO -- **********
            DO 140 JJ = M, IGH
               J = MP - JJ
               F = F + ORT(J) * A(I,J)
  140       CONTINUE
C
            F = F / H
C
            DO 150 J = M, IGH
  150       A(I,J) = A(I,J) - F * ORT(J)
C
  160    CONTINUE
C
         ORT(M) = SCALE * ORT(M)
         A(M,M-1) = SCALE * G
  180 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR)
C
      INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITS,LOW,MP2,ENM2,IERR
      REAL H(NM,N),WR(N),WI(N)
      REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,MACHEP,SPMPAR
C     REAL SQRT,ABS
C     INTEGER MIN0
      LOGICAL NOTLAS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR,
C     NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL
C     UPPER HESSENBERG MATRIX BY THE QR METHOD.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        H CONTAINS THE UPPER HESSENBERG MATRIX.  INFORMATION ABOUT
C          THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG
C          FORM BY  ELMHES  OR  ORTHES, IF PERFORMED, IS STORED
C          IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX.
C
C     ON OUTPUT-
C
C        H HAS BEEN DESTROYED.  THEREFORE, IT MUST BE SAVED
C          BEFORE CALLING  HQR  IF SUBSEQUENT CALCULATION AND
C          BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  THE EIGENVALUES
C          ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C          OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C          HAVING THE POSITIVE IMAGINARY PART FIRST.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 .
C
                 MACHEP = SPMPAR(1)
C
C                **********
C
      IERR = 0
      NORM = 0.0
      K = 1
C     ********** STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM **********
      DO 50 I = 1, N
C
         DO 40 J = K, N
   40    NORM = NORM + ABS(H(I,J))
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.0
   50 CONTINUE
C
      EN = IGH
      T = 0.0
C     ********** SEARCH FOR NEXT EIGENVALUES **********
   60 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = ABS(H(L-1,L-1)) + ABS(H(L,L))
         IF (S .EQ. 0.0) S = NORM
         IF (ABS(H(L,L-1)) .LE. MACHEP * S) GO TO 100
   80 CONTINUE
C     ********** FORM SHIFT **********
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITS .EQ. 30) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C     ********** FORM EXCEPTIONAL SHIFT **********
      T = T + X
C
      DO 120 I = LOW, EN
  120 H(I,I) = H(I,I) - X
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = 0.75 * S
      Y = X
      W = -0.4375 * S * S
  130 ITS = ITS + 1
C     ********** LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- **********
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         IF (ABS(H(M,M-1)) * (ABS(Q) + ABS(R)) .LE. MACHEP * ABS(P)
     X    * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.0
  160 CONTINUE
C     ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN **********
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.0
         IF (NOTLAS) R = H(K+2,K-1)
         X = ABS(P) + ABS(Q) + ABS(R)
         IF (X .EQ. 0.0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = SQRT(P*P + Q*Q + R*R)
         IF (P .LT. 0.0) S = -S
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     ********** ROW MODIFICATION **********
         DO 210 J = K, EN
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN0(EN,K+3)
C     ********** COLUMN MODIFICATION **********
         DO 230 I = L, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     ********** ONE ROOT FOUND **********
  270 WR(EN) = X + T
      WI(EN) = 0.0
      EN = NA
      GO TO 60
C     ********** TWO ROOTS FOUND **********
  280 P = (Y - X) / 2.0
      Q = P * P + W
      ZZ = SQRT(ABS(Q))
      X = X + T
      IF (Q .LT. 0.0) GO TO 320
C     ********** REAL PAIR **********
      IF (P .LT. 0.0) ZZ = -ZZ
      ZZ = P + ZZ
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.0) WR(EN) = X - W / ZZ
      WI(NA) = 0.0
      WI(EN) = 0.0
      GO TO 330
C     ********** COMPLEX PAIR **********
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z)
C
      INTEGER I,J,K,M,N,II,NM,IGH,LOW
      REAL SCALE(N),Z(NM,M)
      REAL S
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL
C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C     BALANCED MATRIX DETERMINED BY  BALANC.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY  BALANC,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
C          AND SCALING FACTORS USED BY  BALANC,
C
C        M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED,
C
C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN-
C          VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE
C          TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS.
C
C-----------------------------------------------------------------------
C
      IF (M .EQ. 0) GO TO 200
      IF (IGH .EQ. LOW) GO TO 120
C
      DO 110 I = LOW, IGH
         S = SCALE(I)
C     ********** LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
C                IF THE FOREGOING STATEMENT IS REPLACED BY
C                S=1.0/SCALE(I). **********
         DO 100 J = 1, M
  100    Z(I,J) = Z(I,J) * S
C
  110 CONTINUE
C     ********- FOR I=LOW-1 STEP -1 UNTIL 1,
C               IGH+1 STEP 1 UNTIL N DO -- **********
  120 DO 140 II = 1, N
         I = II
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GO TO 140
C
         DO 130 J = 1, M
            S = Z(I,J)
            Z(I,J) = Z(K,J)
            Z(K,J) = S
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE ELTRAN(NM,N,LOW,IGH,A,INT,Z)
C
      INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
      REAL A(NM,IGH),Z(NM,N)
      INTEGER INT(IGH)
C-----------------------------------------------------------------------
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 TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE
C          REDUCTION BY  ELMHES  IN ITS LOWER TRIANGLE
C          BELOW THE SUBDIAGONAL,
C
C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
C          INTERCHANGED IN THE REDUCTION BY  ELMHES.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  ELMHES.
C
C-----------------------------------------------------------------------
C
C     ********** INITIALIZE Z TO IDENTITY MATRIX **********
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.0
C
         Z(I,I) = 1.0
   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.0
  130    CONTINUE
C
         Z(I,MP) = 1.0
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE ELTRN0(NM,N,LOW,IGH,A,INT,Z)
C
      INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
      REAL A(NM,IGH),Z(NM,N)
      REAL INT(IGH)
C-----------------------------------------------------------------------
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  ELMHS0.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE
C          REDUCTION BY  ELMHS0  IN ITS LOWER TRIANGLE
C          BELOW THE SUBDIAGONAL,
C
C        INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS
C          INTERCHANGED IN THE REDUCTION BY  ELMHS0.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  ELMHS0.
C
C-----------------------------------------------------------------------
C
C     ********** INITIALIZE Z TO IDENTITY MATRIX **********
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.0
C
         Z(I,I) = 1.0
   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.0
  130    CONTINUE
C
         Z(I,MP) = 1.0
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE ORTRAN(NM,N,LOW,IGH,A,ORT,Z)
C
      INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
      REAL A(NM,IGH),ORT(IGH),Z(NM,N)
      REAL G
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS,
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 ORTHOGONAL SIMILARITY
C     TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL
C     MATRIX TO UPPER HESSENBERG FORM BY  ORTHES.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C          FORMATIONS USED IN THE REDUCTION BY  ORTHES
C          IN ITS STRICT LOWER TRIANGLE,
C
C        ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
C          FORMATIONS USED IN THE REDUCTION BY  ORTHES.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  ORTHES,
C
C        ORT HAS BEEN ALTERED.
C
C-----------------------------------------------------------------------
C
C     ********** INITIALIZE Z TO IDENTITY MATRIX **********
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.0
C
         Z(I,I) = 1.0
   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
         IF (A(MP,MP-1) .EQ. 0.0) GO TO 140
         MP1 = MP + 1
C
         DO 100 I = MP1, IGH
  100    ORT(I) = A(I,MP-1)
C
         DO 130 J = MP, IGH
            G = 0.0
C
            DO 110 I = MP, IGH
  110       G = G + ORT(I) * Z(I,J)
C     ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
C                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
            G = (G / ORT(MP)) / A(MP,MP-1)
C
            DO 120 I = MP, IGH
  120       Z(I,J) = Z(I,J) + G * ORT(I)
C
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE ORTRN1(N,LOW,IGH,A,NA,Z,NZ,ORT)
C
      INTEGER I,J,N,KL,MM,MP,NA,IGH,LOW,MP1,NZ
      REAL A(NA,IGH),ORT(IGH),Z(NZ,N)
      REAL G
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS,
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 ORTHOGONAL SIMILARITY
C     TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL
C     MATRIX TO UPPER HESSENBERG FORM BY  ORTHES.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C          FORMATIONS USED IN THE REDUCTION BY  ORTHES
C          IN ITS STRICT LOWER TRIANGLE,
C
C        NA MUST BE SET TO THE ROW DIMENSION OF THE 2-DIMENSIONAL
C          ARRAY PARAMETER  A  AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        NZ MUST BE SET TO THE ROW DIMENSION OF THE 2-DIMENSIONAL
C          ARRAY PARAMETER  Z  AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
C          FORMATIONS USED IN THE REDUCTION BY  ORTHES.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  ORTHES,
C
C        ORT HAS BEEN ALTERED.
C
C-----------------------------------------------------------------------
C
C     ********** INITIALIZE Z TO IDENTITY MATRIX **********
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.0
C
         Z(I,I) = 1.0
   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
         IF (A(MP,MP-1) .EQ. 0.0) GO TO 140
         MP1 = MP + 1
C
         DO 100 I = MP1, IGH
  100    ORT(I) = A(I,MP-1)
C
         DO 130 J = MP, IGH
            G = 0.0
C
            DO 110 I = MP, IGH
  110       G = G + ORT(I) * Z(I,J)
C     ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
C                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
            G = (G / ORT(MP)) / A(MP,MP-1)
C
            DO 120 I = MP, IGH
  120       Z(I,J) = Z(I,J) + G * ORT(I)
C
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN,
     X        IGH,ITS,LOW,MP2,ENM2,IERR
      REAL H(NM,N),WR(N),WI(N),Z(NM,N)
      REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,MACHEP,SPMPAR
C     REAL SQRT,ABS
C     INTEGER MIN0
      LOGICAL NOTLAS
      COMPLEX Z3
C     COMPLEX CMPLX
C     REAL REAL,AIMAG
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2,
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 FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD.  THE
C     EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND
C     IF  ELMHES  AND  ELTRAN  OR  ORTHES  AND  ORTRAN  HAVE
C     BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM
C     AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  BALANC.  IF  BALANC  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        H CONTAINS THE UPPER HESSENBERG MATRIX,
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY  ELTRAN
C          AFTER THE REDUCTION BY  ELMHES, OR BY  ORTRAN  AFTER THE
C          REDUCTION BY  ORTHES, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE
C          IDENTITY MATRIX.
C
C     ON OUTPUT-
C
C        H HAS BEEN DESTROYED,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  THE EIGENVALUES
C          ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C          OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C          HAVING THE POSITIVE IMAGINARY PART FIRST.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N,
C
C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
C          IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z
C          CONTAINS ITS EIGENVECTOR.  IF THE I-TH EIGENVALUE IS COMPLEX
C          WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH
C          COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS
C          EIGENVECTOR.  THE EIGENVECTORS ARE UNNORMALIZED.  IF AN
C          ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     ARITHMETIC IS REAL EXCEPT FOR THE REPLACEMENT OF THE ALGOL
C     PROCEDURE CDIV BY COMPLEX DIVISION.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 .
C
                 MACHEP = SPMPAR(1)
C
C                **********
C
      IERR = 0
      NORM = 0.0
      K = 1
C     ********** STORE ROOTS ISOLATED BY BALANC
C                AND COMPUTE MATRIX NORM **********
      DO 50 I = 1, N
C
         DO 40 J = K, N
   40    NORM = NORM + ABS(H(I,J))
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.0
   50 CONTINUE
C
      EN = IGH
      T = 0.0
C     ********** SEARCH FOR NEXT EIGENVALUES **********
   60 IF (EN .LT. LOW) GO TO 340
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = ABS(H(L-1,L-1)) + ABS(H(L,L))
         IF (S .EQ. 0.0) S = NORM
         IF (ABS(H(L,L-1)) .LE. MACHEP * S) GO TO 100
   80 CONTINUE
C     ********** FORM SHIFT **********
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITS .EQ. 30) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130
C     ********** FORM EXCEPTIONAL SHIFT **********
      T = T + X
C
      DO 120 I = LOW, EN
  120 H(I,I) = H(I,I) - X
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = 0.75 * S
      Y = X
      W = -0.4375 * S * S
  130 ITS = ITS + 1
C     ********** LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- **********
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         IF (ABS(H(M,M-1)) * (ABS(Q) + ABS(R)) .LE. MACHEP * ABS(P)
     X    * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.0
  160 CONTINUE
C     ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN **********
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.0
         IF (NOTLAS) R = H(K+2,K-1)
         X = ABS(P) + ABS(Q) + ABS(R)
         IF (X .EQ. 0.0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = SQRT(P*P + Q*Q + R*R)
         IF (P .LT. 0.0) S = -S
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     ********** ROW MODIFICATION **********
         DO 210 J = K, N
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN0(EN,K+3)
C     ********** COLUMN MODIFICATION **********
         DO 230 I = 1, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C     ********** ACCUMULATE TRANSFORMATIONS **********
         DO 250 I = LOW, IGH
            P = X * Z(I,K) + Y * Z(I,K+1)
            IF (.NOT. NOTLAS) GO TO 240
            P = P + ZZ * Z(I,K+2)
            Z(I,K+2) = Z(I,K+2) - P * R
  240       Z(I,K+1) = Z(I,K+1) - P * Q
            Z(I,K) = Z(I,K) - P
  250    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     ********** ONE ROOT FOUND **********
  270 H(EN,EN) = X + T
      WR(EN) = H(EN,EN)
      WI(EN) = 0.0
      EN = NA
      GO TO 60
C     ********** TWO ROOTS FOUND **********
  280 P = (Y - X) / 2.0
      Q = P * P + W
      ZZ = SQRT(ABS(Q))
      H(EN,EN) = X + T
      X = H(EN,EN)
      H(NA,NA) = Y + T
      IF (Q .LT. 0.0) GO TO 320
C     ********** REAL PAIR **********
      IF (P .LT. 0.0) ZZ = -ZZ
      ZZ = P + ZZ
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.0) WR(EN) = X - W / ZZ
      WI(NA) = 0.0
      WI(EN) = 0.0
      X = H(EN,NA)
      S = ABS(X) + ABS(ZZ)
      P = X / S
      Q = ZZ / S
      R = SQRT(P*P+Q*Q)
      P = P / R
      Q = Q / R
C     ********** ROW MODIFICATION **********
      DO 290 J = NA, N
         ZZ = H(NA,J)
         H(NA,J) = Q * ZZ + P * H(EN,J)
         H(EN,J) = Q * H(EN,J) - P * ZZ
  290 CONTINUE
C     ********** COLUMN MODIFICATION **********
      DO 300 I = 1, EN
         ZZ = H(I,NA)
         H(I,NA) = Q * ZZ + P * H(I,EN)
         H(I,EN) = Q * H(I,EN) - P * ZZ
  300 CONTINUE
C     ********** ACCUMULATE TRANSFORMATIONS **********
      DO 310 I = LOW, IGH
         ZZ = Z(I,NA)
         Z(I,NA) = Q * ZZ + P * Z(I,EN)
         Z(I,EN) = Q * Z(I,EN) - P * ZZ
  310 CONTINUE
C
      GO TO 330
C     ********** COMPLEX PAIR **********
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     ********** ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM **********
  340 IF (NORM .EQ. 0.0) GO TO 1001
C     ********** FOR EN=N STEP -1 UNTIL 1 DO -- **********
      DO 800 NN = 1, N
         EN = N + 1 - NN
         P = WR(EN)
         Q = WI(EN)
         NA = EN - 1
         IF (Q) 710, 600, 800
C     ********** REAL VECTOR **********
  600    M = EN
         H(EN,EN) = 1.0
         IF (NA .EQ. 0) GO TO 800
C     ********** FOR I=EN-1 STEP -1 UNTIL 1 DO -- **********
         DO 700 II = 1, NA
            I = EN - II
            W = H(I,I) - P
            R = H(I,EN)
            IF (M .GT. NA) GO TO 620
C
            DO 610 J = M, NA
  610       R = R + H(I,J) * H(J,EN)
C
  620       IF (WI(I) .GE. 0.0) GO TO 630
            ZZ = W
            S = R
            GO TO 700
  630       M = I
            IF (WI(I) .NE. 0.0) GO TO 640
            T = W
            IF (W .EQ. 0.0) T = MACHEP * NORM
            H(I,EN) = -R / T
            GO TO 700
C     ********** SOLVE REAL EQUATIONS **********
  640       X = H(I,I+1)
            Y = H(I+1,I)
            Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
            T = (X * S - ZZ * R) / Q
            H(I,EN) = T
            IF (ABS(X) .LE. ABS(ZZ)) GO TO 650
            H(I+1,EN) = (-R - W * T) / X
            GO TO 700
  650       H(I+1,EN) = (-S - Y * T) / ZZ
  700    CONTINUE
C     ********** END REAL VECTOR **********
         GO TO 800
C     ********** COMPLEX VECTOR **********
  710    M = NA
C     ********** LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C                EIGENVECTOR MATRIX IS TRIANGULAR **********
         IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720
         H(NA,NA) = Q / H(EN,NA)
         H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
         GO TO 730
  720    Z3 = CMPLX(0.0,-H(NA,EN)) / CMPLX(H(NA,NA)-P,Q)
         H(NA,NA) = REAL(Z3)
         H(NA,EN) = AIMAG(Z3)
  730    H(EN,NA) = 0.0
         H(EN,EN) = 1.0
         ENM2 = NA - 1
         IF (ENM2 .EQ. 0) GO TO 800
C     ********** FOR I=EN-2 STEP -1 UNTIL 1 DO -- **********
         DO 790 II = 1, ENM2
            I = NA - II
            W = H(I,I) - P
            RA = 0.0
            SA = H(I,EN)
C
            DO 760 J = M, NA
               RA = RA + H(I,J) * H(J,NA)
               SA = SA + H(I,J) * H(J,EN)
  760       CONTINUE
C
            IF (WI(I) .GE. 0.0) GO TO 770
            ZZ = W
            R = RA
            S = SA
            GO TO 790
  770       M = I
            IF (WI(I) .NE. 0.0) GO TO 780
            Z3 = CMPLX(-RA,-SA) / CMPLX(W,Q)
            H(I,NA) = REAL(Z3)
            H(I,EN) = AIMAG(Z3)
            GO TO 790
C     ********** SOLVE COMPLEX EQUATIONS **********
  780       X = H(I,I+1)
            Y = H(I+1,I)
            VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
            VI = (WR(I) - P) * 2.0 * Q
            IF (VR .EQ. 0.0 .AND. VI .EQ. 0.0) VR = MACHEP * NORM
     X       * (ABS(W) + ABS(Q) + ABS(X) + ABS(Y) + ABS(ZZ))
            Z3 = CMPLX(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA) / CMPLX(VR,VI)
            H(I,NA) = REAL(Z3)
            H(I,EN) = AIMAG(Z3)
            IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785
            H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
            H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
            GO TO 790
  785       Z3 = CMPLX(-R-Y*H(I,NA),-S-Y*H(I,EN)) / CMPLX(ZZ,Q)
            H(I+1,NA) = REAL(Z3)
            H(I+1,EN) = AIMAG(Z3)
  790    CONTINUE
C     ********** END COMPLEX VECTOR **********
  800 CONTINUE
C     ********** END BACK SUBSTITUTION.
C                VECTORS OF ISOLATED ROOTS **********
      DO 840 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
C
         DO 820 J = I, N
  820    Z(I,J) = H(I,J)
C
  840 CONTINUE
C     ********** MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW DO -- **********
      DO 880 JJ = LOW, N
         J = N + LOW - JJ
         M = MIN0(J,IGH)
C
         DO 880 I = LOW, IGH
            ZZ = 0.0
C
            DO 860 K = LOW, M
  860       ZZ = ZZ + Z(I,K) * H(K,J)
C
            Z(I,J) = ZZ
  880 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE DEIG (IBAL,A,KA,N,WR,WI,IERR)
C-----------------------------------------------------------------------
C                EIGENVALUES OF DOUBLE PRECISION MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), WR(N), WI(N)
C
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL DBAL (KA,N,A,LOW,IGH,WR)
      CALL DORTH (KA,N,LOW,IGH,A,WR)
      CALL DHQR (KA,N,LOW,IGH,A,WR,WI,IERR)
      RETURN
      END
      SUBROUTINE DEIGV (IBAL,A,KA,N,WR,WI,ZR,ZI,IERR)
C-----------------------------------------------------------------------
C     EIGENVALUES AND EIGENVECTORS OF DOUBLE PRECISION MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N),WR(N),WI(N),ZR(KA,N),ZI(KA,N)
C
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL DBAL (KA,N,A,LOW,IGH,ZI)
      CALL DORTH (KA,N,LOW,IGH,A,WR)
      CALL DORTRN (KA,N,LOW,IGH,A,WR,ZR)
      CALL DHQR2 (KA,N,LOW,IGH,A,WR,WI,ZR,IERR)
      IF (IERR .NE. 0) RETURN
      IF (IBAL .NE. 0) CALL DBABK (KA,N,LOW,IGH,ZI,N,ZR)
C
      DO 30 K = 1,N
         IF (WI(K)) 30,10,20
   10    DO 11 J = 1,N
   11       ZI(J,K) = 0.D0
         GO TO 30
   20    KP1 = K + 1
         DO 21 J = 1,N
            ZI(J,K) = ZR(J,KP1)
            ZR(J,KP1) = ZR(J,K)
   21       ZI(J,KP1) = -ZI(J,K)
   30 CONTINUE
      RETURN
      END
      SUBROUTINE DBAL(NM,N,A,LOW,IGH,SCALE)
C
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
      DOUBLE PRECISION A(NM,N),SCALE(N)
      DOUBLE PRECISION C,F,G,R,S,B2,RADIX
      INTEGER IPMPAR
C     DOUBLE PRECISION DABS
      LOGICAL NOCONV
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     DBAL BALANCES A DOUBLE PRECISION REAL MATRIX AND ISOLATES
C     EIGENVALUES WHENEVER POSSIBLE.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        A CONTAINS THE INPUT MATRIX TO BE BALANCED.
C
C     ON OUTPUT-
C
C        A CONTAINS THE BALANCED MATRIX,
C
C        LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J)
C          IS EQUAL TO ZERO IF
C           (1) I IS GREATER THAN J AND
C           (2) J=1,...,LOW-1 OR I=IGH+1,...,N,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE
C           PERMUTATIONS AND SCALING FACTORS USED.
C
C     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
C     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
C     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
C     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
C        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
C                 = D(J,J),      J = LOW,...,IGH
C                 = P(J)         J = IGH+1,...,N.
C     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
C     THEN 1 TO LOW-1.
C
C     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
C
C     THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN
C     DBAL IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
C     K,L HAVE BEEN REVERSED.)
C
C-----------------------------------------------------------------------
C
C     ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION.
C
                 RADIX = IPMPAR(4)
C
C                **********
C
      B2 = RADIX * RADIX
      K = 1
      L = N
      GO TO 100
C     ********** IN-LINE PROCEDURE FOR ROW AND
C                COLUMN EXCHANGE **********
   20 SCALE(M) = J
      IF (J .EQ. M) GO TO 50
C
      DO 30 I = 1, L
         F = A(I,J)
         A(I,J) = A(I,M)
         A(I,M) = F
   30 CONTINUE
C
      DO 40 I = K, N
         F = A(J,I)
         A(J,I) = A(M,I)
         A(M,I) = F
   40 CONTINUE
C
   50 GO TO (80,130), IEXC
C     ********** SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C                AND PUSH THEM DOWN **********
   80 IF (L .EQ. 1) GO TO 280
      L = L - 1
C     ********** FOR J=L STEP -1 UNTIL 1 DO -- **********
  100 DO 120 JJ = 1, L
         J = L + 1 - JJ
C
         DO 110 I = 1, L
            IF (I .EQ. J) GO TO 110
            IF (A(J,I) .NE. 0.D0) GO TO 120
  110    CONTINUE
C
         M = L
         IEXC = 1
         GO TO 20
  120 CONTINUE
C
      GO TO 140
C     ********** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C                AND PUSH THEM LEFT **********
  130 K = K + 1
C
  140 DO 170 J = K, L
C
         DO 150 I = K, L
            IF (I .EQ. J) GO TO 150
            IF (A(I,J) .NE. 0.D0) GO TO 170
  150    CONTINUE
C
         M = K
         IEXC = 2
         GO TO 20
  170 CONTINUE
C     ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L **********
      DO 180 I = K, L
  180 SCALE(I) = 1.D0
C     ********** ITERATIVE LOOP FOR NORM REDUCTION **********
  190 NOCONV = .FALSE.
C
      DO 270 I = K, L
         C = 0.D0
         R = 0.D0
C
         DO 200 J = K, L
            IF (J .EQ. I) GO TO 200
            C = C + DABS(A(J,I))
            R = R + DABS(A(I,J))
  200    CONTINUE
C     ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW **********
         IF (C .EQ. 0.D0 .OR. R .EQ. 0.D0) GO TO 270
         G = R / RADIX
         F = 1.D0
         S = C + R
  210    IF (C .GE. G) GO TO 220
         F = F * RADIX
         C = C * B2
         GO TO 210
  220    G = R * RADIX
  230    IF (C .LT. G) GO TO 240
         F = F / RADIX
         C = C / B2
         GO TO 230
C     ********** NOW BALANCE **********
  240    IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270
         G = 1.D0 / F
         SCALE(I) = SCALE(I) * F
         NOCONV = .TRUE.
C
         DO 250 J = K, N
  250    A(I,J) = A(I,J) * G
C
         DO 260 J = 1, L
  260    A(J,I) = A(J,I) * F
C
  270 CONTINUE
C
      IF (NOCONV) GO TO 190
C
  280 LOW = K
      IGH = L
      RETURN
      END
      SUBROUTINE DBALNV (NZ,N,Z,LOW,IGH,SCALE)
      INTEGER I,J,K,N,II,NZ,IGH,LOW
      DOUBLE PRECISION Z(NZ,N),SCALE(N)
      DOUBLE PRECISION S
C-----------------------------------------------------------------------
C        GIVEN A MATRIX A OF ORDER N. DBAL TRANSFORMS A INTO
C     THE MATRIX B BY THE SIMILARITY TRANSFORMATION
C             B = D**(-1)*TRANSPOSE(P)*A*P*D
C     WHERE D IS A DIAGONAL MATRIX AND P A PERMUTATION MATRIX.
C     THE INFORMATION CONCERNING D AND P IS STORED IN IGH, LOW,
C     AND SCALE. THE ORDER IN WHICH THE INTERCHANGES WERE MADE
C     IS N TO IGH + 1, AND THEN 1 TO LOW - 1.
C
C        Z IS A MATRIX OF ORDER N. DBALNV TRANSFORMS Z INTO THE
C     MATRIX W USING THE INVERSE SIMILARITY TRANSFORM
C             W = P*D*Z*D**(-1)*TRANSPOSE(P)
C
C     ON INPUT-
C
C        NZ IS THE ROW DIMENSION OF THE MATRIX Z IN THE CALLING
C          PROGRAM,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY  DBAL,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
C          AND SCALING FACTORS USED BY  DBAL,
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMED MATRIX W
C
C-----------------------------------------------------------------------
C
      IF (IGH .EQ. LOW) GO TO 30
C
      DO 11 I = LOW, IGH
      S = SCALE(I)
         DO 10 J = 1, N
   10    Z(I,J) = Z(I,J) * S
   11 CONTINUE
C
      DO 21 J = LOW, IGH
      S = 1.D0/SCALE(J)
         DO 20 I = 1, N
   20    Z(I,J) = Z(I,J) * S
   21 CONTINUE
C
C     ********- FOR I=LOW-1 STEP -1 UNTIL 1,
C               IGH+1 STEP 1 UNTIL N DO -- **********
C
   30 DO 60 II = 1, N
         I = II
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 60
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GO TO 60
C
         DO 40 J = 1, N
            S = Z(I,J)
            Z(I,J) = Z(K,J)
   40       Z(K,J) = S
C
         DO 50 J = 1, N
            S = Z(J,I)
            Z(J,I) = Z(J,K)
   50       Z(J,K) = S
   60 CONTINUE
      RETURN
      END
      SUBROUTINE DORTH(NM,N,LOW,IGH,A,ORT)
C
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      DOUBLE PRECISION A(NM,N),ORT(IGH)
      DOUBLE PRECISION F,G,H,SCALE
C     DOUBLE PRECISION DSQRT,DABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES,
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     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE DBAL.  IF DBAL HAS NOT BEEN USED THEN
C          SET LOW=1, IGH=N,
C
C        A CONTAINS THE INPUT MATRIX.
C
C     ON OUTPUT-
C
C        A CONTAINS THE HESSENBERG MATRIX.  INFORMATION ABOUT
C          THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION
C          IS STORED IN THE REMAINING TRIANGLE UNDER THE
C          HESSENBERG MATRIX,
C
C        ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C-----------------------------------------------------------------------
C
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         H = 0.D0
         ORT(M) = 0.D0
         SCALE = 0.D0
C     ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) **********
         DO 90 I = M, IGH
   90    SCALE = SCALE + DABS(A(I,M-1))
C
         IF (SCALE .EQ. 0.D0) GO TO 180
         MP = M + IGH
C     ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
         DO 100 II = M, IGH
            I = MP - II
            ORT(I) = A(I,M-1) / SCALE
            H = H + ORT(I) * ORT(I)
  100    CONTINUE
C
         G = DSQRT(H)
         IF (ORT(M) .GE. 0.D0) G = -G
         H = H - ORT(M) * G
         ORT(M) = ORT(M) - G
C     ********** FORM (I-(U*UT)/H) * A **********
         DO 130 J = M, N
            F = 0.D0
C     ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
            DO 110 II = M, IGH
               I = MP - II
               F = F + ORT(I) * A(I,J)
  110       CONTINUE
C
            F = F / H
C
            DO 120 I = M, IGH
  120       A(I,J) = A(I,J) - F * ORT(I)
C
  130    CONTINUE
C     ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) **********
         DO 160 I = 1, IGH
            F = 0.D0
C     ********** FOR J=IGH STEP -1 UNTIL M DO -- **********
            DO 140 JJ = M, IGH
               J = MP - JJ
               F = F + ORT(J) * A(I,J)
  140       CONTINUE
C
            F = F / H
C
            DO 150 J = M, IGH
  150       A(I,J) = A(I,J) - F * ORT(J)
C
  160    CONTINUE
C
         ORT(M) = SCALE * ORT(M)
         A(M,M-1) = SCALE * G
  180 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE DHQR(NM,N,LOW,IGH,H,WR,WI,IERR)
C
      INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITS,LOW,MP2,ENM2,IERR
      DOUBLE PRECISION H(NM,N),WR(N),WI(N)
      DOUBLE PRECISION P,Q,R,S,T,W,X,Y,ZZ,NORM,MACHEP,DPMPAR
C     DOUBLE PRECISION DSQRT,DABS
C     INTEGER MIN0
      LOGICAL NOTLAS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR,
C     NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971).
C
C     DHQR FINDS THE EIGENVALUES OF A DOUBLE PRECISION REAL
C     UPPER HESSENBERG MATRIX BY THE QR METHOD.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE DBAL.  IF DBAL HAS NOT BEEN USED THEN
C          SET LOW=1, IGH=N,
C
C        H CONTAINS THE UPPER HESSENBERG MATRIX.  INFORMATION ABOUT
C          THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG
C          FORM BY DORTH, IF PERFORMED, IS STORED
C          IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX.
C
C     ON OUTPUT-
C
C        H HAS BEEN DESTROYED.  THEREFORE, IT MUST BE SAVED
C          BEFORE CALLING  HQR  IF SUBSEQUENT CALCULATION AND
C          BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  THE EIGENVALUES
C          ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C          OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C          HAVING THE POSITIVE IMAGINARY PART FIRST.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 50 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0
C                IN THE DOUBLE PRECISION ARITHMETIC BEING USED.
C
                 MACHEP = DPMPAR(1)
C
C                **********
C
      IERR = 0
      NORM = 0.D0
      K = 1
C     ********** STORE ROOTS ISOLATED BY DBAL
C                AND COMPUTE MATRIX NORM **********
      DO 50 I = 1, N
C
         DO 40 J = K, N
   40    NORM = NORM + DABS(H(I,J))
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.D0
   50 CONTINUE
C
      EN = IGH
      T = 0.D0
C     ********** SEARCH FOR NEXT EIGENVALUES **********
   60 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = DABS(H(L-1,L-1)) + DABS(H(L,L))
         IF (S .EQ. 0.D0) S = NORM
         IF (DABS(H(L,L-1)) .LE. MACHEP * S) GO TO 100
   80 CONTINUE
C     ********** FORM SHIFT **********
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITS .EQ. 50) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20 .AND. ITS .NE. 30) GO TO 130
C     ********** FORM EXCEPTIONAL SHIFT **********
      T = T + X
C
      DO 120 I = LOW, EN
  120 H(I,I) = H(I,I) - X
C
      S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
      X = .75D0 * S
      Y = X
      W = -.4375D0 * S * S
  130 ITS = ITS + 1
C     ********** LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- **********
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = DABS(P) + DABS(Q) + DABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         IF (DABS(H(M,M-1)) * (DABS(Q) + DABS(R)) .LE. MACHEP * DABS(P)
     X    * (DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.D0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.D0
  160 CONTINUE
C     ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN **********
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.D0
         IF (NOTLAS) R = H(K+2,K-1)
         X = DABS(P) + DABS(Q) + DABS(R)
         IF (X .EQ. 0.D0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = DSQRT(P*P + Q*Q + R*R)
         IF (P .LT. 0.D0) S = -S
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     ********** ROW MODIFICATION **********
         DO 210 J = K, EN
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN0(EN,K+3)
C     ********** COLUMN MODIFICATION **********
         DO 230 I = L, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     ********** ONE ROOT FOUND **********
  270 WR(EN) = X + T
      WI(EN) = 0.D0
      EN = NA
      GO TO 60
C     ********** TWO ROOTS FOUND **********
  280 P = (Y - X) / 2.D0
      Q = P * P + W
      ZZ = DSQRT(DABS(Q))
      X = X + T
      IF (Q .LT. 0.D0) GO TO 320
C     ********** REAL PAIR **********
      IF (P .LT. 0.D0) ZZ = -ZZ
      ZZ = P + ZZ
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.D0) WR(EN) = X - W / ZZ
      WI(NA) = 0.D0
      WI(EN) = 0.D0
      GO TO 330
C     ********** COMPLEX PAIR **********
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 50 ITERATIONS **********
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE DBABK(NM,N,LOW,IGH,SCALE,M,Z)
C
      INTEGER I,J,K,M,N,II,NM,IGH,LOW
      DOUBLE PRECISION SCALE(N),Z(NM,M)
      DOUBLE PRECISION S
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL
C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C     BALANCED MATRIX DETERMINED BY DBAL.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY DBAL,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
C          AND SCALING FACTORS USED BY DBAL,
C
C        M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED,
C
C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN-
C          VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE
C          TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS.
C
C-----------------------------------------------------------------------
C
      IF (M .EQ. 0) GO TO 200
      IF (IGH .EQ. LOW) GO TO 120
C
      DO 110 I = LOW, IGH
         S = SCALE(I)
C     ********** LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
C                IF THE FOREGOING STATEMENT IS REPLACED BY
C                S=1.0/SCALE(I). **********
         DO 100 J = 1, M
  100    Z(I,J) = Z(I,J) * S
C
  110 CONTINUE
C     ********- FOR I=LOW-1 STEP -1 UNTIL 1,
C               IGH+1 STEP 1 UNTIL N DO -- **********
  120 DO 140 II = 1, N
         I = II
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GO TO 140
C
         DO 130 J = 1, M
            S = Z(I,J)
            Z(I,J) = Z(K,J)
            Z(K,J) = S
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE DORTRN(NM,N,LOW,IGH,A,ORT,Z)
C
      INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
      DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,N)
      DOUBLE PRECISION G
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS,
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 ORTHOGONAL SIMILARITY
C     TRANSFORMATIONS USED IN THE REDUCTION OF A REAL DOUBLE
C     PRECISION MATRIX TO UPPER HESSENBERG FORM BY DORTH.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE DBAL.  IF DBAL HAS NOT BEEN USED THEN
C          SET LOW=1, IGH=N,
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C          FORMATIONS USED IN THE REDUCTION BY DORTH
C          IN ITS STRICT LOWER TRIANGLE,
C
C        ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
C          FORMATIONS USED IN THE REDUCTION BY DORTH.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY DORTH,
C
C        ORT HAS BEEN ALTERED.
C
C-----------------------------------------------------------------------
C
C     ********** INITIALIZE Z TO IDENTITY MATRIX **********
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.D0
C
         Z(I,I) = 1.D0
   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
         IF (A(MP,MP-1) .EQ. 0.D0) GO TO 140
         MP1 = MP + 1
C
         DO 100 I = MP1, IGH
  100    ORT(I) = A(I,MP-1)
C
         DO 130 J = MP, IGH
            G = 0.D0
C
            DO 110 I = MP, IGH
  110       G = G + ORT(I) * Z(I,J)
C     ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
C                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
            G = (G / ORT(MP)) / A(MP,MP-1)
C
            DO 120 I = MP, IGH
  120       Z(I,J) = Z(I,J) + G * ORT(I)
C
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE DRTRN1(N,LOW,IGH,A,NA,Z,NZ,ORT)
C
      INTEGER I,J,N,KL,MM,MP,NA,IGH,LOW,MP1,NZ
      DOUBLE PRECISION A(NA,IGH),ORT(IGH),Z(NZ,N)
      DOUBLE PRECISION G
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS,
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 ORTHOGONAL SIMILARITY
C     TRANSFORMATIONS USED IN THE REDUCTION OF A REAL DOUBLE
C     PRECISION MATRIX TO UPPER HESSENBERG FORM BY DORTH.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE DBAL.  IF DBAL HAS NOT BEEN USED THEN
C          SET LOW=1, IGH=N,
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C          FORMATIONS USED IN THE REDUCTION BY DORTH
C          IN ITS STRICT LOWER TRIANGLE,
C
C        NA MUST BE SET TO THE ROW DIMENSION OF THE 2-DIMENSIONAL
C          ARRAY PARAMETER  A  AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        NZ MUST BE SET TO THE ROW DIMENSION OF THE 2-DIMENSIONAL
C          ARRAY PARAMETER  Z  AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS-
C          FORMATIONS USED IN THE REDUCTION BY DORTH.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C     ON OUTPUT-
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY DORTH,
C
C        ORT HAS BEEN ALTERED.
C
C-----------------------------------------------------------------------
C
C     ********** INITIALIZE Z TO IDENTITY MATRIX **********
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.D0
C
         Z(I,I) = 1.D0
   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
         IF (A(MP,MP-1) .EQ. 0.D0) GO TO 140
         MP1 = MP + 1
C
         DO 100 I = MP1, IGH
  100    ORT(I) = A(I,MP-1)
C
         DO 130 J = MP, IGH
            G = 0.D0
C
            DO 110 I = MP, IGH
  110       G = G + ORT(I) * Z(I,J)
C     ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
C                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
            G = (G / ORT(MP)) / A(MP,MP-1)
C
            DO 120 I = MP, IGH
  120       Z(I,J) = Z(I,J) + G * ORT(I)
C
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE DHQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR)
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN,
     X        IGH,ITS,LOW,MP2,ENM2,IERR
      DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N)
      DOUBLE PRECISION A,B,D,P,Q,R,S,T,U,W,X,Y
      DOUBLE PRECISION RA,SA,VI,VR,ZZ,NORM,MACHEP
C     INTEGER MIN0
C     DOUBLE PRECISION DSQRT,DABS
      DOUBLE PRECISION DPMPAR
      LOGICAL NOTLAS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2,
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 FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A REAL DOUBLE PRECISION UPPER HESSENBERG MATRIX BY THE
C     QR METHOD.  THE EIGENVECTORS OF A REAL GENERAL MATRIX CAN
C     ALSO BE FOUND IF DORTH AND DORTRN HAVE BEEN USED TO REDUCE
C     THIS GENERAL MATRIX TO HESSENBERG FORM AND TO ACCUMULATE
C     THE SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE DBAL.  IF DBAL HAS NOT BEEN USED THEN
C          SET LOW=1, IGH=N,
C
C        H CONTAINS THE UPPER HESSENBERG MATRIX,
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY DORTRN
C          AFTER THE REDUCTION BY DORTH, IF PERFORMED. IF THE
C          EIGENVECTORS OF THE HESSENBERG MATRIX ARE DESIRED,
C          Z MUST CONTAIN THE IDENTITY MATRIX.
C
C     ON OUTPUT-
C
C        H HAS BEEN DESTROYED,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  THE EIGENVALUES
C          ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS
C          OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE
C          HAVING THE POSITIVE IMAGINARY PART FIRST.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N,
C
C        Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS.
C          IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z
C          CONTAINS ITS EIGENVECTOR.  IF THE I-TH EIGENVALUE IS COMPLEX
C          WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH
C          COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS
C          EIGENVECTOR.  THE EIGENVECTORS ARE UNNORMALIZED.  IF AN
C          ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 50 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0
C                IN THE DOUBLE PRECISION ARITHMETIC BEING USED.
C
                 MACHEP = DPMPAR(1)
C
C                **********
C
      IERR = 0
      NORM = 0.D0
      K = 1
C     ********** STORE ROOTS ISOLATED BY DBAL
C                AND COMPUTE MATRIX NORM **********
      DO 50 I = 1, N
C
         DO 40 J = K, N
   40    NORM = NORM + DABS(H(I,J))
C
         K = I
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50
         WR(I) = H(I,I)
         WI(I) = 0.D0
   50 CONTINUE
C
      EN = IGH
      T = 0.D0
C     ********** SEARCH FOR NEXT EIGENVALUES **********
   60 IF (EN .LT. LOW) GO TO 340
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********
   70 DO 80 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 100
         S = DABS(H(L-1,L-1)) + DABS(H(L,L))
         IF (S .EQ. 0.D0) S = NORM
         IF (DABS(H(L,L-1)) .LE. MACHEP * S) GO TO 100
   80 CONTINUE
C     ********** FORM SHIFT **********
  100 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 270
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 280
      IF (ITS .EQ. 50) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20 .AND. ITS .NE. 30) GO TO 130
C     ********** FORM EXCEPTIONAL SHIFT **********
      T = T + X
C
      DO 120 I = LOW, EN
  120 H(I,I) = H(I,I) - X
C
      S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))
      X = .75D0 * S
      Y = X
      W = -.4375D0 * S * S
  130 ITS = ITS + 1
C     ********** LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- **********
      DO 140 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = DABS(P) + DABS(Q) + DABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 150
         IF (DABS(H(M,M-1)) * (DABS(Q) + DABS(R)) .LE. MACHEP * DABS(P)
     X    * (DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))) GO TO 150
  140 CONTINUE
C
  150 MP2 = M + 2
C
      DO 160 I = MP2, EN
         H(I,I-2) = 0.D0
         IF (I .EQ. MP2) GO TO 160
         H(I,I-3) = 0.D0
  160 CONTINUE
C     ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN **********
      DO 260 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 170
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = 0.D0
         IF (NOTLAS) R = H(K+2,K-1)
         X = DABS(P) + DABS(Q) + DABS(R)
         IF (X .EQ. 0.D0) GO TO 260
         P = P / X
         Q = Q / X
         R = R / X
  170    S = DSQRT(P*P + Q*Q + R*R)
         IF (P .LT. 0.D0) S = -S
         IF (K .EQ. M) GO TO 180
         H(K,K-1) = -S * X
         GO TO 190
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  190    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     ********** ROW MODIFICATION **********
         DO 210 J = K, N
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 200
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  200       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  210    CONTINUE
C
         J = MIN0(EN,K+3)
C     ********** COLUMN MODIFICATION **********
         DO 230 I = 1, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 220
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  220       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  230    CONTINUE
C     ********** ACCUMULATE TRANSFORMATIONS **********
         DO 250 I = LOW, IGH
            P = X * Z(I,K) + Y * Z(I,K+1)
            IF (.NOT. NOTLAS) GO TO 240
            P = P + ZZ * Z(I,K+2)
            Z(I,K+2) = Z(I,K+2) - P * R
  240       Z(I,K+1) = Z(I,K+1) - P * Q
            Z(I,K) = Z(I,K) - P
  250    CONTINUE
C
  260 CONTINUE
C
      GO TO 70
C     ********** ONE ROOT FOUND **********
  270 H(EN,EN) = X + T
      WR(EN) = H(EN,EN)
      WI(EN) = 0.D0
      EN = NA
      GO TO 60
C     ********** TWO ROOTS FOUND **********
  280 P = (Y - X) / 2.D0
      Q = P * P + W
      ZZ = DSQRT(DABS(Q))
      H(EN,EN) = X + T
      X = H(EN,EN)
      H(NA,NA) = Y + T
      IF (Q .LT. 0.D0) GO TO 320
C     ********** REAL PAIR **********
      IF (P .LT. 0.D0) ZZ = -ZZ
      ZZ = P + ZZ
      WR(NA) = X + ZZ
      WR(EN) = WR(NA)
      IF (ZZ .NE. 0.D0) WR(EN) = X - W / ZZ
      WI(NA) = 0.D0
      WI(EN) = 0.D0
      X = H(EN,NA)
      S = DABS(X) + DABS(ZZ)
      P = X / S
      Q = ZZ / S
      R = DSQRT(P*P+Q*Q)
      P = P / R
      Q = Q / R
C     ********** ROW MODIFICATION **********
      DO 290 J = NA, N
         ZZ = H(NA,J)
         H(NA,J) = Q * ZZ + P * H(EN,J)
         H(EN,J) = Q * H(EN,J) - P * ZZ
  290 CONTINUE
C     ********** COLUMN MODIFICATION **********
      DO 300 I = 1, EN
         ZZ = H(I,NA)
         H(I,NA) = Q * ZZ + P * H(I,EN)
         H(I,EN) = Q * H(I,EN) - P * ZZ
  300 CONTINUE
C     ********** ACCUMULATE TRANSFORMATIONS **********
      DO 310 I = LOW, IGH
         ZZ = Z(I,NA)
         Z(I,NA) = Q * ZZ + P * Z(I,EN)
         Z(I,EN) = Q * Z(I,EN) - P * ZZ
  310 CONTINUE
C
      GO TO 330
C     ********** COMPLEX PAIR **********
  320 WR(NA) = X + P
      WR(EN) = X + P
      WI(NA) = ZZ
      WI(EN) = -ZZ
  330 EN = ENM2
      GO TO 60
C     ********** ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM **********
  340 IF (NORM .EQ. 0.D0) GO TO 1001
C     ********** FOR EN=N STEP -1 UNTIL 1 DO -- **********
      DO 800 NN = 1, N
         EN = N + 1 - NN
         P = WR(EN)
         Q = WI(EN)
         NA = EN - 1
         IF (Q) 710, 600, 800
C     ********** REAL VECTOR **********
  600    M = EN
         H(EN,EN) = 1.D0
         IF (NA .EQ. 0) GO TO 800
C     ********** FOR I=EN-1 STEP -1 UNTIL 1 DO -- **********
         DO 700 II = 1, NA
            I = EN - II
            W = H(I,I) - P
            R = H(I,EN)
            IF (M .GT. NA) GO TO 620
C
            DO 610 J = M, NA
  610       R = R + H(I,J) * H(J,EN)
C
  620       IF (WI(I) .GE. 0.D0) GO TO 630
            ZZ = W
            S = R
            GO TO 700
  630       M = I
            IF (WI(I) .NE. 0.D0) GO TO 640
            T = W
            IF (W .EQ. 0.D0) T = MACHEP * NORM
            H(I,EN) = -R / T
            GO TO 700
C     ********** SOLVE REAL EQUATIONS **********
  640       X = H(I,I+1)
            Y = H(I+1,I)
            Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I)
            T = (X * S - ZZ * R) / Q
            H(I,EN) = T
            IF (DABS(X) .LE. DABS(ZZ)) GO TO 650
            H(I+1,EN) = (-R - W * T) / X
            GO TO 700
  650       H(I+1,EN) = (-S - Y * T) / ZZ
  700    CONTINUE
C     ********** END REAL VECTOR **********
         GO TO 800
C     ********** COMPLEX VECTOR **********
  710    M = NA
C     ********** LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C                EIGENVECTOR MATRIX IS TRIANGULAR **********
         IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720
         H(NA,NA) = Q / H(EN,NA)
         H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA)
         GO TO 730
  720    U = H(NA,NA) - P
         B = -H(NA,EN) / (U * U + Q * Q)
         H(NA,NA) = B * Q
         H(NA,EN) = B * U
  730    H(EN,NA) = 0.D0
         H(EN,EN) = 1.D0
         ENM2 = NA - 1
         IF (ENM2 .EQ. 0) GO TO 800
C     ********** FOR I=EN-2 STEP -1 UNTIL 1 DO -- **********
         DO 790 II = 1, ENM2
            I = NA - II
            W = H(I,I) - P
            RA = 0.D0
            SA = H(I,EN)
C
            DO 760 J = M, NA
               RA = RA + H(I,J) * H(J,NA)
               SA = SA + H(I,J) * H(J,EN)
  760       CONTINUE
C
            IF (WI(I) .GE. 0.D0) GO TO 770
            ZZ = W
            R = RA
            S = SA
            GO TO 790
  770       M = I
            IF (WI(I) .NE. 0.D0) GO TO 780
            D = W * W + Q * Q
            H(I,NA) = -(RA * W + SA * Q) / D
            H(I,EN) = (RA * Q - SA * W) / D
            GO TO 790
C     ********** SOLVE COMPLEX EQUATIONS **********
  780       X = H(I,I+1)
            Y = H(I+1,I)
            VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q
            VI = (WR(I) - P) * 2.D0 * Q
            IF (VR .EQ. 0.D0 .AND. VI .EQ. 0.D0) VR = MACHEP * NORM
     X       * (DABS(W) + DABS(Q) + DABS(X) + DABS(Y) + DABS(ZZ))
            A = X * R - ZZ * RA + Q * SA
            B = X * S - ZZ * SA - Q * RA
            D = VR * VR + VI * VI
            H(I,NA) = (A * VR + B * VI) / D
            H(I,EN) = (B * VR - A * VI) / D
            IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785
            H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X
            H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X
            GO TO 790
  785       A = -R - Y * H(I,NA)
            B = -S - Y * H(I,EN)
            D = ZZ * ZZ + Q * Q
            H(I+1,NA) = (A * ZZ + B * Q) / D
            H(I+1,EN) = (B * ZZ - A * Q) / D
  790    CONTINUE
C     ********** END COMPLEX VECTOR **********
  800 CONTINUE
C     ********** END BACK SUBSTITUTION.
C                VECTORS OF ISOLATED ROOTS **********
      DO 840 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
C
         DO 820 J = I, N
  820    Z(I,J) = H(I,J)
C
  840 CONTINUE
C     ********** MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW DO -- **********
      DO 880 JJ = LOW, N
         J = N + LOW - JJ
         M = MIN0(J,IGH)
C
         DO 880 I = LOW, IGH
            ZZ = 0.D0
C
            DO 860 K = LOW, M
  860       ZZ = ZZ + Z(I,K) * H(K,J)
C
            Z(I,J) = ZZ
  880 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 50 ITERATIONS **********
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE SEIG (A, KA, N, W, T, IERR)
C-----------------------------------------------------------------------
C               EIGENVALUES OF SYMMETRIC REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(*), W(N), T(*)
C
      IF (KA .EQ. 0) GO TO 10
         CALL TRED1 (KA, N, A, W, T(N+1), T(1))
         CALL TQLRAT (N, W, T, IERR)
         RETURN
10    L = N*(N + 1)
      L = L/2
      CALL TRED3 (N, L, A, W, T(N+1), T(1))
      CALL TQLRAT (N, W, T, IERR)
      RETURN
      END
      SUBROUTINE SEIG1 (A, KA, N, W, T, IERR)
C-----------------------------------------------------------------------
C               EIGENVALUES OF SYMMETRIC REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(*), W(N), T(N)
C
      IF (KA .EQ. 0) GO TO 10
         CALL TRED1 (KA, N, A, W, T, T)
         CALL IMTQL1 (N, W, T, IERR)
         RETURN
10    L = N*(N + 1)
      L = L/2
      CALL TRED3 (N, L, A, W, T, T)
      CALL IMTQL1 (N, W, T, IERR)
      RETURN
      END
      SUBROUTINE SEIGV (A, KA, N, W, Z, T, IERR)
C-----------------------------------------------------------------------
C        EIGENVALUES AND EIGENVECTORS OF SYMMETRIC REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), W(N), Z(KA,N), T(N)
C
      CALL TRED2 (KA, N, A, W, T, Z)
      CALL TQL2 (KA, N, W, T, Z, IERR)
      RETURN
      END
      SUBROUTINE SEIGV1 (A, KA, N, W, Z, T, IERR)
C-----------------------------------------------------------------------
C        EIGENVALUES AND EIGENVECTORS OF SYMMETRIC REAL MATRICES
C-----------------------------------------------------------------------
      REAL A(KA,N), W(N), Z(KA,N), T(N)
C
      CALL TRED2 (KA, N, A, W, T, Z)
      CALL IMTQL2 (KA, N, W, T, Z, IERR)
      RETURN
      END
      SUBROUTINE TRED1(NM,N,A,D,E,E2)
C
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL A(NM,N),D(N),E(N),E2(N)
      REAL F,G,H,SCALE
C     REAL SQRT,ABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
C     TO A SYMMETRIC TRIDIAGONAL MATRIX USING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT-
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C          FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
C          TRIANGLE.  THE FULL UPPER TRIANGLE OF A IS UNALTERED,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C-----------------------------------------------------------------------
C
      DO 100 I = 1, N
  100 D(I) = A(I,I)
C     ********** FOR I=N STEP -1 UNTIL 1 DO -- **********
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0
         SCALE = 0.0
         IF (L .LT. 1) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(A(I,K))
C
         IF (SCALE .NE. 0.0) GO TO 140
  130    E(I) = 0.0
         E2(I) = 0.0
         GO TO 290
C
  140    DO 150 K = 1, L
            A(I,K) = A(I,K) / SCALE
            H = H + A(I,K) * A(I,K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = A(I,L)
         G = SQRT(H)
         IF (F .GE. 0.0) G = -G
         E(I) = SCALE * G
         H = H - F * G
         A(I,L) = F - G
         IF (L .EQ. 1) GO TO 270
         F = 0.0
C
         DO 240 J = 1, L
            G = 0.0
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, J
  180       G = G + A(J,K) * A(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + A(K,J) * A(I,K)
C     ********** FORM ELEMENT OF P **********
  220       E(J) = G / H
            F = F + E(J) * A(I,J)
  240    CONTINUE
C
         H = F / (H + H)
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = A(I,J)
            G = E(J) - H * F
            E(J) = G
C
            DO 260 K = 1, J
               A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
  260    CONTINUE
C
  270    DO 280 K = 1, L
  280    A(I,K) = SCALE * A(I,K)
C
  290    H = D(I)
         D(I) = A(I,I)
         A(I,I) = H
  300 CONTINUE
C
      RETURN
C     ********** LAST CARD OF TRED1 **********
      END
      SUBROUTINE TRED3(N,NV,A,D,E,E2)
C
      INTEGER I,J,K,L,N,II,IZ,JK,NV
      REAL A(NV),D(N),E(N),E2(N)
      REAL F,G,H,HH,SCALE
C     REAL SQRT,ABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS
C     A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX
C     USING ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
C          AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT,
C
C        A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
C          INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL
C          ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS.
C
C     ON OUTPUT-
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL
C          TRANSFORMATIONS USED IN THE REDUCTION,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C-----------------------------------------------------------------------
C
C     ********** FOR I=N STEP -1 UNTIL 1 DO -- **********
      DO  300 II = 1, N
         I = N + 1 - II
         L = I - 1
         IZ = (I * L) / 2
         H = 0.0
         SCALE = 0.0
         IF (L .LT. 1) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
            IZ = IZ + 1
            D(K) = A(IZ)
            SCALE = SCALE + ABS(D(K))
  120    CONTINUE
C
         IF (SCALE .NE. 0.0) GO TO 140
  130    E(I) = 0.0
         E2(I) = 0.0
         GO TO 290
C
  140    DO 150 K = 1, L
            D(K) = D(K) / SCALE
            H = H + D(K) * D(K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = D(L)
         G = SQRT(H)
         IF (F .GE. 0.0) G = -G
         E(I) = SCALE * G
         H = H - F * G
         D(L) = F - G
         A(IZ) = SCALE * D(L)
         IF (L .EQ. 1) GO TO 290
         F = 0.0
C
         DO 240 J = 1, L
            G = 0.0
            JK = (J * (J-1)) / 2
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, L
               JK = JK + 1
               IF (K .GT. J) JK = JK + K - 2
               G = G + A(JK) * D(K)
  180       CONTINUE
C     ********** FORM ELEMENT OF P **********
            E(J) = G / H
            F = F + E(J) * D(J)
  240    CONTINUE
C
         HH = F / (H + H)
         JK = 0
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = D(J)
            G = E(J) - HH * F
            E(J) = G
C
            DO 260 K = 1, J
               JK = JK + 1
               A(JK) = A(JK) - F * E(K) - G * D(K)
  260    CONTINUE
C
  290    D(I) = A(IZ+1)
         A(IZ+1) = SCALE * SQRT(H)
  300 CONTINUE
C
      RETURN
C     ********** LAST CARD OF TRED3 **********
      END
      SUBROUTINE TQLRAT(N,D,E2,IERR)
C
      INTEGER I,J,L,M,N,II,L1,MML,IERR
      REAL D(N),E2(N)
      REAL B,C,F,G,H,P,R,S,MACHEP
C     REAL SQRT,ABS,SPMPAR
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        E2 HAS BEEN DESTROYED,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 .
C
                 MACHEP = SPMPAR(1)
C
C                **********
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E2(I-1) = E2(I)
C
      F = 0.0
      B = 0.0
      E2(N) = 0.0
C
      DO 290 L = 1, N
         J = 0
         H = MACHEP * (ABS(D(L)) + SQRT(E2(L)))
         IF (B .GT. H) GO TO 105
         B = H
         C = B * B
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
  105    DO 110 M = L, N
            IF (E2(M) .LE. C) GO TO 120
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 210
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         L1 = L + 1
         S = SQRT(E2(L))
         G = D(L)
         P = (D(L1) - G) / (2.0 * S)
         R = SQRT(P*P+1.0)
         IF (P .LT. 0.0) R = -R
         D(L) = S / (P + R)
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     ********** RATIONAL QL TRANSFORMATION **********
         G = D(M)
         IF (G .EQ. 0.0) G = B
         H = G
         S = 0.0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            P = G * H
            R = P + E2(I)
            E2(I+1) = S * R
            S = E2(I) / R
            D(I+1) = H + S * (H + D(I))
            G = D(I) - E2(I) / G
            IF (G .EQ. 0.0) G = B
            H = G * P / R
  200    CONTINUE
C
         E2(L) = S * G
         D(L) = H
C     ********** GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST **********
         IF (H .EQ. 0.0) GO TO 210
         IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210
         E2(L) = H * E2(L)
         IF (E2(L) .NE. 0.0) GO TO 130
  210    P = D(L) + F
C     ********** ORDER EIGENVALUES **********
         IF (L .EQ. 1) GO TO 250
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. D(I-1)) GO TO 270
            D(I) = D(I-1)
  230    CONTINUE
C
  250    I = 1
  270    D(I) = P
  290 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF TQLRAT **********
      END
      SUBROUTINE IMTQL1(N,D,E,IERR)
C
      INTEGER I,J,L,M,N,II,MML,IERR
      REAL D(N),E(N)
      REAL B,C,F,G,P,R,S,MACHEP
C     REAL SQRT,ABS,SPMPAR
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1,
C     NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C     AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        E HAS BEEN DESTROYED,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 .
C
                 MACHEP = SPMPAR(1)
C
C                **********
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      E(N) = 0.0
C
      DO 290 L = 1, N
         J = 0
C     ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
  105    DO 110 M = L, N
            IF (M .EQ. N) GO TO 120
            IF (ABS(E(M)) .LE. MACHEP * (ABS(D(M)) + ABS(D(M+1))))
     X         GO TO 120
  110    CONTINUE
C
  120    P = D(L)
         IF (M .EQ. L) GO TO 215
         IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         G = (D(L+1) - P) / (2.0 * E(L))
         R = SQRT(G*G+1.0)
         IF (G .LT. 0.0) R = -R
         G = D(M) - P + E(L) / (G + R)
         S = 1.0
         C = 1.0
         P = 0.0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            F = S * E(I)
            B = C * E(I)
            IF (ABS(F) .LT. ABS(G)) GO TO 150
            C = G / F
            R = SQRT(C*C+1.0)
            E(I+1) = F * R
            S = 1.0 / R
            C = C * S
            GO TO 160
  150       S = F / G
            R = SQRT(S*S+1.0)
            E(I+1) = G * R
            C = 1.0 / R
            S = S * C
  160       G = D(I+1) - P
            R = (D(I) - G) * S + 2.0 * C * B
            P = S * R
            D(I+1) = G + P
            G = C * R - B
  200    CONTINUE
C
         D(L) = D(L) - P
         E(L) = G
         E(M) = 0.0
         GO TO 105
C     ********** ORDER EIGENVALUES **********
  215    IF (L .EQ. 1) GO TO 250
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. D(I-1)) GO TO 270
            D(I) = D(I-1)
  230    CONTINUE
C
  250    I = 1
  270    D(I) = P
  290 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF IMTQL1 **********
      END
      SUBROUTINE TRED2(NM,N,A,D,E,Z)
C
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL A(NM,N),D(N),E(N),Z(NM,N)
      REAL F,G,H,HH,SCALE
C     REAL SQRT,ABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A
C     SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT-
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX
C          PRODUCED IN THE REDUCTION,
C
C        A AND Z MAY COINCIDE.  IF DISTINCT, A IS UNALTERED.
C
C-----------------------------------------------------------------------
C
      DO 100 I = 1, N
C
         DO 100 J = 1, I
            Z(I,J) = A(I,J)
  100 CONTINUE
C
      IF (N .EQ. 1) GO TO 320
C     ********** FOR I=N STEP -1 UNTIL 2 DO -- **********
      DO 300 II = 2, N
         I = N + 2 - II
         L = I - 1
         H = 0.0
         SCALE = 0.0
         IF (L .LT. 2) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(Z(I,K))
C
         IF (SCALE .NE. 0.0) GO TO 140
  130    E(I) = Z(I,L)
         GO TO 290
C
  140    DO 150 K = 1, L
            Z(I,K) = Z(I,K) / SCALE
            H = H + Z(I,K) * Z(I,K)
  150    CONTINUE
C
         F = Z(I,L)
         G = SQRT(H)
         IF (F .GE. 0.0) G = -G
         E(I) = SCALE * G
         H = H - F * G
         Z(I,L) = F - G
         F = 0.0
C
         DO 240 J = 1, L
            Z(J,I) = Z(I,J) / H
            G = 0.0
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, J
  180       G = G + Z(J,K) * Z(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + Z(K,J) * Z(I,K)
C     ********** FORM ELEMENT OF P **********
  220       E(J) = G / H
            F = F + E(J) * Z(I,J)
  240    CONTINUE
C
         HH = F / (H + H)
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = Z(I,J)
            G = E(J) - HH * F
            E(J) = G
C
            DO 260 K = 1, J
               Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)
  260    CONTINUE
C
  290    D(I) = H
  300 CONTINUE
C
  320 D(1) = 0.0
      E(1) = 0.0
C     ********** ACCUMULATION OF TRANSFORMATION MATRICES **********
      DO 500 I = 1, N
         L = I - 1
         IF (D(I) .EQ. 0.0) GO TO 380
C
         DO 360 J = 1, L
            G = 0.0
C
            DO 340 K = 1, L
  340       G = G + Z(I,K) * Z(K,J)
C
            DO 360 K = 1, L
               Z(K,J) = Z(K,J) - G * Z(K,I)
  360    CONTINUE
C
  380    D(I) = Z(I,I)
         Z(I,I) = 1.0
         IF (L .LT. 1) GO TO 500
C
         DO 400 J = 1, L
            Z(I,J) = 0.0
            Z(J,I) = 0.0
  400    CONTINUE
C
  500 CONTINUE
C
      RETURN
C     ********** LAST CARD OF TRED2 **********
      END
      SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
C
      INTEGER I,J,K,L,M,N,II,L1,NM,MML,IERR
      REAL D(N),E(N),Z(NM,N)
      REAL B,C,F,G,H,P,R,S,MACHEP
C     REAL SQRT,ABS,SPMPAR
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
C     NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
C     WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
C     FULL MATRIX TO TRIDIAGONAL FORM.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY,
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C          THE IDENTITY MATRIX.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1,2,...,IERR-1,
C
C        E HAS BEEN DESTROYED,
C
C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 .
C
                 MACHEP = SPMPAR(1)
C
C                **********
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      F = 0.0
      B = 0.0
      E(N) = 0.0
C
      DO 240 L = 1, N
         J = 0
         H = MACHEP * (ABS(D(L)) + ABS(E(L)))
         IF (B .LT. H) B = H
C     ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
         DO 110 M = L, N
            IF (ABS(E(M)) .LE. B) GO TO 120
C     ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 220
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         L1 = L + 1
         G = D(L)
         P = (D(L1) - G) / (2.0 * E(L))
         R = SQRT(P*P+1.0)
         IF (P .LT. 0.0) R = -R
         D(L) = E(L) / (P + R)
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     ********** QL TRANSFORMATION **********
         P = D(M)
         C = 1.0
         S = 0.0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            G = C * E(I)
            H = C * P
            IF (ABS(P) .LT. ABS(E(I))) GO TO 150
            C = E(I) / P
            R = SQRT(C*C+1.0)
            E(I+1) = S * P * R
            S = C / R
            C = 1.0 / R
            GO TO 160
  150       C = P / E(I)
            R = SQRT(C*C+1.0)
            E(I+1) = S * E(I) * R
            S = 1.0 / R
            C = C * S
  160       P = C * D(I) - S * G
            D(I+1) = H + S * (C * G + S * D(I))
C     ********** FORM VECTOR **********
            DO 180 K = 1, N
               H = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * H
               Z(K,I) = C * Z(K,I) - S * H
  180       CONTINUE
C
  200    CONTINUE
C
         E(L) = S * P
         D(L) = C * P
         IF (ABS(E(L)) .GT. B) GO TO 130
  220    D(L) = D(L) + F
  240 CONTINUE
C     ********** ORDER EIGENVALUES AND EIGENVECTORS **********
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
C
  300 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF TQL2 **********
      END
      SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR)
C
      INTEGER I,J,K,L,M,N,II,NM,MML,IERR
      REAL D(N),E(N),Z(NM,N)
      REAL B,C,F,G,P,R,S,MACHEP
C     REAL SQRT,ABS,SPMPAR
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
C     NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C     AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
C     FULL MATRIX TO TRIDIAGONAL FORM.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY,
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C          THE IDENTITY MATRIX.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1,2,...,IERR-1,
C
C        E HAS BEEN DESTROYED,
C
C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 .
C
                 MACHEP = SPMPAR(1)
C
C                **********
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      E(N) = 0.0
C
      DO 240 L = 1, N
         J = 0
C     ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
  105    DO 110 M = L, N
            IF (M .EQ. N) GO TO 120
            IF (ABS(E(M)) .LE. MACHEP * (ABS(D(M)) + ABS(D(M+1))))
     X         GO TO 120
  110    CONTINUE
C
  120    P = D(L)
         IF (M .EQ. L) GO TO 240
         IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         G = (D(L+1) - P) / (2.0 * E(L))
         R = SQRT(G*G+1.0)
         IF (G .LT. 0.0) R = -R
         G = D(M) - P + E(L) / (G + R)
         S = 1.0
         C = 1.0
         P = 0.0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            F = S * E(I)
            B = C * E(I)
            IF (ABS(F) .LT. ABS(G)) GO TO 150
            C = G / F
            R = SQRT(C*C+1.0)
            E(I+1) = F * R
            S = 1.0 / R
            C = C * S
            GO TO 160
  150       S = F / G
            R = SQRT(S*S+1.0)
            E(I+1) = G * R
            C = 1.0 / R
            S = S * C
  160       G = D(I+1) - P
            R = (D(I) - G) * S + 2.0 * C * B
            P = S * R
            D(I+1) = G + P
            G = C * R - B
C     ********** FORM VECTOR **********
            DO 180 K = 1, N
               F = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * F
               Z(K,I) = C * Z(K,I) - S * F
  180       CONTINUE
C
  200    CONTINUE
C
         D(L) = D(L) - P
         E(L) = G
         E(M) = 0.0
         GO TO 105
  240 CONTINUE
C     ********** ORDER EIGENVALUES AND EIGENVECTORS **********
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
C
  300 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF IMTQL2 **********
      END
      SUBROUTINE DSEIG (A, KA, N, W, T, IERR)
C-----------------------------------------------------------------------
C                DOUBLE PRECISION COMPUTATION OF THE
C               EIGENVALUES OF SYMMETRIC REAL MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), W(N), T(*)
C
      IF (KA .EQ. 0) GO TO 10
         CALL DTRED1 (KA, N, A, W, T(N+1), T(1))
         CALL DTQL (N, W, T, IERR)
         RETURN
10    L = N*(N + 1)
      L = L/2
      CALL DTRED3 (N, L, A, W, T(N+1), T(1))
      CALL DTQL (N, W, T, IERR)
      RETURN
      END
      SUBROUTINE DSEIGV (A, KA, N, W, Z, T, IERR)
C-----------------------------------------------------------------------
C                 DOUBLE PRECISION COMPUTATION OF
C                 EIGENVALUES AND EIGENVECTORS OF
C                     SYMMETRIC REAL MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(KA,N), W(N), Z(KA,N), T(N)
C
      CALL DTRED2 (KA, N, A, W, T, Z)
      CALL DTQL2 (KA, N, W, T, Z, IERR)
      RETURN
      END
      SUBROUTINE DTRED1 (NM,N,A,D,E,E2)
C
      INTEGER I,J,K,L,N,II,NM,JP1
      DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N)
      DOUBLE PRECISION F,G,H,SCALE
C     DOUBLE PRECISION DSQRT,DABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
C     TO A SYMMETRIC TRIDIAGONAL MATRIX USING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT-
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C          FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
C          TRIANGLE.  THE FULL UPPER TRIANGLE OF A IS UNALTERED,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C-----------------------------------------------------------------------
C
      DO 100 I = 1, N
  100 D(I) = A(I,I)
C     ********** FOR I=N STEP -1 UNTIL 1 DO -- **********
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.D0
         SCALE = 0.D0
         IF (L .LT. 1) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
  120    SCALE = SCALE + DABS(A(I,K))
C
         IF (SCALE .NE. 0.D0) GO TO 140
  130    E(I) = 0.D0
         E2(I) = 0.D0
         GO TO 290
C
  140    DO 150 K = 1, L
            A(I,K) = A(I,K) / SCALE
            H = H + A(I,K) * A(I,K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = A(I,L)
         G = DSQRT(H)
         IF (F .GE. 0.D0) G = -G
         E(I) = SCALE * G
         H = H - F * G
         A(I,L) = F - G
         IF (L .EQ. 1) GO TO 270
         F = 0.D0
C
         DO 240 J = 1, L
            G = 0.D0
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, J
  180       G = G + A(J,K) * A(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + A(K,J) * A(I,K)
C     ********** FORM ELEMENT OF P **********
  220       E(J) = G / H
            F = F + E(J) * A(I,J)
  240    CONTINUE
C
         H = F / (H + H)
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = A(I,J)
            G = E(J) - H * F
            E(J) = G
C
            DO 260 K = 1, J
               A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
  260    CONTINUE
C
  270    DO 280 K = 1, L
  280    A(I,K) = SCALE * A(I,K)
C
  290    H = D(I)
         D(I) = A(I,I)
         A(I,I) = H
  300 CONTINUE
C
      RETURN
C     ********** LAST CARD OF DTRED1 **********
      END
      SUBROUTINE DTRED3 (N,NV,A,D,E,E2)
C
      INTEGER I,J,K,L,N,II,IZ,JK,NV
      DOUBLE PRECISION A(NV),D(N),E(N),E2(N)
      DOUBLE PRECISION F,G,H,HH,SCALE
C     DOUBLE PRECISION DSQRT,DABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS
C     A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX
C     USING ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
C          AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT,
C
C        A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
C          INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL
C          ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS.
C
C     ON OUTPUT-
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL
C          TRANSFORMATIONS USED IN THE REDUCTION,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C-----------------------------------------------------------------------
C
C     ********** FOR I=N STEP -1 UNTIL 1 DO -- **********
      DO  300 II = 1, N
         I = N + 1 - II
         L = I - 1
         IZ = (I * L) / 2
         H = 0.D0
         SCALE = 0.D0
         IF (L .LT. 1) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
            IZ = IZ + 1
            D(K) = A(IZ)
            SCALE = SCALE + DABS(D(K))
  120    CONTINUE
C
         IF (SCALE .NE. 0.D0) GO TO 140
  130    E(I) = 0.D0
         E2(I) = 0.D0
         GO TO 290
C
  140    DO 150 K = 1, L
            D(K) = D(K) / SCALE
            H = H + D(K) * D(K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = D(L)
         G = DSQRT(H)
         IF (F .GE. 0.D0) G = -G
         E(I) = SCALE * G
         H = H - F * G
         D(L) = F - G
         A(IZ) = SCALE * D(L)
         IF (L .EQ. 1) GO TO 290
         F = 0.D0
C
         DO 240 J = 1, L
            G = 0.D0
            JK = (J * (J-1)) / 2
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, L
               JK = JK + 1
               IF (K .GT. J) JK = JK + K - 2
               G = G + A(JK) * D(K)
  180       CONTINUE
C     ********** FORM ELEMENT OF P **********
            E(J) = G / H
            F = F + E(J) * D(J)
  240    CONTINUE
C
         HH = F / (H + H)
         JK = 0
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = D(J)
            G = E(J) - HH * F
            E(J) = G
C
            DO 260 K = 1, J
               JK = JK + 1
               A(JK) = A(JK) - F * E(K) - G * D(K)
  260    CONTINUE
C
  290    D(I) = A(IZ+1)
         A(IZ+1) = SCALE * DSQRT(H)
  300 CONTINUE
C
      RETURN
C     ********** LAST CARD OF DTRED3 **********
      END
      SUBROUTINE DTQL (N,D,E2,IERR)
C
      INTEGER I,J,L,M,N,II,L1,MML,IERR
      DOUBLE PRECISION D(N),E2(N)
      DOUBLE PRECISION B,C,F,G,H,P,R,S,MACHEP
      DOUBLE PRECISION DPMPAR
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        E2 HAS BEEN DESTROYED,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 50 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 .
C
                 MACHEP = DPMPAR(1)
C
C                **********
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E2(I-1) = E2(I)
C
      F = 0.D0
      B = 0.D0
      E2(N) = 0.D0
C
      DO 290 L = 1, N
         J = 0
         H = MACHEP * (DABS(D(L)) + DSQRT(E2(L)))
         IF (B .GT. H) GO TO 105
         B = H
         C = B * B
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
  105    DO 110 M = L, N
            IF (E2(M) .LE. C) GO TO 120
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 210
  130    IF (J .EQ. 50) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         L1 = L + 1
         S = DSQRT(E2(L))
         G = D(L)
         P = (D(L1) - G) / (2.D0 * S)
         R = DSQRT(P*P + 1.D0)
         IF (P .LT. 0.D0) R = -R
         D(L) = S / (P + R)
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     ********** RATIONAL QL TRANSFORMATION **********
         G = D(M)
         IF (G .EQ. 0.D0) G = B
         H = G
         S = 0.D0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            P = G * H
            R = P + E2(I)
            E2(I+1) = S * R
            S = E2(I) / R
            D(I+1) = H + S * (H + D(I))
            G = D(I) - E2(I) / G
            IF (G .EQ. 0.D0) G = B
            H = G * P / R
  200    CONTINUE
C
         E2(L) = S * G
         D(L) = H
C     ********** GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST **********
         IF (H .EQ. 0.D0) GO TO 210
         IF (DABS(E2(L)) .LE. DABS(C/H)) GO TO 210
         E2(L) = H * E2(L)
         IF (E2(L) .NE. 0.D0) GO TO 130
  210    P = D(L) + F
C     ********** ORDER EIGENVALUES **********
         IF (L .EQ. 1) GO TO 250
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. D(I-1)) GO TO 270
            D(I) = D(I-1)
  230    CONTINUE
C
  250    I = 1
  270    D(I) = P
  290 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 50 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF DTQL **********
      END
      SUBROUTINE DTRED2 (NM,N,A,D,E,Z)
C
      INTEGER I,J,K,L,N,II,NM,JP1
      DOUBLE PRECISION A(NM,N),D(N),E(N),Z(NM,N)
      DOUBLE PRECISION F,G,H,HH,SCALE
C     DOUBLE PRECISION DSQRT,DABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A
C     SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT-
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX
C          PRODUCED IN THE REDUCTION,
C
C        A AND Z MAY COINCIDE.  IF DISTINCT, A IS UNALTERED.
C
C-----------------------------------------------------------------------
C
      DO 100 I = 1, N
C
         DO 100 J = 1, I
            Z(I,J) = A(I,J)
  100 CONTINUE
C
      IF (N .EQ. 1) GO TO 320
C     ********** FOR I=N STEP -1 UNTIL 2 DO -- **********
      DO 300 II = 2, N
         I = N + 2 - II
         L = I - 1
         H = 0.D0
         SCALE = 0.D0
         IF (L .LT. 2) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
  120    SCALE = SCALE + DABS(Z(I,K))
C
         IF (SCALE .NE. 0.D0) GO TO 140
  130    E(I) = Z(I,L)
         GO TO 290
C
  140    DO 150 K = 1, L
            Z(I,K) = Z(I,K) / SCALE
            H = H + Z(I,K) * Z(I,K)
  150    CONTINUE
C
         F = Z(I,L)
         G = DSQRT(H)
         IF (F .GE. 0.D0) G = -G
         E(I) = SCALE * G
         H = H - F * G
         Z(I,L) = F - G
         F = 0.D0
C
         DO 240 J = 1, L
            Z(J,I) = Z(I,J) / H
            G = 0.D0
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, J
  180       G = G + Z(J,K) * Z(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + Z(K,J) * Z(I,K)
C     ********** FORM ELEMENT OF P **********
  220       E(J) = G / H
            F = F + E(J) * Z(I,J)
  240    CONTINUE
C
         HH = F / (H + H)
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = Z(I,J)
            G = E(J) - HH * F
            E(J) = G
C
            DO 260 K = 1, J
               Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)
  260    CONTINUE
C
  290    D(I) = H
  300 CONTINUE
C
  320 D(1) = 0.D0
      E(1) = 0.D0
C     ********** ACCUMULATION OF TRANSFORMATION MATRICES **********
      DO 500 I = 1, N
         L = I - 1
         IF (D(I) .EQ. 0.D0) GO TO 380
C
         DO 360 J = 1, L
            G = 0.D0
C
            DO 340 K = 1, L
  340       G = G + Z(I,K) * Z(K,J)
C
            DO 360 K = 1, L
               Z(K,J) = Z(K,J) - G * Z(K,I)
  360    CONTINUE
C
  380    D(I) = Z(I,I)
         Z(I,I) = 1.D0
         IF (L .LT. 1) GO TO 500
C
         DO 400 J = 1, L
            Z(I,J) = 0.D0
            Z(J,I) = 0.D0
  400    CONTINUE
C
  500 CONTINUE
C
      RETURN
C     ********** LAST CARD OF DTRED2 **********
      END
      SUBROUTINE DTQL2 (NM,N,D,E,Z,IERR)
C
      INTEGER I,J,K,L,M,N,II,L1,NM,MML,IERR
      DOUBLE PRECISION D(N),E(N),Z(NM,N)
      DOUBLE PRECISION B,C,F,G,H,P,R,S,MACHEP
      DOUBLE PRECISION DPMPAR
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
C     NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
C     WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
C     FULL MATRIX TO TRIDIAGONAL FORM.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY,
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C          THE IDENTITY MATRIX.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1,2,...,IERR-1,
C
C        E HAS BEEN DESTROYED,
C
C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 50 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN
C                MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE
C                FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 .
C
                 MACHEP = DPMPAR(1)
C
C                **********
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      F = 0.D0
      B = 0.D0
      E(N) = 0.D0
C
      DO 240 L = 1, N
         J = 0
         H = MACHEP * (DABS(D(L)) + DABS(E(L)))
         IF (B .LT. H) B = H
C     ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
         DO 110 M = L, N
            IF (DABS(E(M)) .LE. B) GO TO 120
C     ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 220
  130    IF (J .EQ. 50) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         L1 = L + 1
         G = D(L)
         P = (D(L1) - G) / (2.D0 * E(L))
         R = DSQRT(P*P + 1.D0)
         IF (P .LT. 0.D0) R = -R
         D(L) = E(L) / (P + R)
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     ********** QL TRANSFORMATION **********
         P = D(M)
         C = 1.D0
         S = 0.D0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            G = C * E(I)
            H = C * P
            IF (DABS(P) .LT. DABS(E(I))) GO TO 150
            C = E(I) / P
            R = DSQRT(C*C + 1.D0)
            E(I+1) = S * P * R
            S = C / R
            C = 1.D0 / R
            GO TO 160
  150       C = P / E(I)
            R = DSQRT(C*C + 1.D0)
            E(I+1) = S * E(I) * R
            S = 1.D0 / R
            C = C * S
  160       P = C * D(I) - S * G
            D(I+1) = H + S * (C * G + S * D(I))
C     ********** FORM VECTOR **********
            DO 180 K = 1, N
               H = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * H
               Z(K,I) = C * Z(K,I) - S * H
  180       CONTINUE
C
  200    CONTINUE
C
         E(L) = S * P
         D(L) = C * P
         IF (DABS(E(L)) .GT. B) GO TO 130
  220    D(L) = D(L) + F
  240 CONTINUE
C     ********** ORDER EIGENVALUES AND EIGENVECTORS **********
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
C
  300 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 50 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF DTQL2 **********
      END
      SUBROUTINE CEIG(IBAL,AR,AI,KA,N,WR,WI,IERR)
C-----------------------------------------------------------------------
C                EIGENVALUES OF COMPLEX MATRICES
C-----------------------------------------------------------------------
      REAL AR(KA,N), AI(KA,N), WR(N), WI(N)
C
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL CBAL(KA,N,AR,AI,LOW,IGH,WR)
      CALL CORTH(KA,N,LOW,IGH,AR,AI,WR,WI)
      CALL COMQR(KA,N,LOW,IGH,AR,AI,WR,WI,IERR)
      RETURN
      END
      SUBROUTINE CEIGV(IBAL,AR,AI,KA,N,WR,WI,ZR,ZI,IERR,TEMP)
C-----------------------------------------------------------------------
C          EIGENVALUES AND EIGENVECTORS OF COMPLEX MATRICES
C-----------------------------------------------------------------------
      REAL AR(KA,N),AI(KA,N),WR(N),WI(N),ZR(KA,N),ZI(KA,N),TEMP(*)
C----------------------
C     TEMP IS A TEMPORARY STORAGE AREA
C        DIMENSION(TEMP) .GE. 2*N    IF IBAL .EQ. 0
C        DIMENSION(TEMP) .GE. 3*N    IF IBAL .NE. 0
C----------------------
      I2 = 1
      I3 = N + 1
      I1 = N + I3
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL CBAL(KA,N,AR,AI,LOW,IGH,TEMP(I1))
      CALL CORTH(KA,N,LOW,IGH,AR,AI,TEMP(I2),TEMP(I3))
      CALL COMQR2(KA,N,LOW,IGH,TEMP(I2),TEMP(I3),AR,AI,WR,WI,ZR,ZI,IERR)
      IF (IERR .NE. 0) RETURN
      IF (IBAL .NE. 0) CALL CBABK2(KA,N,LOW,IGH,TEMP(I1),N,ZR,ZI)
      RETURN
      END
      SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE)
C
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
      REAL AR(NM,N),AI(NM,N),SCALE(N)
      REAL C,F,G,R,S,B2,RADIX
C     REAL ABS
      LOGICAL NOCONV
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
C     CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
C     EIGENVALUES WHENEVER POSSIBLE.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
C
C     ON OUTPUT-
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE BALANCED MATRIX,
C
C        LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
C          ARE EQUAL TO ZERO IF
C           (1) I IS GREATER THAN J AND
C           (2) J=1,...,LOW-1 OR I=IGH+1,...,N,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE
C           PERMUTATIONS AND SCALING FACTORS USED.
C
C     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
C     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
C     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
C     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
C        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
C                 = D(J,J)       J = LOW,...,IGH
C                 = P(J)         J = IGH+1,...,N.
C     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
C     THEN 1 TO LOW-1.
C
C     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
C
C     THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
C     CBAL  IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
C     K,L HAVE BEEN REVERSED.)
C
C-----------------------------------------------------------------------
C
C     ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION.
C
                 RADIX = IPMPAR(4)
C
C                **********
C
      B2 = RADIX * RADIX
      K = 1
      L = N
      GO TO 100
C     ********** IN-LINE PROCEDURE FOR ROW AND
C                COLUMN EXCHANGE **********
   20 SCALE(M) = J
      IF (J .EQ. M) GO TO 50
C
      DO 30 I = 1, L
         F = AR(I,J)
         AR(I,J) = AR(I,M)
         AR(I,M) = F
         F = AI(I,J)
         AI(I,J) = AI(I,M)
         AI(I,M) = F
   30 CONTINUE
C
      DO 40 I = K, N
         F = AR(J,I)
         AR(J,I) = AR(M,I)
         AR(M,I) = F
         F = AI(J,I)
         AI(J,I) = AI(M,I)
         AI(M,I) = F
   40 CONTINUE
C
   50 GO TO (80,130), IEXC
C     ********** SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C                AND PUSH THEM DOWN **********
   80 IF (L .EQ. 1) GO TO 280
      L = L - 1
C     ********** FOR J=L STEP -1 UNTIL 1 DO -- **********
  100 DO 120 JJ = 1, L
         J = L + 1 - JJ
C
         DO 110 I = 1, L
            IF (I .EQ. J) GO TO 110
            IF (AR(J,I) .NE. 0.0 .OR. AI(J,I) .NE. 0.0) GO TO 120
  110    CONTINUE
C
         M = L
         IEXC = 1
         GO TO 20
  120 CONTINUE
C
      GO TO 140
C     ********** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C                AND PUSH THEM LEFT **********
  130 K = K + 1
C
  140 DO 170 J = K, L
C
         DO 150 I = K, L
            IF (I .EQ. J) GO TO 150
            IF (AR(I,J) .NE. 0.0 .OR. AI(I,J) .NE. 0.0) GO TO 170
  150    CONTINUE
C
         M = K
         IEXC = 2
         GO TO 20
  170 CONTINUE
C     ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L **********
      DO 180 I = K, L
  180 SCALE(I) = 1.0
C     ********** ITERATIVE LOOP FOR NORM REDUCTION **********
  190 NOCONV = .FALSE.
C
      DO 270 I = K, L
         C = 0.0
         R = 0.0
C
         DO 200 J = K, L
            IF (J .EQ. I) GO TO 200
            C = C + ABS(AR(J,I)) + ABS(AI(J,I))
            R = R + ABS(AR(I,J)) + ABS(AI(I,J))
  200    CONTINUE
C     ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW **********
         IF (C .EQ. 0.0 .OR. R .EQ. 0.0) GO TO 270
         G = R / RADIX
         F = 1.0
         S = C + R
  210    IF (C .GE. G) GO TO 220
         F = F * RADIX
         C = C * B2
         GO TO 210
  220    G = R * RADIX
  230    IF (C .LT. G) GO TO 240
         F = F / RADIX
         C = C / B2
         GO TO 230
C     ********** NOW BALANCE **********
  240    IF ((C + R) / F .GE. 0.95 * S) GO TO 270
         G = 1.0 / F
         SCALE(I) = SCALE(I) * F
         NOCONV = .TRUE.
C
         DO 250 J = K, N
            AR(I,J) = AR(I,J) * G
            AI(I,J) = AI(I,J) * G
  250    CONTINUE
C
         DO 260 J = 1, L
            AR(J,I) = AR(J,I) * F
            AI(J,I) = AI(J,I) * F
  260    CONTINUE
C
  270 CONTINUE
C
      IF (NOCONV) GO TO 190
C
  280 LOW = K
      IGH = L
      RETURN
C     ********** LAST CARD OF CBAL **********
      END
      SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
C
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      REAL AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
      REAL F,G,H,FI,FR,SCALE
C     REAL SQRT,CABS,ABS
C     COMPLEX CMPLX
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C     THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
C     BY MARTIN AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C     UNITARY SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
C
C     ON OUTPUT-
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE HESSENBERG MATRIX.  INFORMATION
C          ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
C          IS STORED IN THE REMAINING TRIANGLES UNDER THE
C          HESSENBERG MATRIX,
C
C        ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
C          TRANSFORMATIONS.  ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C-----------------------------------------------------------------------
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         H = 0.0
         ORTR(M) = 0.0
         ORTI(M) = 0.0
         SCALE = 0.0
C     ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) **********
         DO 90 I = M, IGH
   90    SCALE = SCALE + ABS(AR(I,M-1)) + ABS(AI(I,M-1))
C
         IF (SCALE .EQ. 0.0) GO TO 180
         MP = M + IGH
C     ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
         DO 100 II = M, IGH
            I = MP - II
            ORTR(I) = AR(I,M-1) / SCALE
            ORTI(I) = AI(I,M-1) / SCALE
            H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
  100    CONTINUE
C
         G = SQRT(H)
         F = CABS(CMPLX(ORTR(M),ORTI(M)))
         IF (F .EQ. 0.0) GO TO 103
         H = H + F * G
         G = G / F
         ORTR(M) = (1.0 + G) * ORTR(M)
         ORTI(M) = (1.0 + G) * ORTI(M)
         GO TO 105
C
  103    ORTR(M) = G
         AR(M,M-1) = SCALE
C     ********** FORM (I-(U*UT)/H) * A **********
  105    DO 130 J = M, N
            FR = 0.0
            FI = 0.0
C     ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
            DO 110 II = M, IGH
               I = MP - II
               FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
               FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
  110       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 120 I = M, IGH
               AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
               AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
  120       CONTINUE
C
  130    CONTINUE
C     ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) **********
         DO 160 I = 1, IGH
            FR = 0.0
            FI = 0.0
C     ********** FOR J=IGH STEP -1 UNTIL M DO -- **********
            DO 140 JJ = M, IGH
               J = MP - JJ
               FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
               FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
  140       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 150 J = M, IGH
               AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
               AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
  150       CONTINUE
C
  160    CONTINUE
C
         ORTR(M) = SCALE * ORTR(M)
         ORTI(M) = SCALE * ORTI(M)
         AR(M,M-1) = -G * AR(M,M-1)
         AI(M,M-1) = -G * AI(M,M-1)
  180 CONTINUE
C
  200 RETURN
C     ********** LAST CARD OF CORTH **********
      END
      SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
C
      INTEGER I,J,L,N,EN,LL,NM,IGH,ITS,LOW,LP1,ENM1,IERR
      REAL HR(NM,N),HI(NM,N),WR(N),WI(N)
      REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,MACHEP
      COMPLEX Z3
      REAL SPMPAR
C     INTEGER MIN0
C     REAL SQRT,CABS,ABS,REAL,AIMAG
C     COMPLEX CSQRT,CMPLX
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C     ALGOL PROCEDURE  COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
C     AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
C     UPPER HESSENBERG MATRIX BY THE QR METHOD.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
C          INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
C          THE REDUCTION BY  CORTH, IF PERFORMED.
C
C     ON OUTPUT-
C
C        THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
C          DESTROYED.  THEREFORE, THEY MUST BE SAVED BEFORE
C          CALLING  COMQR  IF SUBSEQUENT CALCULATION OF
C          EIGENVECTORS IS TO BE PERFORMED,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     ARITHMETIC IS REAL EXCEPT FOR THE REPLACEMENT OF THE ALGOL
C     PROCEDURE CDIV BY COMPLEX DIVISION AND USE OF THE SUBROUTINES
C     CSQRT AND CMPLX IN COMPUTING COMPLEX SQUARE ROOTS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
                 MACHEP = SPMPAR(1)
C
C                **********
C
      IERR = 0
      IF (LOW .EQ. IGH) GO TO 180
C     ********** CREATE REAL SUBDIAGONAL ELEMENTS **********
      L = LOW + 1
C
      DO 170 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.0) GO TO 170
         NORM = CABS(CMPLX(HR(I,I-1),HI(I,I-1)))
         YR = HR(I,I-1) / NORM
         YI = HI(I,I-1) / NORM
         HR(I,I-1) = NORM
         HI(I,I-1) = 0.0
C
         DO 155 J = I, IGH
            SI = YR * HI(I,J) - YI * HR(I,J)
            HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
            HI(I,J) = SI
  155    CONTINUE
C
         DO 160 J = LOW, LL
            SI = YR * HI(J,I) + YI * HR(J,I)
            HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
            HI(J,I) = SI
  160    CONTINUE
C
  170 CONTINUE
C     ********** STORE ROOTS ISOLATED BY CBAL **********
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.0
      TI = 0.0
C     ********** SEARCH FOR NEXT EIGENVALUE **********
  220 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      ENM1 = EN - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW  -- **********
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         IF (ABS(HR(L,L-1)) .LE.
     X      MACHEP * (ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
     X             + ABS(HR(L,L)) +ABS(HI(L,L)))) GO TO 300
  260 CONTINUE
C     ********** FORM SHIFT **********
  300 IF (L .EQ. EN) GO TO 660
      IF (ITS .EQ. 30) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1)
      XI = HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.0 .AND. XI .EQ. 0.0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.0
      YI = (HI(ENM1,ENM1) - SI) / 2.0
      Z3 = CSQRT(CMPLX(YR**2-YI**2+XR,2.0*YR*YI+XI))
      ZZR = REAL(Z3)
      ZZI = AIMAG(Z3)
      IF (YR * ZZR + YI * ZZI .GE. 0.0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 Z3 = CMPLX(XR,XI) / CMPLX(YR+ZZR,YI+ZZI)
      SR = SR - REAL(Z3)
      SI = SI - AIMAG(Z3)
      GO TO 340
C     ********** FORM EXCEPTIONAL SHIFT **********
  320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
      SI = 0.0
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
C     ********** REDUCE TO TRIANGLE (ROWS) **********
      LP1 = L + 1
C
      DO 500 I = LP1, EN
         SR = HR(I,I-1)
         HR(I,I-1) = 0.0
         NORM = SQRT(HR(I-1,I-1)*HR(I-1,I-1)+HI(I-1,I-1)*HI(I-1,I-1)
     X               +SR*SR)
         XR = HR(I-1,I-1) / NORM
         WR(I-1) = XR
         XI = HI(I-1,I-1) / NORM
         WI(I-1) = XI
         HR(I-1,I-1) = NORM
         HI(I-1,I-1) = 0.0
         HI(I,I-1) = SR / NORM
C
         DO 490 J = I, EN
            YR = HR(I-1,J)
            YI = HI(I-1,J)
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
            HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
            HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
            HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  490    CONTINUE
C
  500 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.0) GO TO 540
      NORM = CABS(CMPLX(HR(EN,EN),SI))
      SR = HR(EN,EN) / NORM
      SI = SI / NORM
      HR(EN,EN) = NORM
      HI(EN,EN) = 0.0
C     ********** INVERSE OPERATION (COLUMNS) **********
  540 DO 600 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 580 I = L, J
            YR = HR(I,J-1)
            YI = 0.0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GO TO 560
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  580    CONTINUE
C
  600 CONTINUE
C
      IF (SI .EQ. 0.0) GO TO 240
C
      DO 630 I = L, EN
         YR = HR(I,EN)
         YI = HI(I,EN)
         HR(I,EN) = SR * YR - SI * YI
         HI(I,EN) = SR * YI + SI * YR
  630 CONTINUE
C
      GO TO 240
C     ********** A ROOT FOUND **********
  660 WR(EN) = HR(EN,EN) + TR
      WI(EN) = HI(EN,EN) + TI
      EN = ENM1
      GO TO 220
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = EN
 1001 RETURN
C     ********** LAST CARD OF COMQR **********
      END
      SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
C
      INTEGER I,J,K,M,N,II,NM,IGH,LOW
      REAL SCALE(N),ZR(NM,M),ZI(NM,M)
      REAL S
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
C     CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C     BALANCED MATRIX DETERMINED BY  CBAL.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY  CBAL,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
C          AND SCALING FACTORS USED BY  CBAL,
C
C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED,
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVECTORS TO BE
C          BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
C
C     ON OUTPUT-
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
C          IN THEIR FIRST M COLUMNS.
C
C-----------------------------------------------------------------------
      IF (M .EQ. 0) GO TO 200
      IF (IGH .EQ. LOW) GO TO 120
C
      DO 110 I = LOW, IGH
         S = SCALE(I)
C     ********** LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
C                IF THE FOREGOING STATEMENT IS REPLACED BY
C                S=1.0/SCALE(I). **********
         DO 100 J = 1, M
            ZR(I,J) = ZR(I,J) * S
            ZI(I,J) = ZI(I,J) * S
  100    CONTINUE
C
  110 CONTINUE
C     ********** FOR I=LOW-1 STEP -1 UNTIL 1,
C                IGH+1 STEP 1 UNTIL N DO -- **********
  120 DO 140 II = 1, N
         I = II
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GO TO 140
C
         DO 130 J = 1, M
            S = ZR(I,J)
            ZR(I,J) = ZR(K,J)
            ZR(K,J) = S
            S = ZI(I,J)
            ZI(I,J) = ZI(K,J)
            ZI(K,J) = S
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
C     ********** LAST CARD OF CBABK2 **********
      END
      SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
     *        ITS,LOW,LP1,ENM1,IEND,IERR
      REAL HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
     *       ORTR(IGH),ORTI(IGH)
      REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,MACHEP
      COMPLEX Z3
      REAL SPMPAR
C     INTEGER MIN0
C     REAL SQRT,CABS,ABS,REAL,AIMAG
C     COMPLEX CSQRT,CMPLX
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C     ALGOL PROCEDURE  COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
C     AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
C     METHOD.  THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
C     CAN ALSO BE FOUND IF  CORTH  HAS BEEN USED TO REDUCE
C     THIS GENERAL MATRIX TO HESSENBERG FORM.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C          FORMATIONS USED IN THE REDUCTION BY  CORTH, IF PERFORMED.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.  IF THE EIGENVECTORS
C          OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
C          ORTI(J) TO 0.0 FOR THESE ELEMENTS,
C
C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
C          INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
C          REDUCTION BY  CORTH, IF PERFORMED.  IF THE EIGENVECTORS OF
C          THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
C          ARBITRARY.
C
C     ON OUTPUT-
C
C        ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
C          HAVE BEEN DESTROYED,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N,
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVECTORS.  THE EIGENVECTORS
C          ARE UNNORMALIZED.  IF AN ERROR EXIT IS MADE, NONE OF
C          THE EIGENVECTORS HAS BEEN FOUND,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     ARITHMETIC IS REAL EXCEPT FOR THE REPLACEMENT OF THE ALGOL
C     PROCEDURE CDIV BY COMPLEX DIVISION AND USE OF THE SUBROUTINES
C     CSQRT AND CMPLX IN COMPUTING COMPLEX SQUARE ROOTS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
                 MACHEP = SPMPAR(1)
C
C                **********
C
      IERR = 0
C     ********** INITIALIZE EIGENVECTOR MATRIX **********
      DO 100 I = 1, N
C
         DO 100 J = 1, N
            ZR(I,J) = 0.0
            ZI(I,J) = 0.0
            IF (I .EQ. J) ZR(I,J) = 1.0
  100 CONTINUE
C     ********** FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
C                FROM THE INFORMATION LEFT BY CORTH **********
      IEND = IGH - LOW - 1
      IF (IEND) 180, 150, 105
C     ********** FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- **********
  105 DO 140 II = 1, IEND
         I = IGH - II
         IF (ORTR(I) .EQ. 0.0 .AND. ORTI(I) .EQ. 0.0) GO TO 140
         IF (HR(I,I-1) .EQ. 0.0 .AND. HI(I,I-1) .EQ. 0.0) GO TO 140
C     ********** NORM BELOW IS NEGATIVE OF H FORMED IN CORTH **********
         NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
         IP1 = I + 1
C
         DO 110 K = IP1, IGH
            ORTR(K) = HR(K,I-1)
            ORTI(K) = HI(K,I-1)
  110    CONTINUE
C
         DO 130 J = I, IGH
            SR = 0.0
            SI = 0.0
C
            DO 115 K = I, IGH
               SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
               SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
  115       CONTINUE
C
            SR = SR / NORM
            SI = SI / NORM
C
            DO 120 K = I, IGH
               ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
               ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
  120       CONTINUE
C
  130    CONTINUE
C
  140 CONTINUE
C     ********** CREATE REAL SUBDIAGONAL ELEMENTS **********
  150 L = LOW + 1
C
      DO 170 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.0) GO TO 170
         NORM = CABS(CMPLX(HR(I,I-1),HI(I,I-1)))
         YR = HR(I,I-1) / NORM
         YI = HI(I,I-1) / NORM
         HR(I,I-1) = NORM
         HI(I,I-1) = 0.0
C
         DO 155 J = I, N
            SI = YR * HI(I,J) - YI * HR(I,J)
            HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
            HI(I,J) = SI
  155    CONTINUE
C
         DO 160 J = 1, LL
            SI = YR * HI(J,I) + YI * HR(J,I)
            HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
            HI(J,I) = SI
  160    CONTINUE
C
         DO 165 J = LOW, IGH
            SI = YR * ZI(J,I) + YI * ZR(J,I)
            ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
            ZI(J,I) = SI
  165    CONTINUE
C
  170 CONTINUE
C     ********** STORE ROOTS ISOLATED BY CBAL **********
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.0
      TI = 0.0
C     ********** SEARCH FOR NEXT EIGENVALUE **********
  220 IF (EN .LT. LOW) GO TO 680
      ITS = 0
      ENM1 = EN - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         IF (ABS(HR(L,L-1)) .LE.
     X      MACHEP * (ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1))
     X             + ABS(HR(L,L)) +ABS(HI(L,L)))) GO TO 300
  260 CONTINUE
C     ********** FORM SHIFT **********
  300 IF (L .EQ. EN) GO TO 660
      IF (ITS .EQ. 30) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1)
      XI = HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.0 .AND. XI .EQ. 0.0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.0
      YI = (HI(ENM1,ENM1) - SI) / 2.0
      Z3 = CSQRT(CMPLX(YR**2-YI**2+XR,2.0*YR*YI+XI))
      ZZR = REAL(Z3)
      ZZI = AIMAG(Z3)
      IF (YR * ZZR + YI * ZZI .GE. 0.0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 Z3 = CMPLX(XR,XI) / CMPLX(YR+ZZR,YI+ZZI)
      SR = SR - REAL(Z3)
      SI = SI - AIMAG(Z3)
      GO TO 340
C     ********** FORM EXCEPTIONAL SHIFT **********
  320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2))
      SI = 0.0
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
C     ********** REDUCE TO TRIANGLE (ROWS) **********
      LP1 = L + 1
C
      DO 500 I = LP1, EN
         SR = HR(I,I-1)
         HR(I,I-1) = 0.0
         NORM = SQRT(HR(I-1,I-1)*HR(I-1,I-1)+HI(I-1,I-1)*HI(I-1,I-1)
     X               +SR*SR)
         XR = HR(I-1,I-1) / NORM
         WR(I-1) = XR
         XI = HI(I-1,I-1) / NORM
         WI(I-1) = XI
         HR(I-1,I-1) = NORM
         HI(I-1,I-1) = 0.0
         HI(I,I-1) = SR / NORM
C
         DO 490 J = I, N
            YR = HR(I-1,J)
            YI = HI(I-1,J)
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
            HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
            HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
            HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  490    CONTINUE
C
  500 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.0) GO TO 540
      NORM = CABS(CMPLX(HR(EN,EN),SI))
      SR = HR(EN,EN) / NORM
      SI = SI / NORM
      HR(EN,EN) = NORM
      HI(EN,EN) = 0.0
      IF (EN .EQ. N) GO TO 540
      IP1 = EN + 1
C
      DO 520 J = IP1, N
         YR = HR(EN,J)
         YI = HI(EN,J)
         HR(EN,J) = SR * YR + SI * YI
         HI(EN,J) = SR * YI - SI * YR
  520 CONTINUE
C     ********** INVERSE OPERATION (COLUMNS) **********
  540 DO 600 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 580 I = 1, J
            YR = HR(I,J-1)
            YI = 0.0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GO TO 560
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  580    CONTINUE
C
         DO 590 I = LOW, IGH
            YR = ZR(I,J-1)
            YI = ZI(I,J-1)
            ZZR = ZR(I,J)
            ZZI = ZI(I,J)
            ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
            ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  590    CONTINUE
C
  600 CONTINUE
C
      IF (SI .EQ. 0.0) GO TO 240
C
      DO 630 I = 1, EN
         YR = HR(I,EN)
         YI = HI(I,EN)
         HR(I,EN) = SR * YR - SI * YI
         HI(I,EN) = SR * YI + SI * YR
  630 CONTINUE
C
      DO 640 I = LOW, IGH
         YR = ZR(I,EN)
         YI = ZI(I,EN)
         ZR(I,EN) = SR * YR - SI * YI
         ZI(I,EN) = SR * YI + SI * YR
  640 CONTINUE
C
      GO TO 240
C     ********** A ROOT FOUND **********
  660 HR(EN,EN) = HR(EN,EN) + TR
      WR(EN) = HR(EN,EN)
      HI(EN,EN) = HI(EN,EN) + TI
      WI(EN) = HI(EN,EN)
      EN = ENM1
      GO TO 220
C     ********** ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM **********
  680 NORM = 0.0
C
      DO 720 I = 1, N
C
         DO 720 J = I, N
            NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J))
  720 CONTINUE
C
      IF (N .EQ. 1 .OR. NORM .EQ. 0.0) GO TO 1001
C     ********** FOR EN=N STEP -1 UNTIL 2 DO -- **********
      DO 800 NN = 2, N
         EN = N + 2 - NN
         XR = WR(EN)
         XI = WI(EN)
         ENM1 = EN - 1
C     ********** FOR I=EN-1 STEP -1 UNTIL 1 DO -- **********
         DO 780 II = 1, ENM1
            I = EN - II
            ZZR = HR(I,EN)
            ZZI = HI(I,EN)
            IF (I .EQ. ENM1) GO TO 760
            IP1 = I + 1
C
            DO 740 J = IP1, ENM1
               ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
               ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
  740       CONTINUE
C
  760       YR = XR - WR(I)
            YI = XI - WI(I)
            IF (YR .EQ. 0.0 .AND. YI .EQ. 0.0) YR = MACHEP * NORM
            Z3 = CMPLX(ZZR,ZZI) / CMPLX(YR,YI)
            HR(I,EN) = REAL(Z3)
            HI(I,EN) = AIMAG(Z3)
  780    CONTINUE
C
  800 CONTINUE
C     ********** END BACKSUBSTITUTION **********
      ENM1 = N - 1
C     ********** VECTORS OF ISOLATED ROOTS **********
      DO  840 I = 1, ENM1
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
         IP1 = I + 1
C
         DO 820 J = IP1, N
            ZR(I,J) = HR(I,J)
            ZI(I,J) = HI(I,J)
  820    CONTINUE
C
  840 CONTINUE
C     ********** MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW+1 DO -- **********
      DO 880 JJ = LOW, ENM1
         J = N + LOW - JJ
         M = MIN0(J-1,IGH)
C
         DO 880 I = LOW, IGH
            ZZR = ZR(I,J)
            ZZI = ZI(I,J)
C
            DO 860 K = LOW, M
               ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
               ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
  860       CONTINUE
C
            ZR(I,J) = ZZR
            ZI(I,J) = ZZI
  880 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = EN
 1001 RETURN
C     ********** LAST CARD OF COMQR2 **********
      END
      SUBROUTINE DCEIG(IBAL,AR,AI,KA,N,WR,WI,IERR)
C-----------------------------------------------------------------------
C            EIGENVALUES OF DOUBLE PRECISION COMPLEX MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION AR(KA,N), AI(KA,N), WR(N), WI(N)
C
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL DCBAL(KA,N,AR,AI,LOW,IGH,WR)
      CALL DCORTH(KA,N,LOW,IGH,AR,AI,WR,WI)
      CALL DCOMQR(KA,N,LOW,IGH,AR,AI,WR,WI,IERR)
      RETURN
      END
      SUBROUTINE DCEIGV (IBAL,AR,AI,KA,N,WR,WI,ZR,ZI,IERR,TEMP)
C-----------------------------------------------------------------------
C                     EIGENVALUES AND EIGENVECTORS
C                 OF DOUBLE PRECISION COMPLEX MATRICES
C-----------------------------------------------------------------------
      DOUBLE PRECISION AR(KA,N),AI(KA,N),WR(N),WI(N),ZR(KA,N),ZI(KA,N),
     *                 TEMP(*)
C----------------------
C     TEMP IS A TEMPORARY STORAGE AREA
C        DIMENSION(TEMP) .GE. 2*N    IF IBAL .EQ. 0
C        DIMENSION(TEMP) .GE. 3*N    IF IBAL .NE. 0
C----------------------
      I2 = 1
      I3 = N + 1
      I1 = N + I3
      LOW = 1
      IGH = N
      IF (IBAL .NE. 0) CALL DCBAL(KA,N,AR,AI,LOW,IGH,TEMP(I1))
      CALL DCORTH(KA,N,LOW,IGH,AR,AI,TEMP(I2),TEMP(I3))
      CALL DCMQR2(KA,N,LOW,IGH,TEMP(I2),TEMP(I3),AR,AI,WR,WI,
     *                ZR,ZI,IERR)
      IF (IERR .NE. 0) RETURN
      IF (IBAL .NE. 0) CALL DCBABK(KA,N,LOW,IGH,TEMP(I1),N,ZR,ZI)
      RETURN
      END
      SUBROUTINE DCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
C
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
      DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N)
      DOUBLE PRECISION C,F,G,R,S,B2,RADIX
      LOGICAL NOCONV
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
C     CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     DCBAL BALANCES A DOUBLE PRECISION COMPLEX MATRIX AND
C     ISOLATES EIGENVALUES WHENEVER POSSIBLE.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
C
C     ON OUTPUT-
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE BALANCED MATRIX,
C
C        LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
C          ARE EQUAL TO ZERO IF
C           (1) I IS GREATER THAN J AND
C           (2) J=1,...,LOW-1 OR I=IGH+1,...,N,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE
C           PERMUTATIONS AND SCALING FACTORS USED.
C
C     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
C     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
C     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
C     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
C        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
C                 = D(J,J)       J = LOW,...,IGH
C                 = P(J)         J = IGH+1,...,N.
C     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
C     THEN 1 TO LOW-1.
C
C     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
C
C     THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
C     DCBAL IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
C     K,L HAVE BEEN REVERSED.)
C
C-----------------------------------------------------------------------
C
C     ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION.
C
                 RADIX = IPMPAR(4)
C
C                **********
C
      B2 = RADIX * RADIX
      K = 1
      L = N
      GO TO 100
C     ********** IN-LINE PROCEDURE FOR ROW AND
C                COLUMN EXCHANGE **********
   20 SCALE(M) = J
      IF (J .EQ. M) GO TO 50
C
      DO 30 I = 1, L
         F = AR(I,J)
         AR(I,J) = AR(I,M)
         AR(I,M) = F
         F = AI(I,J)
         AI(I,J) = AI(I,M)
         AI(I,M) = F
   30 CONTINUE
C
      DO 40 I = K, N
         F = AR(J,I)
         AR(J,I) = AR(M,I)
         AR(M,I) = F
         F = AI(J,I)
         AI(J,I) = AI(M,I)
         AI(M,I) = F
   40 CONTINUE
C
   50 GO TO (80,130), IEXC
C     ********** SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C                AND PUSH THEM DOWN **********
   80 IF (L .EQ. 1) GO TO 280
      L = L - 1
C     ********** FOR J=L STEP -1 UNTIL 1 DO -- **********
  100 DO 120 JJ = 1, L
         J = L + 1 - JJ
C
         DO 110 I = 1, L
            IF (I .EQ. J) GO TO 110
            IF (AR(J,I) .NE. 0.D0 .OR. AI(J,I) .NE. 0.D0) GO TO 120
  110    CONTINUE
C
         M = L
         IEXC = 1
         GO TO 20
  120 CONTINUE
C
      GO TO 140
C     ********** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C                AND PUSH THEM LEFT **********
  130 K = K + 1
C
  140 DO 170 J = K, L
C
         DO 150 I = K, L
            IF (I .EQ. J) GO TO 150
            IF (AR(I,J) .NE. 0.D0 .OR. AI(I,J) .NE. 0.D0) GO TO 170
  150    CONTINUE
C
         M = K
         IEXC = 2
         GO TO 20
  170 CONTINUE
C     ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L **********
      DO 180 I = K, L
  180 SCALE(I) = 1.D0
C     ********** ITERATIVE LOOP FOR NORM REDUCTION **********
  190 NOCONV = .FALSE.
C
      DO 270 I = K, L
         C = 0.D0
         R = 0.D0
C
         DO 200 J = K, L
            IF (J .EQ. I) GO TO 200
            C = C + DABS(AR(J,I)) + DABS(AI(J,I))
            R = R + DABS(AR(I,J)) + DABS(AI(I,J))
  200    CONTINUE
C     ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW **********
         IF (C .EQ. 0.D0 .OR. R .EQ. 0.D0) GO TO 270
         G = R / RADIX
         F = 1.D0
         S = C + R
  210    IF (C .GE. G) GO TO 220
         F = F * RADIX
         C = C * B2
         GO TO 210
  220    G = R * RADIX
  230    IF (C .LT. G) GO TO 240
         F = F / RADIX
         C = C / B2
         GO TO 230
C     ********** NOW BALANCE **********
  240    IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270
         G = 1.D0 / F
         SCALE(I) = SCALE(I) * F
         NOCONV = .TRUE.
C
         DO 250 J = K, N
            AR(I,J) = AR(I,J) * G
            AI(I,J) = AI(I,J) * G
  250    CONTINUE
C
         DO 260 J = 1, L
            AR(J,I) = AR(J,I) * F
            AI(J,I) = AI(J,I) * F
  260    CONTINUE
C
  270 CONTINUE
C
      IF (NOCONV) GO TO 190
C
  280 LOW = K
      IGH = L
      RETURN
C     ********** LAST CARD OF DCBAL **********
      END
      SUBROUTINE DCORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
C
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
      DOUBLE PRECISION F,G,H,FI,FR,SCALE
      DOUBLE PRECISION DCPABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C     THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
C     BY MARTIN AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     GIVEN A DOUBLE PRECISION COMPLEX MATRIX, DCORTH
C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C     UNITARY SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE DCBAL.  IF DCBAL HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
C
C     ON OUTPUT-
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE HESSENBERG MATRIX.  INFORMATION
C          ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
C          IS STORED IN THE REMAINING TRIANGLES UNDER THE
C          HESSENBERG MATRIX,
C
C        ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
C          TRANSFORMATIONS.  ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C-----------------------------------------------------------------------
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         H = 0.D0
         ORTR(M) = 0.D0
         ORTI(M) = 0.D0
         SCALE = 0.D0
C     ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) **********
         DO 90 I = M, IGH
   90    SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
C
         IF (SCALE .EQ. 0.D0) GO TO 180
         MP = M + IGH
C     ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
         DO 100 II = M, IGH
            I = MP - II
            ORTR(I) = AR(I,M-1) / SCALE
            ORTI(I) = AI(I,M-1) / SCALE
            H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
  100    CONTINUE
C
         G = DSQRT(H)
         F = DCPABS(ORTR(M),ORTI(M))
         IF (F .EQ. 0.D0) GO TO 103
         H = H + F * G
         G = G / F
         ORTR(M) = (1.D0 + G) * ORTR(M)
         ORTI(M) = (1.D0 + G) * ORTI(M)
         GO TO 105
C
  103    ORTR(M) = G
         AR(M,M-1) = SCALE
C     ********** FORM (I-(U*UT)/H) * A **********
  105    DO 130 J = M, N
            FR = 0.D0
            FI = 0.D0
C     ********** FOR I=IGH STEP -1 UNTIL M DO -- **********
            DO 110 II = M, IGH
               I = MP - II
               FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
               FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
  110       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 120 I = M, IGH
               AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
               AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
  120       CONTINUE
C
  130    CONTINUE
C     ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) **********
         DO 160 I = 1, IGH
            FR = 0.D0
            FI = 0.D0
C     ********** FOR J=IGH STEP -1 UNTIL M DO -- **********
            DO 140 JJ = M, IGH
               J = MP - JJ
               FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
               FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
  140       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 150 J = M, IGH
               AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
               AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
  150       CONTINUE
C
  160    CONTINUE
C
         ORTR(M) = SCALE * ORTR(M)
         ORTI(M) = SCALE * ORTI(M)
         AR(M,M-1) = -G * AR(M,M-1)
         AI(M,M-1) = -G * AI(M,M-1)
  180 CONTINUE
C
  200 RETURN
C     ********** LAST CARD OF DCORTH **********
      END
      SUBROUTINE DCOMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
C
      INTEGER I,J,L,N,EN,LL,NM,IGH,ITS,LOW,LP1,ENM1,IERR
      DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N)
      DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,MACHEP
      DOUBLE PRECISION R2,W(2),Z(2)
      DOUBLE PRECISION DPMPAR,DCPABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C     ALGOL PROCEDURE  COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
C     AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A DOUBLE PRECISION
C     COMPLEX UPPER HESSENBERG MATRIX BY THE QR METHOD.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE DCBAL.  IF DCBAL HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
C          INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
C          THE REDUCTION BY DCORTH, IF PERFORMED.
C
C     ON OUTPUT-
C
C        THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
C          DESTROYED.  THEREFORE, THEY MUST BE SAVED BEFORE
C          CALLING DCOMQR IF SUBSEQUENT CALCULATION OF
C          EIGENVECTORS IS TO BE PERFORMED,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 50 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
                 MACHEP = DPMPAR(1)
C
C                **********
C
      IERR = 0
      IF (LOW .EQ. IGH) GO TO 180
C     ********** CREATE REAL SUBDIAGONAL ELEMENTS **********
      L = LOW + 1
C
      DO 170 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.D0) GO TO 170
         NORM = DCPABS(HR(I,I-1),HI(I,I-1))
         YR = HR(I,I-1) / NORM
         YI = HI(I,I-1) / NORM
         HR(I,I-1) = NORM
         HI(I,I-1) = 0.D0
C
         DO 155 J = I, IGH
            SI = YR * HI(I,J) - YI * HR(I,J)
            HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
            HI(I,J) = SI
  155    CONTINUE
C
         DO 160 J = LOW, LL
            SI = YR * HI(J,I) + YI * HR(J,I)
            HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
            HI(J,I) = SI
  160    CONTINUE
C
  170 CONTINUE
C     ********** STORE ROOTS ISOLATED BY DCBAL **********
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.D0
      TI = 0.D0
C     ********** SEARCH FOR NEXT EIGENVALUE **********
  220 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      ENM1 = EN - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW  -- **********
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         IF (DABS(HR(L,L-1)) .LE.
     X      MACHEP * (DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
     X             + DABS(HR(L,L)) + DABS(HI(L,L)))) GO TO 300
  260 CONTINUE
C     ********** FORM SHIFT **********
  300 IF (L .EQ. EN) GO TO 660
      IF (ITS .EQ. 50) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20 .OR. ITS .EQ. 30) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1)
      XI = HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.D0 .AND. XI .EQ. 0.D0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.D0
      YI = (HI(ENM1,ENM1) - SI) / 2.D0
      Z(1) = YR*YR - YI*YI + XR
      Z(2) = 2.D0*YR*YI + XI
      CALL DCSQRT(Z,W)
      ZZR = W(1)
      ZZI = W(2)
      IF (YR * ZZR + YI * ZZI .GE. 0.D0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 Z(1) = YR + ZZR
      Z(2) = YI + ZZI
      R2 = Z(1)**2 + Z(2)**2
      SR = SR - (XR*Z(1) + XI*Z(2))/R2
      SI = SI - (XI*Z(1) - XR*Z(2))/R2
      GO TO 340
C     ********** FORM EXCEPTIONAL SHIFT **********
  320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
      SI = 0.D0
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
C     ********** REDUCE TO TRIANGLE (ROWS) **********
      LP1 = L + 1
C
      DO 500 I = LP1, EN
         SR = HR(I,I-1)
         HR(I,I-1) = 0.D0
         NORM = DSQRT(HR(I-1,I-1)*HR(I-1,I-1)+HI(I-1,I-1)*HI(I-1,I-1)
     X               + SR*SR)
         XR = HR(I-1,I-1) / NORM
         WR(I-1) = XR
         XI = HI(I-1,I-1) / NORM
         WI(I-1) = XI
         HR(I-1,I-1) = NORM
         HI(I-1,I-1) = 0.D0
         HI(I,I-1) = SR / NORM
C
         DO 490 J = I, EN
            YR = HR(I-1,J)
            YI = HI(I-1,J)
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
            HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
            HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
            HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  490    CONTINUE
C
  500 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.D0) GO TO 540
      NORM = DCPABS(HR(EN,EN),SI)
      SR = HR(EN,EN) / NORM
      SI = SI / NORM
      HR(EN,EN) = NORM
      HI(EN,EN) = 0.D0
C     ********** INVERSE OPERATION (COLUMNS) **********
  540 DO 600 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 580 I = L, J
            YR = HR(I,J-1)
            YI = 0.D0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GO TO 560
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  580    CONTINUE
C
  600 CONTINUE
C
      IF (SI .EQ. 0.D0) GO TO 240
C
      DO 630 I = L, EN
         YR = HR(I,EN)
         YI = HI(I,EN)
         HR(I,EN) = SR * YR - SI * YI
         HI(I,EN) = SR * YI + SI * YR
  630 CONTINUE
C
      GO TO 240
C     ********** A ROOT FOUND **********
  660 WR(EN) = HR(EN,EN) + TR
      WI(EN) = HI(EN,EN) + TI
      EN = ENM1
      GO TO 220
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 50 ITERATIONS **********
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE DCBABK (NM,N,LOW,IGH,SCALE,M,ZR,ZI)
C
      INTEGER I,J,K,M,N,II,NM,IGH,LOW
      DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M)
      DOUBLE PRECISION S
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
C     CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A DOUBLE PRECISION
C     COMPLEX MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C     BALANCED MATRIX DETERMINED BY DCBAL.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY DCBAL,
C
C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
C          AND SCALING FACTORS USED BY DCBAL,
C
C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED,
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVECTORS TO BE
C          BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
C
C     ON OUTPUT-
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
C          IN THEIR FIRST M COLUMNS.
C
C-----------------------------------------------------------------------
      IF (M .EQ. 0) GO TO 200
      IF (IGH .EQ. LOW) GO TO 120
C
      DO 110 I = LOW, IGH
         S = SCALE(I)
C     ********** LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
C                IF THE FOREGOING STATEMENT IS REPLACED BY
C                S=1.0/SCALE(I). **********
         DO 100 J = 1, M
            ZR(I,J) = ZR(I,J) * S
            ZI(I,J) = ZI(I,J) * S
  100    CONTINUE
C
  110 CONTINUE
C
C     ********** FOR I=LOW-1 STEP -1 UNTIL 1,
C                IGH+1 STEP 1 UNTIL N DO -- **********
  120 DO 140 II = 1, N
         I = II
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GO TO 140
C
         DO 130 J = 1, M
            S = ZR(I,J)
            ZR(I,J) = ZR(K,J)
            ZR(K,J) = S
            S = ZI(I,J)
            ZI(I,J) = ZI(K,J)
            ZI(K,J) = S
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
C     ********** LAST CARD OF DCBABK **********
      END
      SUBROUTINE DCMQR2 (NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
     *        ITS,LOW,LP1,ENM1,IEND,IERR
      DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
     *                 ORTR(IGH),ORTI(IGH)
      DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,MACHEP
      DOUBLE PRECISION R2,W(2),Z(2)
      DOUBLE PRECISION DPMPAR,DCPABS
C-----------------------------------------------------------------------
C
C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C     ALGOL PROCEDURE  COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
C     AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS OF
C     A DOUBLE PRECISION COMPLEX UPPER HESSENBERG MATRIX BY THE
C     QR METHOD.  THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
C     CAN ALSO BE FOUND IF DCORTH HAS BEEN USED TO REDUCE
C     THIS GENERAL MATRIX TO HESSENBERG FORM.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE DCBAL.  IF DCBAL HAS NOT BEEN USED,
C          SET LOW=1, IGH=N,
C
C        ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C          FORMATIONS USED IN THE REDUCTION BY DCORTH, IF PERFORMED.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.  IF THE EIGENVECTORS
C          OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
C          ORTI(J) TO 0.0 FOR THESE ELEMENTS,
C
C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
C          INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
C          REDUCTION BY DCORTH, IF PERFORMED.  IF THE EIGENVECTORS OF
C          THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
C          ARBITRARY.
C
C     ON OUTPUT-
C
C        ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
C          HAVE BEEN DESTROYED,
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N,
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVECTORS.  THE EIGENVECTORS
C          ARE UNNORMALIZED.  IF AN ERROR EXIT IS MADE, NONE OF
C          THE EIGENVECTORS HAS BEEN FOUND,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 50 ITERATIONS.
C
C-----------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
                 MACHEP = DPMPAR(1)
C
C                **********
C
      IERR = 0
C     ********** INITIALIZE EIGENVECTOR MATRIX **********
      DO 100 I = 1, N
C
         DO 100 J = 1, N
            ZR(I,J) = 0.D0
            ZI(I,J) = 0.D0
            IF (I .EQ. J) ZR(I,J) = 1.D0
  100 CONTINUE
C     ********** FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
C                FROM THE INFORMATION LEFT BY DCORTH **********
      IEND = IGH - LOW - 1
      IF (IEND) 180, 150, 105
C     ********** FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- **********
  105 DO 140 II = 1, IEND
         I = IGH - II
         IF (ORTR(I) .EQ. 0.D0 .AND. ORTI(I) .EQ. 0.D0) GO TO 140
         IF (HR(I,I-1) .EQ. 0.D0 .AND. HI(I,I-1) .EQ. 0.D0) GO TO 140
C     ********** NORM BELOW IS NEGATIVE OF H FORMED IN DCORTH **********
         NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
         IP1 = I + 1
C
         DO 110 K = IP1, IGH
            ORTR(K) = HR(K,I-1)
            ORTI(K) = HI(K,I-1)
  110    CONTINUE
C
         DO 130 J = I, IGH
            SR = 0.D0
            SI = 0.D0
C
            DO 115 K = I, IGH
               SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
               SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
  115       CONTINUE
C
            SR = SR / NORM
            SI = SI / NORM
C
            DO 120 K = I, IGH
               ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
               ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
  120       CONTINUE
C
  130    CONTINUE
C
  140 CONTINUE
C     ********** CREATE REAL SUBDIAGONAL ELEMENTS **********
  150 L = LOW + 1
C
      DO 170 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.D0) GO TO 170
         NORM = DCPABS(HR(I,I-1),HI(I,I-1))
         YR = HR(I,I-1) / NORM
         YI = HI(I,I-1) / NORM
         HR(I,I-1) = NORM
         HI(I,I-1) = 0.D0
C
         DO 155 J = I, N
            SI = YR * HI(I,J) - YI * HR(I,J)
            HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
            HI(I,J) = SI
  155    CONTINUE
C
         DO 160 J = 1, LL
            SI = YR * HI(J,I) + YI * HR(J,I)
            HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
            HI(J,I) = SI
  160    CONTINUE
C
         DO 165 J = LOW, IGH
            SI = YR * ZI(J,I) + YI * ZR(J,I)
            ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
            ZI(J,I) = SI
  165    CONTINUE
C
  170 CONTINUE
C     ********** STORE ROOTS ISOLATED BY DCBAL **********
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.D0
      TI = 0.D0
C     ********** SEARCH FOR NEXT EIGENVALUE **********
  220 IF (EN .LT. LOW) GO TO 680
      ITS = 0
      ENM1 = EN - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         IF (DABS(HR(L,L-1)) .LE.
     X      MACHEP * (DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
     X             + DABS(HR(L,L)) + DABS(HI(L,L)))) GO TO 300
  260 CONTINUE
C     ********** FORM SHIFT **********
  300 IF (L .EQ. EN) GO TO 660
      IF (ITS .EQ. 50) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20 .OR. ITS .EQ. 30) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1)
      XI = HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.D0 .AND. XI .EQ. 0.D0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.D0
      YI = (HI(ENM1,ENM1) - SI) / 2.D0
      Z(1) = YR*YR - YI*YI + XR
      Z(2) = 2.D0*YR*YI + XI
      CALL DCSQRT(Z,W)
      ZZR = W(1)
      ZZI = W(2)
      IF (YR * ZZR + YI * ZZI .GE. 0.D0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 Z(1) = YR + ZZR
      Z(2) = YI + ZZI
      R2 = Z(1)**2 + Z(2)**2
      SR = SR - (XR*Z(1) + XI*Z(2))/R2
      SI = SI - (XI*Z(1) - XR*Z(2))/R2
      GO TO 340
C     ********** FORM EXCEPTIONAL SHIFT **********
  320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
      SI = 0.D0
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
C     ********** REDUCE TO TRIANGLE (ROWS) **********
      LP1 = L + 1
C
      DO 500 I = LP1, EN
         SR = HR(I,I-1)
         HR(I,I-1) = 0.D0
         NORM = DSQRT(HR(I-1,I-1)*HR(I-1,I-1)+HI(I-1,I-1)*HI(I-1,I-1)
     X               + SR*SR)
         XR = HR(I-1,I-1) / NORM
         WR(I-1) = XR
         XI = HI(I-1,I-1) / NORM
         WI(I-1) = XI
         HR(I-1,I-1) = NORM
         HI(I-1,I-1) = 0.D0
         HI(I,I-1) = SR / NORM
C
         DO 490 J = I, N
            YR = HR(I-1,J)
            YI = HI(I-1,J)
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
            HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
            HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
            HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  490    CONTINUE
C
  500 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.D0) GO TO 540
      NORM = DCPABS(HR(EN,EN),SI)
      SR = HR(EN,EN) / NORM
      SI = SI / NORM
      HR(EN,EN) = NORM
      HI(EN,EN) = 0.D0
      IF (EN .EQ. N) GO TO 540
      IP1 = EN + 1
C
      DO 520 J = IP1, N
         YR = HR(EN,J)
         YI = HI(EN,J)
         HR(EN,J) = SR * YR + SI * YI
         HI(EN,J) = SR * YI - SI * YR
  520 CONTINUE
C     ********** INVERSE OPERATION (COLUMNS) **********
  540 DO 600 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 580 I = 1, J
            YR = HR(I,J-1)
            YI = 0.D0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GO TO 560
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  580    CONTINUE
C
         DO 590 I = LOW, IGH
            YR = ZR(I,J-1)
            YI = ZI(I,J-1)
            ZZR = ZR(I,J)
            ZZI = ZI(I,J)
            ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
            ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  590    CONTINUE
C
  600 CONTINUE
C
      IF (SI .EQ. 0.D0) GO TO 240
C
      DO 630 I = 1, EN
         YR = HR(I,EN)
         YI = HI(I,EN)
         HR(I,EN) = SR * YR - SI * YI
         HI(I,EN) = SR * YI + SI * YR
  630 CONTINUE
C
      DO 640 I = LOW, IGH
         YR = ZR(I,EN)
         YI = ZI(I,EN)
         ZR(I,EN) = SR * YR - SI * YI
         ZI(I,EN) = SR * YI + SI * YR
  640 CONTINUE
C
      GO TO 240
C     ********** A ROOT FOUND **********
  660 HR(EN,EN) = HR(EN,EN) + TR
      WR(EN) = HR(EN,EN)
      HI(EN,EN) = HI(EN,EN) + TI
      WI(EN) = HI(EN,EN)
      EN = ENM1
      GO TO 220
C     ********** ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM **********
  680 NORM = 0.D0
C
      DO 720 I = 1, N
C
         DO 720 J = I, N
            NORM = NORM + DABS(HR(I,J)) + DABS(HI(I,J))
  720 CONTINUE
C
      IF (N .EQ. 1 .OR. NORM .EQ. 0.D0) GO TO 1001
C     ********** FOR EN=N STEP -1 UNTIL 2 DO -- **********
      DO 800 NN = 2, N
         EN = N + 2 - NN
         XR = WR(EN)
         XI = WI(EN)
         ENM1 = EN - 1
C     ********** FOR I=EN-1 STEP -1 UNTIL 1 DO -- **********
         DO 780 II = 1, ENM1
            I = EN - II
            ZZR = HR(I,EN)
            ZZI = HI(I,EN)
            IF (I .EQ. ENM1) GO TO 760
            IP1 = I + 1
C
            DO 740 J = IP1, ENM1
               ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
               ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
  740       CONTINUE
C
  760       YR = XR - WR(I)
            YI = XI - WI(I)
            IF (YR .EQ. 0.D0 .AND. YI .EQ. 0.D0) YR = MACHEP * NORM
            R2 = YR*YR + YI*YI
            HR(I,EN) = (ZZR*YR + ZZI*YI)/R2
            HI(I,EN) = (ZZI*YR - ZZR*YI)/R2
  780    CONTINUE
C
  800 CONTINUE
C     ********** END BACKSUBSTITUTION **********
      ENM1 = N - 1
C     ********** VECTORS OF ISOLATED ROOTS **********
      DO  840 I = 1, ENM1
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
         IP1 = I + 1
C
         DO 820 J = IP1, N
            ZR(I,J) = HR(I,J)
            ZI(I,J) = HI(I,J)
  820    CONTINUE
C
  840 CONTINUE
C     ********** MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW+1 DO -- **********
      DO 880 JJ = LOW, ENM1
         J = N + LOW - JJ
         M = MIN0(J-1,IGH)
C
         DO 880 I = LOW, IGH
            ZZR = ZR(I,J)
            ZZI = ZI(I,J)
C
            DO 860 K = LOW, M
               ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
               ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
  860       CONTINUE
C
            ZR(I,J) = ZZR
            ZI(I,J) = ZZI
  880 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 50 ITERATIONS **********
 1000 IERR = EN
 1001 RETURN
C     ********** LAST CARD OF DCMQR2 **********
      END
      SUBROUTINE CL1(K, L, M, N, Q, KQ, KODE, TOLER, ITER, X, RES,
     *                  ERROR, WK, IWK)
      DIMENSION Q(KQ,*), X(*), RES(*), WK(*), IWK(*)
C     -------------------
      KLM = K + L + M
      CALL XL1(K, L, M, N, KLM, KQ, KLM + N, N + 2, Q, KODE, TOLER,
     *         ITER, X, RES, ERROR, WK, IWK(KLM+1), IWK(1))
      RETURN
      END
      SUBROUTINE XL1(K, L, M, N, KLMD, KLM2D, NKLMD, N2D,
     * Q, KODE, TOLER, ITER, X, RES, ERROR, CU, IU, S)
C
C THIS SUBROUTINE USES A MODIFICATION OF THE SIMPLEX
C METHOD OF LINEAR PROGRAMMING TO CALCULATE AN L1 SOLUTION
C TO A K BY N SYSTEM OF LINEAR EQUATIONS
C             AX=B
C SUBJECT TO L LINEAR EQUALITY CONSTRAINTS
C             CX=D
C AND M LINEAR INEQUALITY CONSTRAINTS
C             EX.LE.F.
C DESCRIPTION OF PARAMETERS
C K      NUMBER OF ROWS OF THE MATRIX A (K.GE.1).
C L      NUMBER OF ROWS OF THE MATRIX C (L.GE.0).
C M      NUMBER OF ROWS OF THE MATRIX E (M.GE.0).
C N      NUMBER OF COLUMNS OF THE MATRICES A,C,E (N.GE.1).
C KLMD   SET TO AT LEAST K+L+M FOR ADJUSTABLE DIMENSIONS.
C KLM2D  SET TO AT LEAST K+L+M+2 FOR ADJUSTABLE DIMENSIONS.
C NKLMD  SET TO AT LEAST N+K+L+M FOR ADJUSTABLE DIMENSIONS.
C N2D    SET TO AT LEAST N+2 FOR ADJUSTABLE DIMENSIONS
C Q      TWO DIMENSIONAL REAL ARRAY WITH KLM2D ROWS AND
C        AT LEAST N2D COLUMNS.
C        ON ENTRY THE MATRICES A,C AND E, AND THE VECTORS
C        B,D AND F MUST BE STORED IN THE FIRST K+L+M ROWS
C        AND N+1 COLUMNS OF Q AS FOLLOWS
C             A B
C         Q = C D
C             E F
C        THESE VALUES ARE DESTROYED BY THE SUBROUTINE.
C KODE   A CODE USED ON ENTRY TO, AND EXIT
C        FROM, THE SUBROUTINE.
C        ON ENTRY, THIS SHOULD NORMALLY BE SET TO 0.
C        HOWEVER, IF CERTAIN NONNEGATIVITY CONSTRAINTS
C        ARE TO BE INCLUDED IMPLICITLY, RATHER THAN
C        EXPLICITLY IN THE CONSTRAINTS EX.LE.F, THEN KODE
C        SHOULD BE SET TO 1, AND THE NONNEGATIVITY
C        CONSTRAINTS INCLUDED IN THE ARRAYS X AND
C        RES (SEE BELOW).
C        ON EXIT, KODE HAS ONE OF THE
C        FOLLOWING VALUES
C             0- OPTIMAL SOLUTION FOUND,
C             1- NO FEASIBLE SOLUTION TO THE
C                CONSTRAINTS,
C             2- CALCULATIONS TERMINATED
C                PREMATURELY DUE TO ROUNDING ERRORS,
C             3- MAXIMUM NUMBER OF ITERATIONS REACHED.
C TOLER  A SMALL POSITIVE TOLERANCE. EMPIRICAL
C        EVIDENCE SUGGESTS TOLER = 10**(-D*2/3),
C        WHERE D REPRESENTS THE NUMBER OF DECIMAL
C        DIGITS OF ACCURACY AVAILABLE. ESSENTIALLY,
C        THE SUBROUTINE CANNOT DISTINGUISH BETWEEN ZERO
C        AND ANY QUANTITY WHOSE MAGNITUDE DOES NOT EXCEED
C        TOLER. IN PARTICULAR, IT WILL NOT PIVOT ON ANY
C        NUMBER WHOSE MAGNITUDE DOES NOT EXCEED TOLER.
C ITER   ON ENTRY ITER MUST CONTAIN AN UPPER BOUND ON
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C        A SUGGESTED VALUE IS 10*(K+L+M). ON EXIT ITER
C        GIVES THE NUMBER OF SIMPLEX ITERATIONS.
C X      ONE DIMENSIONAL REAL ARRAY OF SIZE AT LEAST N2D.
C        ON EXIT THIS ARRAY CONTAINS A
C        SOLUTION TO THE L1 PROBLEM. IF KODE=1
C        ON ENTRY, THIS ARRAY IS ALSO USED TO INCLUDE
C        SIMPLE NONNEGATIVITY CONSTRAINTS ON THE
C        VARIABLES. THE VALUES -1, 0, OR 1
C        FOR X(J) INDICATE THAT THE J-TH VARIABLE
C        IS RESTRICTED TO BE .LE.0, UNRESTRICTED,
C        OR .GE.0 RESPECTIVELY.
C RES    ONE DIMENSIONAL REAL ARRAY OF SIZE AT LEAST KLMD.
C        ON EXIT THIS CONTAINS THE RESIDUALS B-AX
C        IN THE FIRST K COMPONENTS, D-CX IN THE
C        NEXT L COMPONENTS (THESE WILL BE =0),AND
C        F-EX IN THE NEXT M COMPONENTS. IF KODE=1 ON
C        ENTRY, THIS ARRAY IS ALSO USED TO INCLUDE SIMPLE
C        NONNEGATIVITY CONSTRAINTS ON THE RESIDUALS
C        B-AX. THE VALUES -1, 0, OR 1 FOR RES(I)
C        INDICATE THAT THE I-TH RESIDUAL (1.LE.I.LE.K) IS
C        RESTRICTED TO BE .LE.0, UNRESTRICTED, OR .GE.0
C        RESPECTIVELY.
C ERROR  ON EXIT, THIS GIVES THE MINIMUM SUM OF
C        ABSOLUTE VALUES OF THE RESIDUALS.
C CU     A TWO DIMENSIONAL REAL ARRAY WITH TWO ROWS AND
C        AT LEAST NKLMD COLUMNS USED FOR WORKSPACE.
C IU     A TWO DIMENSIONAL INTEGER ARRAY WITH TWO ROWS AND
C        AT LEAST NKLMD COLUMNS USED FOR WORKSPACE.
C S      INTEGER ARRAY OF SIZE AT LEAST KLMD, USED FOR
C        WORKSPACE.
C IF YOUR FORTRAN COMPILER PERMITS A SINGLE COLUMN OF A TWO
C DIMENSIONAL ARRAY TO BE PASSED TO A ONE DIMENSIONAL ARRAY
C THROUGH A SUBROUTINE CALL, CONSIDERABLE SAVINGS IN
C EXECUTION TIME MAY BE ACHIEVED THROUGH THE USE OF THE
C FOLLOWING SUBROUTINE, WHICH OPERATES ON COLUMN VECTORS.
C     SUBROUTINE COL(V1, V2, XMLT, NOTROW, K)
C THIS SUBROUTINE ADDS TO THE VECTOR V1 A MULTIPLE OF THE
C VECTOR V2 (ELEMENTS 1 THROUGH K EXCLUDING NOTROW).
C     DIMENSION V1(K), V2(K)
C     KEND = NOTROW - 1
C     KSTART = NOTROW + 1
C     IF (KEND .LT. 1) GO TO 20
C     DO 10 I=1,KEND
C        V1(I) = V1(I) + XMLT*V2(I)
C  10 CONTINUE
C     IF(KSTART .GT. K) GO TO 40
C  20 DO 30 I=KSTART,K
C       V1(I) = V1(I) + XMLT*V2(I)
C  30 CONTINUE
C  40 RETURN
C     END
C SEE COMMENTS FOLLOWING STATEMENT LABELLED 440 FOR
C INSTRUCTIONS ON THE IMPLEMENTATION OF THIS MODIFICATION.
C
      DOUBLE PRECISION SUM
      REAL Q, X, Z, CU, SN, ZU, ZV, CUV, RES, XMAX, XMIN,
     * ERROR, PIVOT, TOLER, TPIVOT
      INTEGER I, J, K, L, M, N, S, IA, II, IN, IU, JS, KK,
     * NK, N1, N2, JMN, JPN, KLM, NKL, NK1, N2D, IIMN,
     * IOUT, ITER, KLMD, KLM1, KLM2, KODE, NKLM, NKL1,
     * KLM2D, MAXIT, NKLMD, IPHASE, KFORCE, IINEG
      DIMENSION Q(KLM2D,N2D), X(N2D), RES(KLMD),
     * CU(2,NKLMD), IU(2,NKLMD), S(KLMD)
C
C INITIALIZATION.
C
      MAXIT = ITER
      N1 = N + 1
      N2 = N + 2
      NK = N + K
      NK1 = NK + 1
      NKL = NK + L
      NKL1 = NKL + 1
      KLM = K + L + M
      KLM1 = KLM + 1
      KLM2 = KLM + 2
      NKLM = N + KLM
      KFORCE = 1
      ITER = 0
      JS = 1
      IA = 0
C SET UP LABELS IN Q.
      DO 10 J=1,N
         Q(KLM2,J) = J
   10 CONTINUE
      DO 30 I=1,KLM
         Q(I,N2) = N + I
         IF (Q(I,N1).GE.0.) GO TO 30
         DO 20 J=1,N2
            Q(I,J) = -Q(I,J)
   20    CONTINUE
   30 CONTINUE
C SET UP PHASE 1 COSTS.
      IPHASE = 2
      DO 40 J=1,NKLM
         CU(1,J) = 0.
         CU(2,J) = 0.
         IU(1,J) = 0
         IU(2,J) = 0
   40 CONTINUE
      IF (L.EQ.0) GO TO 60
      DO 50 J=NK1,NKL
         CU(1,J) = 1.
         CU(2,J) = 1.
         IU(1,J) = 1
         IU(2,J) = 1
   50 CONTINUE
      IPHASE = 1
   60 IF (M.EQ.0) GO TO 80
      DO 70 J=NKL1,NKLM
         CU(2,J) = 1.
         IU(2,J) = 1
         JMN = J - N
         IF (Q(JMN,N2).LT.0.) IPHASE = 1
   70 CONTINUE
   80 IF (KODE.EQ.0) GO TO 150
      DO 110 J=1,N
         IF (X(J)) 90, 110, 100
   90    CU(1,J) = 1.
         IU(1,J) = 1
         GO TO 110
  100    CU(2,J) = 1.
         IU(2,J) = 1
  110 CONTINUE
      DO 140 J=1,K
         JPN = J + N
         IF (RES(J)) 120, 140, 130
  120    CU(1,JPN) = 1.
         IU(1,JPN) = 1
         IF (Q(J,N2).GT.0.0) IPHASE = 1
         GO TO 140
  130    CU(2,JPN) = 1.
         IU(2,JPN) = 1
         IF (Q(J,N2).LT.0.0) IPHASE = 1
  140 CONTINUE
  150 IF (IPHASE.EQ.2) GO TO 500
C COMPUTE THE MARGINAL COSTS.
  160 DO 200 J=JS,N1
         SUM = 0.D0
         DO 190 I=1,KLM
            II = Q(I,N2)
            IF (II.LT.0) GO TO 170
            Z = CU(1,II)
            GO TO 180
  170       IINEG = -II
            Z = CU(2,IINEG)
  180       SUM = SUM + DBLE(Q(I,J))*DBLE(Z)
  190    CONTINUE
         Q(KLM1,J) = SUM
  200 CONTINUE
      DO 230 J=JS,N
         II = Q(KLM2,J)
         IF (II.LT.0) GO TO 210
         Z = CU(1,II)
         GO TO 220
  210    IINEG = -II
         Z = CU(2,IINEG)
  220    Q(KLM1,J) = Q(KLM1,J) - Z
  230 CONTINUE
C DETERMINE THE VECTOR TO ENTER THE BASIS.
  240 XMAX = 0.
      IF (JS.GT.N) GO TO 490
      DO 280 J=JS,N
         ZU = Q(KLM1,J)
         II = Q(KLM2,J)
         IF (II.GT.0) GO TO 250
         II = -II
         ZV = ZU
         ZU = -ZU - CU(1,II) - CU(2,II)
         GO TO 260
  250    ZV = -ZU - CU(1,II) - CU(2,II)
  260    IF (KFORCE.EQ.1 .AND. II.GT.N) GO TO 280
         IF (IU(1,II).EQ.1) GO TO 270
         IF (ZU.LE.XMAX) GO TO 270
         XMAX = ZU
         IN = J
  270    IF (IU(2,II).EQ.1) GO TO 280
         IF (ZV.LE.XMAX) GO TO 280
         XMAX = ZV
         IN = J
  280 CONTINUE
      IF (XMAX.LE.TOLER) GO TO 490
      IF (Q(KLM1,IN).EQ.XMAX) GO TO 300
      DO 290 I=1,KLM2
         Q(I,IN) = -Q(I,IN)
  290 CONTINUE
      Q(KLM1,IN) = XMAX
C DETERMINE THE VECTOR TO LEAVE THE BASIS.
  300 IF (IPHASE.EQ.1 .OR. IA.EQ.0) GO TO 330
      XMAX = 0.
      DO 310 I=1,IA
         Z = ABS(Q(I,IN))
         IF (Z.LE.XMAX) GO TO 310
         XMAX = Z
         IOUT = I
  310 CONTINUE
      IF (XMAX.LE.TOLER) GO TO 330
      DO 320 J=1,N2
         Z = Q(IA,J)
         Q(IA,J) = Q(IOUT,J)
         Q(IOUT,J) = Z
  320 CONTINUE
      IOUT = IA
      IA = IA - 1
      PIVOT = Q(IOUT,IN)
      GO TO 420
  330 KK = 0
      DO 340 I=1,KLM
         Z = Q(I,IN)
         IF (Z.LE.TOLER) GO TO 340
         KK = KK + 1
         RES(KK) = Q(I,N1)/Z
         S(KK) = I
  340 CONTINUE
  350 IF (KK.GT.0) GO TO 360
      KODE = 2
      GO TO 590
  360 XMIN = RES(1)
      IOUT = S(1)
      J = 1
      IF (KK.EQ.1) GO TO 380
      DO 370 I=2,KK
         IF (RES(I).GE.XMIN) GO TO 370
         J = I
         XMIN = RES(I)
         IOUT = S(I)
  370 CONTINUE
      RES(J) = RES(KK)
      S(J) = S(KK)
  380 KK = KK - 1
      PIVOT = Q(IOUT,IN)
      II = Q(IOUT,N2)
      IF (IPHASE.EQ.1) GO TO 400
      IF (II.LT.0) GO TO 390
      IF (IU(2,II).EQ.1) GO TO 420
      GO TO 400
  390 IINEG = -II
      IF (IU(1,IINEG).EQ.1) GO TO 420
  400 II = IABS(II)
      CUV = CU(1,II) + CU(2,II)
      IF (Q(KLM1,IN)-PIVOT*CUV.LE.TOLER) GO TO 420
C BYPASS INTERMEDIATE VERTICES.
      DO 410 J=JS,N1
         Z = Q(IOUT,J)
         Q(KLM1,J) = Q(KLM1,J) - Z*CUV
         Q(IOUT,J) = -Z
  410 CONTINUE
      Q(IOUT,N2) = -Q(IOUT,N2)
      GO TO 350
C GAUSS-JORDAN ELIMINATION.
  420 IF (ITER.LT.MAXIT) GO TO 430
      KODE = 3
      GO TO 590
  430 ITER = ITER + 1
      DO 440 J=JS,N1
         IF (J.NE.IN) Q(IOUT,J) = Q(IOUT,J)/PIVOT
  440 CONTINUE
C IF PERMITTED, USE SUBROUTINE COL OF THE DESCRIPTION
C SECTION AND REPLACE THE FOLLOWING SEVEN STATEMENTS DOWN
C TO AND INCLUDING STATEMENT NUMBER 460 BY..
C     DO 460 J=JS,N1
C        IF(J .EQ. IN) GO TO 460
C        Z = -Q(IOUT,J)
C        CALL COL(Q(1,J), Q(1,IN), Z, IOUT, KLM1)
C 460 CONTINUE
      DO 460 J=JS,N1
         IF (J.EQ.IN) GO TO 460
         Z = -Q(IOUT,J)
         DO 450 I=1,KLM1
            IF (I.NE.IOUT) Q(I,J) = Q(I,J) + Z*Q(I,IN)
  450    CONTINUE
  460 CONTINUE
      TPIVOT = -PIVOT
      DO 470 I=1,KLM1
         IF (I.NE.IOUT) Q(I,IN) = Q(I,IN)/TPIVOT
  470 CONTINUE
      Q(IOUT,IN) = 1./PIVOT
      Z = Q(IOUT,N2)
      Q(IOUT,N2) = Q(KLM2,IN)
      Q(KLM2,IN) = Z
      II = ABS(Z)
      IF (IU(1,II).EQ.0 .OR. IU(2,II).EQ.0) GO TO 240
      DO 480 I=1,KLM2
         Z = Q(I,IN)
         Q(I,IN) = Q(I,JS)
         Q(I,JS) = Z
  480 CONTINUE
      JS = JS + 1
      GO TO 240
C TEST FOR OPTIMALITY.
  490 IF (KFORCE.EQ.0) GO TO 580
      IF (IPHASE.EQ.1 .AND. Q(KLM1,N1).LE.TOLER) GO TO 500
      KFORCE = 0
      GO TO 240
C SET UP PHASE 2 COSTS.
  500 IPHASE = 2
      DO 510 J=1,NKLM
         CU(1,J) = 0.
         CU(2,J) = 0.
  510 CONTINUE
      DO 520 J=N1,NK
         CU(1,J) = 1.
         CU(2,J) = 1.
  520 CONTINUE
      DO 560 I=1,KLM
         II = Q(I,N2)
         IF (II.GT.0) GO TO 530
         II = -II
         IF (IU(2,II).EQ.0) GO TO 560
         CU(2,II) = 0.
         GO TO 540
  530    IF (IU(1,II).EQ.0) GO TO 560
         CU(1,II) = 0.
  540    IA = IA + 1
         DO 550 J=1,N2
            Z = Q(IA,J)
            Q(IA,J) = Q(I,J)
            Q(I,J) = Z
  550    CONTINUE
  560 CONTINUE
      GO TO 160
  570 IF (Q(KLM1,N1).LE.TOLER) GO TO 500
      KODE = 1
      GO TO 590
  580 IF (IPHASE.EQ.1) GO TO 570
C PREPARE OUTPUT.
      KODE = 0
  590 SUM = 0.D0
      DO 600 J=1,N
         X(J) = 0.
  600 CONTINUE
      DO 610 I=1,KLM
         RES(I) = 0.
  610 CONTINUE
      DO 640 I=1,KLM
         II = Q(I,N2)
         SN = 1.
         IF (II.GT.0) GO TO 620
         II = -II
         SN = -1.
  620    IF (II.GT.N) GO TO 630
         X(II) = SN*Q(I,N1)
         GO TO 640
  630    IIMN = II - N
         RES(IIMN) = SN*Q(I,N1)
         IF (II.GE.N1 .AND. II.LE.NK) SUM = SUM +
     *    DBLE(Q(I,N1))
  640 CONTINUE
      ERROR = SUM
      RETURN
      END
      SUBROUTINE LLSQ(M,N,A,KA,B,KB,NB,WK,IWK,IERR)
      DIMENSION A(KA,N),B(KB,NB),WK(N),IWK(N)
      LOGICAL EXIT
C     --------------
      IERR = 0
      IF (1 .LT. N .AND. N .LE. M) GO TO 10
      IERR = 1
      RETURN
C
   10 NP1 = N + 1
      CALL ORTHO(M,N,A,KA,WK,IWK,EXIT)
      IF (EXIT) GO TO 20
      IERR = 2
      RETURN
C
   20 DO 22 J = 1,NB
      CALL ORSOL(M,N,A,KA,WK,IWK,B(1,J))
      IF (M .EQ. N) GO TO 22
      RNORM = 0.0
      DO 21 I = NP1,M
   21    RNORM = RNORM + B(I,J)*B(I,J)
      B(NP1,J) = SQRT(RNORM)
   22 CONTINUE
      RETURN
      END
      SUBROUTINE LLSQMP(M,N,A,KA,B,KB,NB,WK,IWK,IERR)
      DIMENSION A(KA,N),B(KB,NB),WK(*),IWK(N)
      LOGICAL EXIT
C     -------------------
C     DIMENSION WK(MN + 2M + N)
C     -------------------
      IERR = 0
      IF (1.LT.N .AND. N.LE.M) GO TO 10
      IERR = 2
      RETURN
C
   10 NP1 = N + 1
      LR = M + 1
      LS = LR + M
      LQ = LS + N
C
      CALL MCOPY(M, N, A, KA, WK(LQ), M)
      CALL ORTHO(M, N, WK(LQ), M, WK(LS), IWK, EXIT)
      IF (EXIT) GO TO 20
      IERR = 3
      RETURN
C
   20 DO 31 J = 1,NB
      DO 21 I = 1,M
   21 WK(I) = B(I,J)
      CALL ORSOL(M, N, WK(LQ), M, WK(LS), IWK, WK(1))
      CALL ORIMP(M, N, A, KA, WK(LQ), M, WK(LS), IWK, B(1,J),
     *                 WK(1), WK(LR), EXIT)
      DO 22 I = 1,N
   22 B(I,J) = WK(I)
      IF (.NOT.EXIT) IERR = 1
      IF (M .EQ. N) GO TO 31
C
      RNORM = 0.0
      DO 30 I = NP1,M
   30 RNORM = RNORM + WK(I)*WK(I)
      B(NP1,J) = SQRT(RNORM)
   31 CONTINUE
      RETURN
      END
      SUBROUTINE ORTHO(M, N, QR, MS, S, IP, EXIT)
C***********************************************************************
C      IDENTIFICATION
C        ORTHO - ORTHOGONAL TRANSFORMATION OF A GIVEN GENERAL M BY N
C                MATRIX A TO UPPER TRIANGULAR FORM
C        FORTRAN SUBROUTINE SUBPROGRAM
C        AEROSPACE RESEARCH LABORATORIES
C        WRIGHT-PATTERSON AFB, OHIO  45433
C      PURPOSE
C        ORTHO COMPUTES AN IMPLICIT ORTHOGONAL MATRIX Q AND AN EXPLICIT
C        UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX P SATISFYING
C        QR = PA GIVEN AN M BY N REAL MATRIX A.  ORTHO IS INTENDED FOR
C        USE WITH THE SUBROUTINE ORSOL TO PRODUCE THE LEAST SQUARES
C        SOLUTION OF THE EQUATION AX = B.
C      CONTROL
C
C        DIMENSION QR(MS,N), S(N), IP(N)
C        LOGICAL EXIT
C        .
C        .
C        .
C        CALL ORTHO(M, N, QR, MS, S, IP, EXIT)
C
C        WHERE
C        M    IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A.
C        N    IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A,
C             (1 .LT. N .LE. M).
C        QR   AS A REAL INPUT ARRAY IS MATRIX A TO BE TRIANGULARIZED.
C        QR   AS A REAL OUTPUT ARRAY IS THE UPPER TRIANGULAR FACTOR R IN
C             QR(I,J), I .LE. J, AND THE RELEVANT PARTS OF Q IN QR(I,J),
C             I .GT. J.
C        MS   IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF
C             QR IN THE CALLING PROGRAM.
C        S    IS A REAL OUTPUT ARRAY, THE RELEVANT PARTS OF Q.
C        IP   IS AN INTEGER OUTPUT ARRAY CONTAINING IN IP(I), I=1,...,N,
C             THE IMAGES OF THE PERMUTATION CORRESPONDING TO THE PERMU-
C             TATION MATRIX P.
C        EXIT IS SET TO THE VALUE .TRUE. IF THE RANK OF A IS EQUAL TO N
C             AND .FALSE. OTHERWISE.
C      METHOD
C        THE MATRIX A IN THE ARRAY QR IS REDUCED TO UPPER TRIANGULAR
C        FORM USING ORTHOGONAL TRANSFORMATION WITH PARTIAL PIVOTING.
C      REFERENCES
C        (1) PETER BUSINGER AND G.H. GOLUB, LINEAR LEAST SQUARES SOLU-
C            TIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7(1965),
C            269-276.
C        (2) N.K. TSAO AND P.J. NIKOLAI, PROCEDURES USING ORTHOGONAL
C            TRANSFORMATIONS FOR LINEAR LEAST SQUARES PROBLEMS, ARL
C            TECHNICAL REPORT ARL TR 74-0124(1974).
C***********************************************************************
      DIMENSION QR(MS,N), S(N), IP(N)
      LOGICAL EXIT
C
      EXIT = .TRUE.
      NN = N
      IF (N .EQ. M) NN = N - 1
      DO 80 J = 1, NN
        IP(J) = J
        JP = J + 1
        KJ = J
C                                       SEARCH FOR PIVOT IN THE J-TH
C                                       COLUMN AND INTERCHANGE ROWS.
        DO 10 K = JP, M
           IF (ABS(QR(K,J)) .GT. ABS(QR(KJ,J))) KJ = K
   10   CONTINUE
        IF (QR(KJ,J) .EQ. 0.0) GO TO 90
        IF (KJ .EQ. J) GO TO 30
        IP(J) = KJ
        DO 20 I = J, N
           SAV = QR(J,I)
           QR(J,I) = QR(KJ,I)
   20      QR(KJ,I) = SAV
C                                       NORMALIZE THE PIVOTING COLUMN
C                                       AND FIND ITS NORM.
   30   AJJ = QR(J,J)
        DO 31 I = JP, M
   31      QR(I,J) = QR(I,J)/AJJ
        SAV = 1.0
        DO 40 I = JP, M
   40      SAV = SAV + QR(I,J)*QR(I,J)
        S(J) = -SQRT(SAV)
        QR(J,J) = S(J)*AJJ
        IF (JP .GT. N) GO TO 80
C                                       PREMULTIPLY QR WITH THE J-TH
C                                       ORTHOGONAL MATRIX.
        Y = 1.0 - S(J)
        DO 70 K = JP, N
           SAV = QR(J,K)
           DO 50 I = JP, M
   50         SAV = SAV + QR(I,J)*QR(I,K)
           SS = QR(J,K)
           QR(J,K) = SAV/S(J)
           SS = (SS - QR(J,K))/Y
           DO 60 I = JP, M
   60         QR(I,K) = QR(I,K) - QR(I,J)*SS
   70   CONTINUE
   80 CONTINUE
      RETURN
C
   90 EXIT = .FALSE.
      RETURN
      END
      SUBROUTINE ORSOL(M, N, QR, MS, S, IP, X)
C***********************************************************************
C      IDENTIFICATION
C        ORSOL - LEAST SQUARES SOLUTION OF A LINEAR SYSTEM GIVEN AN
C                ORTHOGONAL-TRIANGULAR FACTORIZATION OF THE COEFFICIENT
C                MATRIX PRODUCED BY SUBROUTINE ORTHO
C        FORTRAN SUBROUTINE SUBPROGRAM
C        AEROSPACE RESEARCH LABORATORIES
C        WRIGHT-PATTERSON AFB, OHIO  45433
C      PURPOSE
C        ORSOL COMPUTES THE LEAST SQUARES SOLUTION OF THE LINEAR SYSTEM
C        QRX = PAX = B WHERE Q, R, AND P ARE DETERMINED FROM A BY ORTHO.
C      CONTROL
C
C        DIMENSION QR(MS,N), S(N), IP(N), X(M)
C        .
C        .
C        .
C        CALL ORSOL(M, N, QR, MS, S, IP, X)
C
C        WHERE
C        M  IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A.
C        N  IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A
C             (1 .LT. N .LE. M).
C        QR IS A REAL INPUT ARRAY, THE ORTHOGONAL AND TRIANGULAR FACTORS
C           OF A PRODUCED BY ORTHO.
C        MS IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF
C           QR IN THE CALLING PROGRAM.
C        S  IS A REAL INPUT ARRAY, THE RELEVANT PARTS OF Q PRODUCED BY
C           ORTHO.
C        IP IS AN INTEGER INPUT ARRAY, THE PERMUTATION INFORMATION
C           PRODUCED BY ORTHO.
C        X  AS A REAL INPUT ARRAY IS THE RIGHT-HAND SIDE B OF AX = B.
C        X  AS A REAL OUTPUT ARRAY IS X(I), I = 1, ..., N, THE LEAST
C           SQUARES SOLUTION, AND X(J), J = N+1, ..., M, THE VECTOR
C           WHOSE LENGTH IS THE MINIMUM OF ALL RESIDUAL B - AX.
C      METHOD
C        THE FACTORED SYSTEM QRX = PAX = PB ARE SOLVED IN THE SEQUENCE
C        OF QY = PB AND RX = Y. FULL RANK FOR THE MATRIX A IS ASSUMED
C        WHICH CAN BE CHECKED BY INTERROGATING THE LOGICAL OUTPUT
C        VARIABLE PRODUCED BY ORTHO.
C      REFERENCES
C        (1) PETER BUSINGER AND G.H. GOLUB, LINEAR LEAST SQUARES SOLU-
C            TIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7(1965),
C            269-276.
C        (2) N.K. TSAO AND P.J. NIKOLAI, PROCEDURES USING ORTHOGONAL
C            TRANSFORMATIONS FOR LINEAR LEAST SQUARES PROBLEMS, ARL
C            TECHNICAL REPORT ARL TR 74-0124(1974).
C***********************************************************************
      DIMENSION QR(MS,N), S(N), IP(N), X(M)
C
      NN = N
      IF (N .EQ. M) NN = N - 1
      DO 30 J = 1, NN
        JP = J + 1
        IJ = IP(J)
        Y = 1.0 - S(J)
        SAV = X(J)
        X(J) = X(IJ)
        X(IJ) = SAV
C                                       PREMULTIPLY X WITH THE J-TH
C                                       ORTHOGONAL MATRIX.
        SAV = X(J)
        DO 10 K = JP, M
   10     SAV = SAV + QR(K,J)*X(K)
        SS = X(J)
        X(J) = SAV/S(J)
        SS = (SS - X(J))/Y
        DO 20 K = JP, M
   20     X(K) = X(K) - QR(K,J)*SS
   30 CONTINUE
C                                       BACK SUBSTITUTE TO FIND THE
C                                       LEAST SQUARES SOLUTION.
      X(N) = X(N)/QR(N,N)
      NM = N - 1
      DO 50 I = 1, NM
        NI = N - I
        NN = N
        DO 40 J = 1, I
          X(NI) = X(NI) - QR(NI,NN)*X(NN)
   40     NN = NN - 1
        X(NI) = X(NI)/QR(NI,NI)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE ORIMP(M, N, A, KA, QR, MS, S, IP, B, X, R, EXIT)
C ----------------------------------------------------------------------
C      PURPOSE
C        GIVEN AN APPROXIMATE LEAST SQUARES SOLUTION X OF A LINEAR
C        SYSTEM AX = B OBTAINED USING ORSOL. ORIMP ATTEMPTS TO COMPUTE
C        AN IMPROVED SOLUTION CORRECT TO MACHINE PRECISION.
C
C      CONTROL
C
C        DIMENSION A(KA,N), QR(MS,N), B(M), X(M), R(M), S(N), IP(N)
C        LOGICAL EXIT
C        .
C        .
C        .
C        CALL ORIMP(M, N, A, KA, QR, MS, S, IP, B, X, R, EXIT)
C
C        WHERE
C        M    IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A.
C        N    IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A
C             (1 .LT. N .LE. M).
C        A    IS A REAL INPUT ARRAY, THE GIVEN M BY N MATRIX.
C        QR   IS A REAL INPUT ARRAY, THE ORTHOGONAL AND TRIANGULAR
C             FACTORS OF A PRODUCED BY ORTHO.
C        B    IS A REAL INPUT ARRAY, THE RIGHT HAND SIDE OF AX = B.
C        X    AS A REAL INPUT ARRAY IS THE APPROXIMATE LEAST SQUARES
C             SOLUTION TOGETHER WITH THE RESIDUAL INFORMATION PRODUCED
C             BY ORSOL.
C        X    AS A REAL OUTPUT ARRAY IS THE IMPROVED LEAST SQUARES
C             SOLUTION WITH A RESIDUAL OF MINIMUM LENGTH.
C        R    IS A REAL OUTPUT ARRAY, THE CORRECTION VECTOR ADDED TO X.
C        KA   IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF
C             OF A IN THE CALLING PROGRAM.
C        MS   IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF
C             OF QR IN THE CALLING PROGRAM.
C        S    IS A REAL INPUT ARRAY, A RELEVANT PART OF Q PRODUCED BY
C             ORTHO.
C        IP   IS AN INTEGER INPUT ARRAY, THE PERMUTATION INFORMATION
C             PRODUCED BY ORTHO.
C        EXIT IS SET TO THE VALUE .TRUE. IF IMPROVEMENT OF X IS SUCCESS-
C             FUL WITH A GAIN IN ACCURACY OF AT LEAST 50 PER CENT EACH
C             ITERATION AND .FALSE. OTHERWISE.
C
C      METHOD
C        ORIMP EXECUTES THE ITERATION CYCLE
C              (1)  AR = B - AX
C              (2)  X = X + R
C        WITH A GIVEN INITIAL X.  THE RESIDUAL VECTOR B - AX IS COMPUTED
C        TO HIGH ACCURACY BY DOUBLE PRECISION.  ORSOL IS THEN USED TO
C        SOLVE (1).
C
C ----------------------------------------------------------------------
C
      DIMENSION A(KA,N), QR(MS,N), B(M), X(M), R(M), S(N), IP(N)
      LOGICAL EXIT
      DOUBLE PRECISION DSUM
      DATA ZERO/0.0/, ONE/1.0/, FOUR/4.0/, FOURTH/0.25/
C
C     ********** EPS IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS
C                THE VALUE U WHERE U IS THE SMALLEST POSITIVE FLOATING
C                POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0.
C
      EPS = SPMPAR(1)
C
      EXIT = .TRUE.
      NP1 = N + 1
      EPS2 = EPS*EPS
C
      XNRM2 = ZERO
      DO 10 I = 1,N
   10 XNRM2 = XNRM2 + X(I)*X(I)
      IF (XNRM2 .EQ. ZERO) RETURN
      RATIO = ONE
C
C                                       FIND THE RESIDUAL VECTOR.
C
   20 DO 22 K = 1,M
      DSUM = B(K)
      DO 21 J = 1,N
   21 DSUM = DSUM - DBLE(A(K,J))*DBLE(X(J))
   22 R(K) = DSUM
C
C                                       FIND THE CORRECTION VECTOR.
C
      CALL ORSOL(M, N, QR, MS, S, IP, R)
      RNRM2 = ZERO
      DO 30 K = 1,N
   30 RNRM2 = RNRM2 + R(K)*R(K)
      IF (RNRM2 .LE. EPS2*XNRM2) RETURN
C
C                                       FORM NEW APPROXIMATE SOLUTION.
C
      DO 40 K = 1,N
   40 X(K) = X(K) + R(K)
      XNRM2 = ZERO
      DO 41 K = 1,N
   41 XNRM2 = XNRM2 + X(K)*X(K)
      IF (M .EQ. N) GO TO 50
      DO 42 K = NP1,M
   42 X(K) = R(K)
C
   50 IF (XNRM2 .EQ. ZERO) RETURN
      RAT = RATIO
      RATIO = RNRM2/XNRM2
      IF (RATIO .LE. FOURTH*RAT) GO TO 20
C
      IF (RATIO .LE. AMIN1(RAT,FOUR*EPS2)) RETURN
      EXIT = .FALSE.
      RETURN
      END
      SUBROUTINE DLLSQ(M,N,A,KA,B,KB,NB,WK,IWK,IERR)
      DOUBLE PRECISION A(KA,N),B(KB,NB),WK(N)
      INTEGER IWK(N)
      DOUBLE PRECISION RNORM
      LOGICAL EXIT
C     --------------
      IERR = 0
      IF (1 .LT. N .AND. N .LE. M) GO TO 10
      IERR = 1
      RETURN
C
   10 NP1 = N + 1
      CALL DORTHO(M,N,A,KA,WK,IWK,EXIT)
      IF (EXIT) GO TO 20
      IERR = 2
      RETURN
C
   20 DO 22 J = 1,NB
      CALL DORSOL(M,N,A,KA,WK,IWK,B(1,J))
      IF (M .EQ. N) GO TO 22
      RNORM = 0.D0
         DO 21 I = NP1,M
   21    RNORM = RNORM + B(I,J)*B(I,J)
      B(NP1,J) = DSQRT(RNORM)
   22 CONTINUE
      RETURN
      END
      SUBROUTINE DORTHO(M, N, QR, MS, S, IP, EXIT)
C***********************************************************************
C      IDENTIFICATION
C        DORTHO - ORTHOGONAL TRANSFORMATION OF A GIVEN GENERAL M BY N
C                MATRIX A TO UPPER TRIANGULAR FORM
C        FORTRAN SUBROUTINE SUBPROGRAM
C        AEROSPACE RESEARCH LABORATORIES
C        WRIGHT-PATTERSON AFB, OHIO  45433
C      PURPOSE
C        DORTHO COMPUTES AN IMPLICIT ORTHOGONAL MATRIX Q AND AN EXPLICIT
C        UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX P SATISFYING
C        QR = PA GIVEN AN M BY N REAL MATRIX A.  DORTHO IS INTENDED FOR
C        USE WITH THE SUBROUTINE DORSOL TO PRODUCE THE LEAST SQUARES
C        SOLUTION OF THE EQUATION AX = B.
C      CONTROL
C
C        DIMENSION QR(MS,N), S(N), IP(N)
C        LOGICAL EXIT
C        .
C        .
C        .
C        CALL DORTHO(M, N, QR, MS, S, IP, EXIT)
C
C        WHERE
C        M    IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A.
C        N    IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A,
C             (1 .LT. N .LE. M).
C        QR   AS A REAL INPUT ARRAY IS MATRIX A TO BE TRIANGULARIZED.
C        QR   AS A REAL OUTPUT ARRAY IS THE UPPER TRIANGULAR FACTOR R IN
C             QR(I,J), I .LE. J, AND THE RELEVANT PARTS OF Q IN QR(I,J),
C             I .GT. J.
C        MS   IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF
C             QR IN THE CALLING PROGRAM.
C        S    IS A REAL OUTPUT ARRAY, THE RELEVANT PARTS OF Q.
C        IP   IS AN INTEGER OUTPUT ARRAY CONTAINING IN IP(I), I=1,...,N,
C             THE IMAGES OF THE PERMUTATION CORRESPONDING TO THE PERMU-
C             TATION MATRIX P.
C        EXIT IS SET TO THE VALUE .TRUE. IF THE RANK OF A IS EQUAL TO N
C             AND .FALSE. OTHERWISE.
C      METHOD
C        THE MATRIX A IN THE ARRAY QR IS REDUCED TO UPPER TRIANGULAR
C        FORM USING ORTHOGONAL TRANSFORMATION WITH PARTIAL PIVOTING.
C      REFERENCES
C        (1) PETER BUSINGER AND G.H. GOLUB, LINEAR LEAST SQUARES SOLU-
C            TIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7(1965),
C            269-276.
C        (2) N.K. TSAO AND P.J. NIKOLAI, PROCEDURES USING ORTHOGONAL
C            TRANSFORMATIONS FOR LINEAR LEAST SQUARES PROBLEMS, ARL
C            TECHNICAL REPORT ARL TR 74-0124(1974).
C***********************************************************************
      DOUBLE PRECISION QR(MS,N), S(N)
      INTEGER IP(N)
      DOUBLE PRECISION AJJ, SAV, SS, Y
      LOGICAL EXIT
C
      EXIT = .TRUE.
      NN = N
      IF (N .EQ. M) NN = N - 1
      DO 80 J = 1, NN
        IP(J) = J
        JP = J + 1
        KJ = J
C                                       SEARCH FOR PIVOT IN THE J-TH
C                                       COLUMN AND INTERCHANGE ROWS.
        DO 10 K = JP, M
           IF (DABS(QR(K,J)) .GT. DABS(QR(KJ,J))) KJ = K
   10   CONTINUE
        IF (QR(KJ,J) .EQ. 0.D0) GO TO 90
        IF (KJ .EQ. J) GO TO 30
        IP(J) = KJ
        DO 20 I = J, N
           SAV = QR(J,I)
           QR(J,I) = QR(KJ,I)
   20      QR(KJ,I) = SAV
C                                       NORMALIZE THE PIVOTING COLUMN
C                                       AND FIND ITS NORM.
   30   AJJ = QR(J,J)
        DO 31 I = JP, M
   31      QR(I,J) = QR(I,J)/AJJ
        SAV = 1.D0
        DO 40 I = JP, M
   40      SAV = SAV + QR(I,J)*QR(I,J)
        S(J) = -DSQRT(SAV)
        QR(J,J) = S(J)*AJJ
        IF (JP .GT. N) GO TO 80
C                                       PREMULTIPLY QR WITH THE J-TH
C                                       ORTHOGONAL MATRIX.
        Y = 1.D0 - S(J)
        DO 70 K = JP, N
           SAV = QR(J,K)
           DO 50 I = JP, M
   50         SAV = SAV + QR(I,J)*QR(I,K)
           SS = QR(J,K)
           QR(J,K) = SAV/S(J)
           SS = (SS - QR(J,K))/Y
           DO 60 I = JP, M
   60         QR(I,K) = QR(I,K) - QR(I,J)*SS
   70   CONTINUE
   80 CONTINUE
      RETURN
C
   90 EXIT = .FALSE.
      RETURN
      END
      SUBROUTINE DORSOL(M, N, QR, MS, S, IP, X)
C***********************************************************************
C      IDENTIFICATION
C        DORSOL - LEAST SQUARES SOLUTION OF A LINEAR SYSTEM GIVEN AN
C                ORTHOGONAL-TRIANGULAR FACTORIZATION OF THE COEFFICIENT
C                MATRIX PRODUCED BY SUBROUTINE DORTHO
C        FORTRAN SUBROUTINE SUBPROGRAM
C        AEROSPACE RESEARCH LABORATORIES
C        WRIGHT-PATTERSON AFB, OHIO  45433
C      PURPOSE
C        DORSOL COMPUTES THE LEAST SQUARES SOLUTION OF THE LINEAR SYSTEM
C        QRX = PAX = B WHERE Q, R, AND P ARE DETERMINED FROM A BY DORTHO
C      CONTROL
C
C        DIMENSION QR(MS,N), S(N), IP(N), X(M)
C        .
C        .
C        .
C        CALL DORSOL(M, N, QR, MS, S, IP, X)
C
C        WHERE
C        M  IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A.
C        N  IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A
C             (1 .LT. N .LE. M).
C        QR IS A REAL INPUT ARRAY, THE ORTHOGONAL AND TRIANGULAR FACTORS
C           OF A PRODUCED BY DORTHO.
C        MS IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF
C           QR IN THE CALLING PROGRAM.
C        S  IS A REAL INPUT ARRAY, THE RELEVANT PARTS OF Q PRODUCED BY
C           DORTHO.
C        IP IS AN INTEGER INPUT ARRAY, THE PERMUTATION INFORMATION
C           PRODUCED BY DORTHO.
C        X  AS A REAL INPUT ARRAY IS THE RIGHT-HAND SIDE B OF AX = B.
C        X  AS A REAL OUTPUT ARRAY IS X(I), I = 1, ..., N, THE LEAST
C           SQUARES SOLUTION, AND X(J), J = N+1, ..., M, THE VECTOR
C           WHOSE LENGTH IS THE MINIMUM OF ALL RESIDUAL B - AX.
C      METHOD
C        THE FACTORED SYSTEM QRX = PAX = PB ARE SOLVED IN THE SEQUENCE
C        OF QY = PB AND RX = Y. FULL RANK FOR THE MATRIX A IS ASSUMED
C        WHICH CAN BE CHECKED BY INTERROGATING THE LOGICAL OUTPUT
C        VARIABLE PRODUCED BY DORTHO.
C      REFERENCES
C        (1) PETER BUSINGER AND G.H. GOLUB, LINEAR LEAST SQUARES SOLU-
C            TIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7(1965),
C            269-276.
C        (2) N.K. TSAO AND P.J. NIKOLAI, PROCEDURES USING ORTHOGONAL
C            TRANSFORMATIONS FOR LINEAR LEAST SQUARES PROBLEMS, ARL
C            TECHNICAL REPORT ARL TR 74-0124(1974).
C***********************************************************************
      DOUBLE PRECISION QR(MS,N), S(N), X(M)
      INTEGER IP(N)
      DOUBLE PRECISION SAV, SS, Y
C
      NN = N
      IF(N .EQ. M) NN = N - 1
      DO 30 J = 1, NN
        JP = J + 1
        IJ = IP(J)
        Y = 1.D0 - S(J)
        SAV = X(J)
        X(J) = X(IJ)
        X(IJ) = SAV
C                                       PREMULTIPLY X WITH THE J-TH
C                                       ORTHOGONAL MATRIX.
        SAV = X(J)
        DO 10 K = JP, M
   10     SAV = SAV + QR(K,J)*X(K)
        SS = X(J)
        X(J) = SAV/S(J)
        SS = (SS - X(J))/Y
        DO 20 K = JP, M
   20     X(K) = X(K) - QR(K,J)*SS
   30 CONTINUE
C                                       BACK SUBSTITUTE TO FIND THE
C                                       LEAST SQUARES SOLUTION.
      X(N) = X(N)/QR(N,N)
      NM = N - 1
      DO 50 I = 1, NM
        NI = N - I
        NN = N
        DO 40 J = 1, I
          X(NI) = X(NI) - QR(NI,NN)*X(NN)
   40     NN = NN - 1
        X(NI) = X(NI)/QR(NI,NI)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE LSQR (IND, A, MDA, M, N, B, MDB, NB, RE, AE, KRANK,
     *                 KSURE, RNORM, WORK, LW, IWORK, LIW, IERR)
C-----------------------------------------------------------------------
C
C              LEAST SQUARES SOLUTION OF LINEAR EQUATIONS
C
C                            --------------
C
C     LSQR SOLVES BOTH UNDERDETERMINED AND OVERDETERMINED LINEAR
C     SYSTEMS AX = B, WHERE A IS AN M BY N MATRIX AND B IS AN M BY
C     NB MATRIX OF RIGHT HAND SIDES. IF M .GE. N, THE LEAST SQUARES
C     SOLUTION IS COMPUTED BY DECOMPOSING THE MATRIX A INTO THE
C     PRODUCT OF AN ORTHOGONAL MATRIX Q AND UPPER TRIANGULAR MATRIX
C     R (QR FACTORIZATION). IF M .LT. N, THE MINIMAL LENGTH SOLUTION
C     IS COMPUTED BY FACTORING THE MATRIX A INTO THE PRODUCT OF A
C     LOWER TRIANGULAR MATRIX L AND ORTHOGONAL MATRIX Q (LQ FACTOR-
C     IZATION). IF THE MATRIX A IS DETERMINED TO BE RANK DEFICIENT,
C     THEN THE MINIMAL LENGTH LEAST SQUARES SOLUTION IS COMPUTED.
C
C     USER INPUT BOUNDS ON THE UNCERTAINTY OF THE ELEMENTS OF A ARE
C     USED TO DETECT NUMERICAL RANK DEFICIENCY. THE ALGORITHM USES
C     A ROW AND COLUMN PIVOT STRATEGY TO MINIMIZE THE GROWTH OF
C     UNCERTAINTY AND ROUND-OFF ERRORS.
C
C   ******************************************************************
C   *                                                                *
C   *         WARNING - ALL INPUT ARRAYS ARE CHANGED ON EXIT.        *
C   *                                                                *
C   ******************************************************************
C
C     INPUT..
C
C     IND           INTEGER WHICH INDICATES IF THE ROUTINE IS BEING
C                   CALLED FOR THE FIRST TIME.
C                      IND = 0      ORIGINAL CALL
C                      IND .NE. 0   SUBSEQUENT CALLS
C                   ON SUBSEQUENT CALLS A NEW SET B OF EQUATIONS CAN
C                   BE SOLVED (USING THE SAME COEFFICIENT MATRIX A).
C                   IT IS ASSUMED THAT A, MDA, M, N, KRANK, IWORK,
C                   LIW, AND THE FIRST 2*MIN(M,N) LOCATIONS OF WORK
C                   HAVE NOT BEEN MODIFIED BY THE USER. RE, AE, AND
C                   KSURE ARE NOT USED.
C
C     A(,)          LINEAR COEFFICIENT MATRIX OF AX=B, WITH MDA THE
C      MDA,M,N      ACTUAL FIRST DIMENSION OF A IN THE CALLING PROGRAM.
C                   M IS THE ROW DIMENSION (NO. OF EQUATIONS OF THE
C                   PROBLEM) AND N THE COL DIMENSION (NO. OF UNKNOWNS).
C                   MUST HAVE MDA .GE. M.
C
C     B(,)          RIGHT HAND SIDE(S), WITH MDB THE ACTUAL FIRST
C      MDB,NB       DIMENSION OF B IN THE CALLING PROGRAM. NB IS THE
C                   NUMBER OF M BY 1 RIGHT HAND SIDES. MUST HAVE
C                   MDB .GE. MAX(M,N). IF NB .LE. 0 THEN B AND MDB
C                   ARE IGNORED.
C
C     RE            RE IS THE MAXIMUM RELATIVE UNCERTAINTY OF THE
C                   ELEMENTS OF THE MATRIX A (0 .LE. RE .LT. 1).
C
C     AE            AE IS THE MAXIMUM ABSOLUTE UNCERTAINTY OF THE
C                   ELEMENTS OF THE MATRIX A (AE .GE. 0).
C
C     WORK()        A REAL WORK ARRAY DIMENSIONED 5*MIN(M,N).
C
C     LW            ACTUAL DIMENSION OF WORK
C
C     IWORK()       INTEGER WORK ARRAY DIMENSIONED AT LEAST N+M.
C
C     LIW           ACTUAL DIMENSION OF IWORK.
C
C     OUTPUT..
C
C     A(,)          CONTAINS THE TRIANGULAR PART OF THE REDUCED MATRIX
C                   AND THE TRANSFORMATION INFORMATION. A AND THE FIRST
C                   2*MIN(M,N) ELEMENTS OF WORK (SEE BELOW) COMPLETELY
C                   SPECIFY THE FACTORIZATION OF THE MATRIX A.
C
C     B(,)          CONTAINS THE N BY NB SOLUTION MATRIX FOR X.
C
C     KRANK,KSURE   THE NUMERICAL RANK OF A,  BASED UPON THE RELATIVE
C                   AND ABSOLUTE BOUNDS ON UNCERTAINTY, IS BOUNDED
C                   ABOVE BY KRANK AND BELOW BY KSURE. THE ALGORITHM
C                   RETURNS A SOLUTION BASED ON KRANK. KSURE PROVIDES
C                   AN INDICATION OF THE PRECISION OF THE RANK.
C
C     RNORM()       CONTAINS THE EUCLIDEAN LENGTH OF THE NB RESIDUAL
C                   VECTORS  B(I) - AX(I), I=1,...,NB.
C
C     WORK()        THE FIRST 2*MIN(M,N) LOCATIONS OF WORK CONTAIN
C                   THE VALUES NECESSARY TO REPRODUCE THE HOUSEHOLDER
C                   FACTORIZATION OF A.
C
C     IWORK()       AN ARRAY OF LENGTH M + N CONTAINING THE ORDERS IN
C                   WHICH THE ROWS AND COLUMNS WERE USED. IF M .GE. N
C                   THEN THE FIRST N LOCATIONS CONTAIN THE ORDER OF
C                   THE COLUMNS AND THE NEXT M LOCATIONS THE ORDER OF
C                   THE ROWS. IF M .LT. N THEN THE ORDER OF THE ROWS
C                   PRECEDES THE ORDER OF THE COLUMNS.
C
C     IERR          FLAG TO INDICATE THE STATUS OF THE RESULTS
C                     0     - SATISFACTORY COMPLETION
C                   .GT. 0  - INPUT ERROR
C
C----------------
C     THE SUBROUTINES U11LS, U12LS, U11US, AND U12US WERE WRITTEN BY
C     T. MANTEUFFEL (LANL) IN 1981. THE DRIVER ROUTINE LSQR WAS WRITTEN
C     BY A.H. MORRIS (NSWC) IN 1991.
C----------------
C     REFERENCE.  MANTEUFFEL, T., AN INTERVAL ANALYSIS APPROACH TO RANK
C                 DETERMINATION IN LINEAR LEAST SQUARES PROBLEMS,
C                 SANDIA LABORATORIES REPORT SAND80-0655, JUNE, 1980.
C-----------------------------------------------------------------------
      REAL A(MDA,N), B(MDB,*), RNORM(*), WORK(LW)
      INTEGER IWORK(LIW)
C----------------
C     NP            IF M .GE. N THEN THE FIRST NP COLUMNS OF A
C                   ARE NEVER INTERCHANGED.
C                   IF M .LT. N THEN THE FIRST NP ROWS OF A ARE
C                   NEVER INTERCHANGED. NP IS NOT REFERENCED ON
C                   A CONTINUATION CALL TO THE ROUTINE.
C
C     MODE          THE INTEGER MODE INDICATES HOW THE ROUTINE
C                   IS TO REACT IF RANK DEFICIENCY IS DETECTED.
C                   IF MODE = 0 RETURN IMMEDIATELY, NO SOLUTION
C                             1 COMPUTE TRUNCATED SOLUTION
C                             2 COMPUTE MINIMAL LENGTH SOLUTION
C                   MODE MUST NOT BE MODIFIED ON A CONTINUATION
C                   CALL TO THE ROUTINE. IF MODE LT. 2, ONLY THE
C                   FIRST N LOCATIONS OF WORK ARE USED.
C----------------
      NP = 0
      MODE = 2
C
C     CHECK THE INPUT
C
      IF (NB .LE. 0 .AND. IND .NE. 0) GO TO 200
      IF (M .LT. 1 .OR. N .LT. 1) GO TO 210
      IF (MDA .LT. M) GO TO 220
      IF (LIW .LT. M + N) GO TO 240
C
      M0 = MIN0(M,N)
      N0 = MAX0(M,N)
C     NUM = 0
C
      IF (NB .LE. 0) GO TO 10
      IF (MDB .LT. N0) GO TO 230
      IF (IND .NE. 0) GO TO 100
C
   10 IF (LW .LT. 5*M0) GO TO 250
      IF (RE .LT. 0.0 .OR. AE .LT. 0.0) GO TO 260
C
C     DEFINE THE RELATIVE AND ABSOLUTE TOLERANCE LISTS
C
      M1 = 1
      M2 = M1 + M0
      M3 = M2 + M0
      M4 = M3 + M0
      M5 = M4 + M0
C
      EPS = 10.0*SPMPAR(1)
      RERR = AMAX1(EPS,RE)
C
      IMAX = M5 - 1
      DO 20 I = M4,IMAX
         WORK(I) = RERR
   20 CONTINUE
      IMAX = IMAX + M0
      DO 30 I = M5,IMAX
         WORK(I) = AE
   30 CONTINUE
C
C     FACTOR THE MATRIX A
C
C     NUM = NP
      IF (M .LT. N) GO TO 40
C
         CALL U11LS (A,MDA,M,N,WORK(M4),WORK(M5),MODE,NP,KRANK,KSURE,
     *               WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2))
         GO TO 100
C
   40 CALL U11US (A,MDA,M,N,WORK(M4),WORK(M5),MODE,NP,KRANK,KSURE,
     *            WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2))
C
C     SOLUTION PHASE
C
  100 IERR = 0
      INFO = 0
      IF (KRANK .EQ. M0) GO TO 110
      IF (KRANK .EQ. 0) GO TO 110
C     IF (KRANK .LT. NUM) GO TO 280
C     IF (MODE .EQ. 0) RETURN
      INFO = MODE
C
  110 IF (NB .LE. 0) RETURN
C
      M1 = 1
      M2 = 1 + M0
      IF (INFO .EQ. 2) GO TO 130
C
C     ONLY MIN(M,N) ELEMENTS OF WORK ARE NEEDED
C
      IF (LW .LT. M0) GO TO 250
      IF (M .LT. N) GO TO 120
C
         CALL U12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,
     *               WORK(M1),WORK(M1),IWORK(M1),IWORK(M2))
         RETURN
C
  120 CALL U12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,
     *            WORK(M1),WORK(M1),IWORK(M1),IWORK(M2))
      RETURN
C
C     HERE 2*MIN(M,N) ELEMENTS OF WORK ARE NEEDED
C
  130 IF (LW .LT. 2*M0) GO TO 250
      IF (M .LT. N) GO TO 140
C
         CALL U12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,
     *               WORK(M1),WORK(M2),IWORK(M1),IWORK(M2))
         RETURN
C
 140  CALL U12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,
     *            WORK(M1),WORK(M2),IWORK(M1),IWORK(M2))
      RETURN
C
C     ERROR RETURN
C
C                             NB .LE. 0  ON A CONTINUATION CALL
  200 IERR = 7
      RETURN
C                             M .LT. 1 OR N .LT. 1
  210 IERR = 1
      RETURN
C                             MDA .LT. M
  220 IERR = 2
      RETURN
C                             MDB .LT. MAX(M,N)
  230 IERR = 3
      RETURN
C                             LIW .LT. M + N
  240 IERR = 4
      RETURN
C                             LW TOO SMALL
  250 IERR = 5
      RETURN
C                             RE OR AE IS NEGATIVE
  260 IERR = 6
      RETURN
C                             0 .LT. KRANK .LT. NP
C 280 IERR = 8
C     RETURN
      END
      SUBROUTINE U11LS (A,MDA,M,N,UB,DB,MODE,NP,KRANK,KSURE,H,W,EB,
     *                  IC,IR)
C
C       THIS ROUTINE PERFORMS A QR FACTORIZATION OF A
C       USING HOUSEHOLDER TRANSFORMATIONS. ROW AND
C       COLUMN PIVOTS ARE CHOSEN TO REDUCE THE GROWTH
C       OF ROUND-OFF AND TO HELP DETECT POSSIBLE RANK
C       DEFICIENCY.
C
      DIMENSION A(MDA,N),UB(N),DB(N),H(N),W(N),EB(N)
      INTEGER IC(N),IR(M)
C
C        INITIALIZATION
C
      J = 0
      KRANK = N
      DO 10 I = 1,N
         IC(I) = I
   10 CONTINUE
      DO 20 I = 1,M
         IR(I) = I
   20 CONTINUE
C
C        DETERMINE REL AND ABS ERROR VECTORS
C
C
C        CALCULATE COL LENGTH
C
      DO 30 I = 1,N
         H(I) = SNRM2(M,A(1,I),1)
         W(I) = H(I)
   30 CONTINUE
C
C         INITIALIZE ERROR BOUNDS
C
      DO 40 I = 1,N
         EB(I) = AMAX1(DB(I),UB(I)*H(I))
         UB(I) = EB(I)
         DB(I) = 0.0
   40 CONTINUE
C
C          DISCARD SELF DEPENDENT COLUMNS
C
      I = 1
   50 IF (EB(I) .GE. H(I)) GO TO 60
      IF (I .EQ. KRANK) GO TO 70
      I = I + 1
      GO TO 50
C
C          MATRIX REDUCTION
C
   60 KK = KRANK
      KRANK = KRANK - 1
      IF (MODE .EQ. 0) RETURN
      IF (I .LE. NP) GO TO 400
      IF (I .GT. KRANK) GO TO 70
      CALL SSWAP (1,EB(I),1,EB(KK),1)
      CALL SSWAP (1,UB(I),1,UB(KK),1)
      CALL SSWAP (1,W(I),1,W(KK),1)
      CALL SSWAP (1,H(I),1,H(KK),1)
      CALL ISWAP (1,IC(I),1,IC(KK),1)
      CALL SSWAP (M,A(1,I),1,A(1,KK),1)
      GO TO 50
C
C           TEST FOR ZERO RANK
C
   70 IF (KRANK .GT. 0) GO TO 100
      KRANK = 0
      KSURE = 0
      RETURN
C
C        M A I N    L O O P
C
  100 J = J + 1
      JP1 = J + 1
      JM1 = J - 1
      KZ = KRANK
      IF (J .LE. NP) KZ = J
C
C        EACH COL HAS MM=M-J+1 COMPONENTS
C
      MM = M - J + 1
C
C         UB DETERMINES COLUMN PIVOT
C
  110 IMIN = J
      IF (H(J) .EQ. 0.0) GO TO 170
      RMIN = UB(J)/H(J)
      DO 120 I = J,KZ
         IF (UB(I) .GE. H(I)*RMIN) GO TO 120
         RMIN = UB(I)/H(I)
         IMIN = I
  120 CONTINUE
C
C     TEST FOR RANK DEFICIENCY
C
      IF (RMIN .LT. 1.0) GO TO 200
      TT = (EB(IMIN) + ABS(DB(IMIN)))/H(IMIN)
      IF (TT .GE. 1.0) GO TO 170
C
C     COMPUTE EXACT UB
C
      DO 125 I = 1,JM1
         W(I) = A(I,IMIN)
  125 CONTINUE
C
      L = JM1
  130 W(L) = W(L)/A(L,L)
      IF (L .EQ. 1) GO TO 150
      LM1 = L - 1
      DO 140 I = L,JM1
         W(LM1) = W(LM1) - A(LM1,I)*W(I)
  140 CONTINUE
      L = LM1
      GO TO 130
C
  150 TT = EB(IMIN)
      DO 160 I = 1,JM1
         TT = TT + ABS(W(I))*EB(I)
  160 CONTINUE
      UB(IMIN) = TT
      IF (UB(IMIN)/H(IMIN) .GE. 1.0) GO TO 170
      GO TO 200
C
C        MATRIX REDUCTION
C
  170 KK = KRANK
      KRANK = KRANK - 1
      KZ = KRANK
      IF (MODE .EQ. 0) RETURN
      IF (J .LE. NP) GO TO 410
      IF (IMIN .GT. KRANK) GO TO 180
         CALL ISWAP (1,IC(IMIN),1,IC(KK),1)
         CALL SSWAP (M,A(1,IMIN),1,A(1,KK),1)
         CALL SSWAP (1,EB(IMIN),1,EB(KK),1)
         CALL SSWAP (1,UB(IMIN),1,UB(KK),1)
         CALL SSWAP (1,DB(IMIN),1,DB(KK),1)
         CALL SSWAP (1,W(IMIN),1,W(KK),1)
         CALL SSWAP (1,H(IMIN),1,H(KK),1)
  180 IF (J .GT. KRANK) GO TO 300
      GO TO 110
C
C        COLUMN PIVOT
C
  200 IF (IMIN .EQ. J) GO TO 210
      CALL SSWAP (1,H(J),1,H(IMIN),1)
      CALL SSWAP (M,A(1,J),1,A(1,IMIN),1)
      CALL SSWAP (1,EB(J),1,EB(IMIN),1)
      CALL SSWAP (1,UB(J),1,UB(IMIN),1)
      CALL SSWAP (1,DB(J),1,DB(IMIN),1)
      CALL SSWAP (1,W(J),1,W(IMIN),1)
      CALL ISWAP (1,IC(J),1,IC(IMIN),1)
C
C        ROW PIVOT
C
  210 JMAX = ISAMAX(MM,A(J,J),1)
      JMAX = JMAX + J - 1
      IF (JMAX .EQ. J) GO TO 220
      CALL SSWAP (N,A(J,1),MDA,A(JMAX,1),MDA)
      CALL ISWAP (1,IR(J),1,IR(JMAX),1)
C
C     APPLY HOUSEHOLDER TRANSFORMATION
C
  220 TN = SNRM2(MM,A(J,J),1)
      IF (TN .EQ. 0.0) GO TO 170
      IF (A(J,J) .NE. 0.0) TN = SIGN(TN,A(J,J))
      CALL SSCAL (MM,1.0/TN,A(J,J),1)
      A(J,J) = A(J,J) + 1.0
      IF (J .EQ. N) GO TO 250
      DO 240 I = JP1,N
         BB = -SDOT(MM,A(J,J),1,A(J,I),1)/A(J,J)
         CALL SAXPY (MM,BB,A(J,J),1,A(J,I),1)
         IF (I .LE. NP) GO TO 240
         IF (H(I) .EQ. 0.0) GO TO 240
         TT = 1.0 - (A(J,I)/H(I))**2
         TT = AMAX1(TT,0.0)
         T = TT
         TT = 1.0 + 0.05*TT*(H(I)/W(I))**2
         IF (TT .EQ. 1.0) GO TO 230
            H(I) = H(I)*SQRT(T)
            GO TO 240
  230    H(I) = SNRM2(M-J,A(J+1,I),1)
         W(I) = H(I)
  240 CONTINUE
C
  250 H(J) = A(J,J)
      A(J,J) = -TN
C
C          UPDATE UB, DB
C
      UB(J) = UB(J)/ABS(A(J,J))
      DB(J) = (SIGN(EB(J),DB(J)) + DB(J))/A(J,J)
      IF (J .EQ. KRANK) GO TO 300
      DO 260 I = JP1,KRANK
         UB(I) = UB(I) + ABS(A(J,I))*UB(J)
         DB(I) = DB(I) - A(J,I)*DB(J)
  260 CONTINUE
      GO TO 100
C
C        E N D    M A I N    L O O P
C
  300 CONTINUE
C
C        COMPUTE KSURE
C
      KM1 = KRANK - 1
      DO 315 I = 1,KM1
         IS = 0
         KMI = KRANK - I
         DO 310 II = 1,KMI
            IF (UB(II) .LE. UB(II + 1)) GO TO 310
            IS = 1
            TEMP = UB(II)
            UB(II) = UB(II + 1)
            UB(II + 1) = TEMP
  310    CONTINUE
         IF (IS .EQ. 0) GO TO 320
  315 CONTINUE
C
  320 KSURE = 0
      SUM = 0.0
      DO 325 I = 1,KRANK
         R2 = UB(I)*UB(I)
         IF (R2 + SUM .GE. 1.0) GO TO 330
         SUM = SUM + R2
         KSURE = KSURE + 1
  325 CONTINUE
C
C     IF SYSTEM IS OF REDUCED RANK AND MODE = 2
C     COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION
C
  330 IF (KRANK .EQ. N .OR. MODE .LT. 2) RETURN
      NMK = N - KRANK
      KP1 = KRANK + 1
      I = KRANK
  340    TN = SNRM2(NMK,A(I,KP1),MDA)/A(I,I)
         TN = A(I,I)*SQRT(1.0 + TN*TN)
         CALL SSCAL (NMK,1.0/TN,A(I,KP1),MDA)
         W(I) = A(I,I)/TN + 1.0
         A(I,I) = -TN
         IF (I .EQ. 1) GO TO 350
         IM1 = I - 1
         DO 345 II = 1,IM1
            TT = -SDOT(NMK,A(II,KP1),MDA,A(I,KP1),MDA)/W(I)
            TT = TT - A(II,I)
            CALL SAXPY (NMK,TT,A(I,KP1),MDA,A(II,KP1),MDA)
            A(II,I) = A(II,I) + TT*W(I)
  345    CONTINUE
         I = I - 1
         GO TO 340
C
  350 CONTINUE
      RETURN
C
C     FIRST NP COLUMNS ARE LINEARLY DEPENDENT
C
  400 KRANK = I - 1
      RETURN
  410 KRANK = J - 1
      RETURN
      END
      SUBROUTINE U12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,H,W,IC,IR)
C
C        GIVEN THE HOUSEHOLDER QR FACTORIZATION OF A, THIS
C        SUBROUTINE SOLVES THE SYSTEM AX=B. IF THE SYSTEM
C        IS OF REDUCED RANK, THIS ROUTINE RETURNS A SOLUTION
C        ACCORDING TO THE SELECTED MODE.
C
C       NOTE - IF MODE.NE.2, W IS NEVER ACCESSED.
C
      DIMENSION A(MDA,N),B(MDB,NB),RNORM(NB),H(N),W(N)
      INTEGER IC(N),IR(M)
C
      K = KRANK
      KP1 = K + 1
      IF (K .GT. 0) GO TO 30
C
C        RANK=0
C
      DO 10 JB = 1,NB
         RNORM(JB) = SNRM2(M,B(1,JB),1)
   10 CONTINUE
      DO 21 JB = 1,NB
         DO 20 I = 1,N
            B(I,JB) = 0.0
   20    CONTINUE
   21 CONTINUE
      RETURN
C
   30 I = 0
C
C     REORDER B TO REFLECT ROW INTERCHANGES
C
   40    I = I + 1
         IF (I .EQ. M) GO TO 100
         J = IR(I)
         IF (J .EQ. I) GO TO 40
         IF (J .LT. 0) GO TO 40
C
         IR(I) = -IR(I)
         DO 50 JB = 1,NB
            RNORM(JB) = B(I,JB)
   50    CONTINUE
C
         IJ = I
   60       DO 70 JB = 1,NB
               B(IJ,JB) = B(J,JB)
   70       CONTINUE
            IJ = J
            J = IR(IJ)
            IR(IJ) = -IR(IJ)
         IF (J .NE. I) GO TO 60
C
         DO 80 JB = 1,NB
            B(IJ,JB) = RNORM(JB)
   80    CONTINUE
         GO TO 40
C
  100 DO 110 I = 1,M
         IR(I) = IABS(IR(I))
  110 CONTINUE
C
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO B
C
      DO 130 J = 1,K
         TT = A(J,J)
         A(J,J) = H(J)
         DO 120 I = 1,NB
            BB = -SDOT (M-J+1,A(J,J),1,B(J,I),1)/H(J)
            CALL SAXPY (M-J+1,BB,A(J,J),1,B(J,I),1)
  120    CONTINUE
         A(J,J) = TT
  130 CONTINUE
C
C        FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B)
C
      DO 140 JB = 1,NB
         RNORM(JB) = SNRM2(M-K,B(KP1,JB),1)
  140 CONTINUE
C
C     BACK SOLVE UPPER TRIANGULAR R
C
      I = K
  150 DO 160 JB = 1,NB
         B(I,JB) = B(I,JB)/A(I,I)
  160 CONTINUE
      IF (I .EQ. 1) GO TO 200
      IM1 = I - 1
      DO 170 JB = 1,NB
         CALL SAXPY (IM1,-B(I,JB),A(1,I),1,B(1,JB),1)
  170 CONTINUE
      I = IM1
      GO TO 150
C
C     RANK LT N
C
C      TRUNCATED SOLUTION
C
  200 IF (K .EQ. N) GO TO 230
      DO 211 JB = 1,NB
         DO 210 I = KP1,N
            B(I,JB) = 0.0
  210    CONTINUE
  211 CONTINUE
      IF (MODE .EQ. 1) GO TO 230
C
C      MINIMAL LENGTH SOLUTION
C
      NMK = N - K
      DO 221 JB = 1,NB
         DO 220 I = 1,K
            TT = -SDOT(NMK,A(I,KP1),MDA,B(KP1,JB),1)/W(I)
            TT = TT - B(I,JB)
            CALL SAXPY (NMK,TT,A(I,KP1),MDA,B(KP1,JB),1)
            B(I,JB) = B(I,JB) + TT*W(I)
  220    CONTINUE
  221 CONTINUE
C
C     REORDER B TO REFLECT COLUMN INTERCHANGES
C
  230 I = 0
C
  240    I = I + 1
         IF (I .EQ. N) GO TO 260
         J = IC(I)
         IF (J .EQ. I) GO TO 240
         IF (J .LT. 0) GO TO 240
C
         IC(I) = -IC(I)
  250       CALL SSWAP (NB,B(J,1),MDB,B(I,1),MDB)
            IJ = IC(J)
            IC(J) = -IC(J)
            J = IJ
         IF (J .NE. I) GO TO 250
         GO TO 240
C
  260 DO 270 I = 1,N
         IC(I) = IABS(IC(I))
  270 CONTINUE
      RETURN
      END
      SUBROUTINE U11US (A,MDA,M,N,UB,DB,MODE,NP,KRANK,KSURE,H,W,EB,
     *                  IR,IC)
C
C       THIS ROUTINE PERFORMS AN LQ FACTORIZATION OF THE
C       MATRIX A USING HOUSEHOLDER TRANSFORMATIONS. ROW
C       AND COLUMN PIVOTS ARE CHOSEN TO REDUCE THE GROWTH
C       OF ROUND-OFF AND TO HELP DETECT POSSIBLE RANK
C       DEFICIENCY.
C
      DIMENSION A(MDA,N),UB(M),DB(M),H(M),W(M),EB(M)
      INTEGER IC(N),IR(M)
C
C        INITIALIZATION
C
      J = 0
      KRANK = M
      DO 10 I = 1,N
         IC(I) = I
   10 CONTINUE
      DO 20 I = 1,M
         IR(I) = I
   20 CONTINUE
C
C        DETERMINE REL AND ABS ERROR VECTORS
C
C
C        CALCULATE ROW LENGTH
C
      DO 30 I = 1,M
         H(I) = SNRM2(N,A(I,1),MDA)
         W(I) = H(I)
   30 CONTINUE
C
C         INITIALIZE ERROR BOUNDS
C
      DO 40 I = 1,M
         EB(I) = AMAX1(DB(I),UB(I)*H(I))
         UB(I) = EB(I)
         DB(I) = 0.0
   40 CONTINUE
C
C          DISCARD SELF DEPENDENT ROWS
C
      I = 1
   50 IF (EB(I) .GE. H(I)) GO TO 60
      IF (I .EQ. KRANK) GO TO 70
      I = I + 1
      GO TO 50
C
C          MATRIX REDUCTION
C
   60 KK = KRANK
      KRANK = KRANK - 1
      IF (MODE .EQ. 0) RETURN
      IF (I .LE. NP) GO TO 400
      IF (I .GT. KRANK) GO TO 70
      CALL SSWAP (1,EB(I),1,EB(KK),1)
      CALL SSWAP (1,UB(I),1,UB(KK),1)
      CALL SSWAP (1,W(I),1,W(KK),1)
      CALL SSWAP (1,H(I),1,H(KK),1)
      CALL ISWAP (1,IR(I),1,IR(KK),1)
      CALL SSWAP (N,A(I,1),MDA,A(KK,1),MDA)
      GO TO 50
C
C           TEST FOR ZERO RANK
C
   70 IF (KRANK .GT. 0) GO TO 100
      KRANK = 0
      KSURE = 0
      RETURN
C
C        M A I N    L O O P
C
  100 J = J + 1
      JP1 = J + 1
      JM1 = J - 1
      KZ = KRANK
      IF (J .LE. NP) KZ = J
C
C        EACH ROW HAS NN=N-J+1 COMPONENTS
C
      NN = N - J + 1
C
C         UB DETERMINES ROW PIVOT
C
  110 IMIN = J
      IF (H(J) .EQ. 0.0) GO TO 170
      RMIN = UB(J)/H(J)
      DO 120 I = J,KZ
         IF (UB(I) .GE. H(I)*RMIN) GO TO 120
         RMIN = UB(I)/H(I)
         IMIN = I
  120 CONTINUE
C
C     TEST FOR RANK DEFICIENCY
C
      IF (RMIN .LT. 1.0) GO TO 200
      TT = (EB(IMIN) + ABS(DB(IMIN)))/H(IMIN)
      IF (TT .GE. 1.0) GO TO 170
C
C     COMPUTE EXACT UB
C
      DO 125 I = 1,JM1
         W(I) = A(IMIN,I)
  125 CONTINUE
C
      L = JM1
  130 W(L) = W(L)/A(L,L)
      IF (L .EQ. 1) GO TO 150
      LM1 = L - 1
      DO 140 I = L,JM1
         W(LM1) = W(LM1) - A(I,LM1)*W(I)
  140 CONTINUE
      L = LM1
      GO TO 130
C
  150 TT = EB(IMIN)
      DO 160 I = 1,JM1
         TT = TT + ABS(W(I))*EB(I)
  160 CONTINUE
      UB(IMIN) = TT
      IF (UB(IMIN)/H(IMIN) .GE. 1.0) GO TO 170
      GO TO 200
C
C        MATRIX REDUCTION
C
  170 KK = KRANK
      KRANK = KRANK - 1
      KZ = KRANK
      IF (MODE .EQ. 0) RETURN
      IF (J .LE. NP) GO TO 410
      IF (IMIN .GT. KRANK) GO TO 180
         CALL ISWAP (1,IR(IMIN),1,IR(KK),1)
         CALL SSWAP (N,A(IMIN,1),MDA,A(KK,1),MDA)
         CALL SSWAP (1,EB(IMIN),1,EB(KK),1)
         CALL SSWAP (1,UB(IMIN),1,UB(KK),1)
         CALL SSWAP (1,DB(IMIN),1,DB(KK),1)
         CALL SSWAP (1,W(IMIN),1,W(KK),1)
         CALL SSWAP (1,H(IMIN),1,H(KK),1)
  180 IF (J .GT. KRANK) GO TO 300
      GO TO 110
C
C        ROW PIVOT
C
  200 IF (IMIN .EQ. J) GO TO 210
      CALL SSWAP (1,H(J),1,H(IMIN),1)
      CALL SSWAP (N,A(J,1),MDA,A(IMIN,1),MDA)
      CALL SSWAP (1,EB(J),1,EB(IMIN),1)
      CALL SSWAP (1,UB(J),1,UB(IMIN),1)
      CALL SSWAP (1,DB(J),1,DB(IMIN),1)
      CALL SSWAP (1,W(J),1,W(IMIN),1)
      CALL ISWAP (1,IR(J),1,IR(IMIN),1)
C
C        COLUMN PIVOT
C
  210 JMAX = ISAMAX(NN,A(J,J),MDA)
      JMAX = JMAX + J - 1
      IF (JMAX .EQ. J) GO TO 220
      CALL SSWAP (M,A(1,J),1,A(1,JMAX),1)
      CALL ISWAP (1,IC(J),1,IC(JMAX),1)
C
C     APPLY HOUSEHOLDER TRANSFORMATION
C
  220 TN = SNRM2(NN,A(J,J),MDA)
      IF (TN .EQ. 0.0) GO TO 170
      IF (A(J,J) .NE. 0.0) TN = SIGN(TN,A(J,J))
      CALL SSCAL (NN,1.0/TN,A(J,J),MDA)
      A(J,J) = A(J,J) + 1.0
      IF (J .EQ. M) GO TO 250
      DO 240 I = JP1,M
         BB = -SDOT(NN,A(J,J),MDA,A(I,J),MDA)/A(J,J)
         CALL SAXPY (NN,BB,A(J,J),MDA,A(I,J),MDA)
         IF (I .LE. NP) GO TO 240
         IF (H(I) .EQ. 0.0) GO TO 240
         TT = 1.0 - (A(I,J)/H(I))**2
         TT = AMAX1(TT,0.0)
         T = TT
         TT = 1.0 + 0.05*TT*(H(I)/W(I))**2
         IF (TT .EQ. 1.0) GO TO 230
            H(I) = H(I)*SQRT(T)
            GO TO 240
  230    H(I) = SNRM2(N-J,A(I,J+1),MDA)
         W(I) = H(I)
  240 CONTINUE
C
  250 H(J) = A(J,J)
      A(J,J) = -TN
C
C          UPDATE UB, DB
C
      UB(J) = UB(J)/ABS(A(J,J))
      DB(J) = (SIGN(EB(J),DB(J))+DB(J))/A(J,J)
      IF (J .EQ. KRANK) GO TO 300
      DO 260 I = JP1,KRANK
         UB(I) = UB(I) + ABS(A(I,J))*UB(J)
         DB(I) = DB(I) - A(I,J)*DB(J)
  260 CONTINUE
      GO TO 100
C
C        E N D    M A I N    L O O P
C
  300 CONTINUE
C
C        COMPUTE KSURE
C
      KM1 = KRANK - 1
      DO 315 I = 1,KM1
         IS = 0
         KMI = KRANK - I
         DO 310 II = 1,KMI
            IF (UB(II) .LE. UB(II + 1)) GO TO 310
            IS = 1
            TEMP = UB(II)
            UB(II) = UB(II + 1)
            UB(II + 1) = TEMP
  310    CONTINUE
         IF (IS .EQ. 0) GO TO 320
  315 CONTINUE
C
  320 KSURE = 0
      SUM = 0.0
      DO 325 I = 1,KRANK
         R2 = UB(I)*UB(I)
         IF (R2 + SUM .GE. 1.0) GO TO 330
         SUM = SUM + R2
         KSURE = KSURE + 1
  325 CONTINUE
C
C     IF SYSTEM IS OF REDUCED RANK AND MODE = 2
C     COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION
C
  330 IF (KRANK .EQ. M .OR. MODE .LT. 2) RETURN
      MMK = M - KRANK
      KP1 = KRANK + 1
      I = KRANK
  340    TN = SNRM2(MMK,A(KP1,I),1)/A(I,I)
         TN = A(I,I)*SQRT(1.0 + TN*TN)
         CALL SSCAL (MMK,1.0/TN,A(KP1,I),1)
         W(I) = A(I,I)/TN + 1.0
         A(I,I) = -TN
         IF (I .EQ. 1) GO TO 350
         IM1 = I - 1
         DO 345 II = 1,IM1
            TT = -SDOT(MMK,A(KP1,II),1,A(KP1,I),1)/W(I)
            TT = TT - A(I,II)
            CALL SAXPY (MMK,TT,A(KP1,I),1,A(KP1,II),1)
            A(I,II) = A(I,II) + TT*W(I)
  345    CONTINUE
         I = I - 1
         GO TO 340
C
  350 CONTINUE
      RETURN
C
C     FIRST NP ROWS ARE LINEARLY DEPENDENT
C
  400 KRANK = I - 1
      RETURN
  410 KRANK = J - 1
      RETURN
      END
      SUBROUTINE U12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,H,W,IR,IC)
C
C        GIVEN THE HOUSEHOLDER LQ FACTORIZATION OF A, THIS
C        SUBROUTINE SOLVES THE SYSTEM AX=B. IF THE SYSTEM
C        IS OF REDUCED RANK, THIS ROUTINE RETURNS A SOLUTION
C        ACCORDING TO THE SELECTED MODE.
C
C       NOTE - IF MODE.NE.2, W IS NEVER ACCESSED.
C
      DIMENSION A(MDA,N),B(MDB,NB),RNORM(NB),H(M),W(M)
      INTEGER IC(N),IR(M)
C
      K = KRANK
      KP1 = K + 1
      IF (K .GT. 0) GO TO 30
C
C        RANK=0
C
      DO 10 JB = 1,NB
         RNORM(JB) = SNRM2(M,B(1,JB),1)
   10 CONTINUE
      DO 21 JB = 1,NB
         DO 20 I = 1,N
            B(I,JB) = 0.0
   20    CONTINUE
   21 CONTINUE
      RETURN
C
   30 I = 0
C
C     REORDER B TO REFLECT ROW INTERCHANGES
C
   40    I = I + 1
         IF (I .EQ. M) GO TO 100
         J = IR(I)
         IF (J .EQ. I) GO TO 40
         IF (J .LT. 0) GO TO 40
C
         IR(I) = -IR(I)
         DO 50 JB = 1,NB
            RNORM(JB) = B(I,JB)
   50    CONTINUE
C
         IJ = I
   60       DO 70 JB = 1,NB
               B(IJ,JB) = B(J,JB)
   70       CONTINUE
            IJ = J
            J = IR(IJ)
            IR(IJ) = -IR(IJ)
         IF (J .NE. I) GO TO 60
C
         DO 80 JB = 1,NB
            B(IJ,JB) = RNORM(JB)
   80    CONTINUE
         GO TO 40
C
  100 DO 110 I = 1,M
         IR(I) = IABS(IR(I))
  110 CONTINUE
C
C     IF A IS OF REDUCED RANK AND MODE=2,
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO B
C
      IF (MODE .LT. 2 .OR. K .EQ. M) GO TO 140
      MMK = M - K
      DO 130 JB = 1,NB
         DO 120 J = 1,K
            I = KP1 - J
            TT = -SDOT(MMK,A(KP1,I),1,B(KP1,JB),1)/W(I)
            TT = TT - B(I,JB)
            CALL SAXPY (MMK,TT,A(KP1,I),1,B(KP1,JB),1)
            B(I,JB) = B(I,JB) + TT*W(I)
  120    CONTINUE
  130 CONTINUE
C
C     FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B)
C
  140 DO 150 JB = 1,NB
         RNORM(JB) = SNRM2(M-K,B(KP1,JB),1)
  150 CONTINUE
C
C     BACK SOLVE LOWER TRIANGULAR L
C
      DO 170 JB = 1,NB
         DO 160 I = 1,K
            B(I,JB) = B(I,JB)/A(I,I)
            IF (I .EQ. K) GO TO 170
            IP1 = I + 1
            CALL SAXPY(K-I,-B(I,JB),A(IP1,I),1,B(IP1,JB),1)
  160    CONTINUE
  170 CONTINUE
C
C      TRUNCATED SOLUTION
C
      IF (K .EQ. N) GO TO 210
      DO 201 JB = 1,NB
         DO 200 I = KP1,N
            B(I,JB) = 0.0
  200    CONTINUE
  201 CONTINUE
C
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO B
C
  210 DO 230 I = 1,K
         J = KP1 - I
         TT = A(J,J)
         A(J,J) = H(J)
         DO 220 JB = 1,NB
            BB = -SDOT(N-J+1,A(J,J),MDA,B(J,JB),1)/H(J)
            CALL SAXPY(N-J+1,BB,A(J,J),MDA,B(J,JB),1)
  220    CONTINUE
         A(J,J) = TT
  230 CONTINUE
C
C     REORDER B TO REFLECT COLUMN INTERCHANGES
C
      I = 0
C
  240    I = I + 1
         IF (I .EQ. N) GO TO 260
         J = IC(I)
         IF (J .EQ. I) GO TO 240
         IF (J .LT. 0) GO TO 240
C
         IC(I) = -IC(I)
  250       CALL SSWAP (NB,B(J,1),MDB,B(I,1),MDB)
            IJ = IC(J)
            IC(J) = -IC(J)
            J = IJ
         IF (J .NE. I) GO TO 250
         GO TO 240
C
  260 DO 270 I = 1,N
         IC(I) = IABS(IC(I))
  270 CONTINUE
      RETURN
      END
      SUBROUTINE DLSQR (IND, A, MDA, M, N, B, MDB, NB, RE, AE, KRANK,
     *                  KSURE, RNORM, WORK, LW, IWORK, LIW, IERR)
C-----------------------------------------------------------------------
C
C              LEAST SQUARES SOLUTION OF LINEAR EQUATIONS
C
C                            --------------
C
C     DLSQR SOLVES BOTH UNDERDETERMINED AND OVERDETERMINED LINEAR
C     SYSTEMS AX = B, WHERE A IS AN M BY N MATRIX AND B IS AN M BY
C     NB MATRIX OF RIGHT HAND SIDES. IF M .GE. N, THE LEAST SQUARES
C     SOLUTION IS COMPUTED BY DECOMPOSING THE MATRIX A INTO THE
C     PRODUCT OF AN ORTHOGONAL MATRIX Q AND UPPER TRIANGULAR MATRIX
C     R (QR FACTORIZATION). IF M .LT. N, THE MINIMAL LENGTH SOLUTION
C     IS COMPUTED BY FACTORING THE MATRIX A INTO THE PRODUCT OF A
C     LOWER TRIANGULAR MATRIX L AND ORTHOGONAL MATRIX Q (LQ FACTOR-
C     IZATION). IF THE MATRIX A IS DETERMINED TO BE RANK DEFICIENT,
C     THEN THE MINIMAL LENGTH LEAST SQUARES SOLUTION IS COMPUTED.
C
C     USER INPUT BOUNDS ON THE UNCERTAINTY OF THE ELEMENTS OF A ARE
C     USED TO DETECT NUMERICAL RANK DEFICIENCY. THE ALGORITHM USES
C     A ROW AND COLUMN PIVOT STRATEGY TO MINIMIZE THE GROWTH OF
C     UNCERTAINTY AND ROUND-OFF ERRORS.
C
C   ******************************************************************
C   *                                                                *
C   *         WARNING - ALL INPUT ARRAYS ARE CHANGED ON EXIT.        *
C   *                                                                *
C   ******************************************************************
C
C     INPUT..
C
C     IND           INTEGER WHICH INDICATES IF THE ROUTINE IS BEING
C                   CALLED FOR THE FIRST TIME.
C                      IND = 0      ORIGINAL CALL
C                      IND .NE. 0   SUBSEQUENT CALLS
C                   ON SUBSEQUENT CALLS A NEW SET B OF EQUATIONS CAN
C                   BE SOLVED (USING THE SAME COEFFICIENT MATRIX A).
C                   IT IS ASSUMED THAT A, MDA, M, N, KRANK, IWORK,
C                   LIW, AND THE FIRST 2*MIN(M,N) LOCATIONS OF WORK
C                   HAVE NOT BEEN MODIFIED BY THE USER. RE, AE, AND
C                   KSURE ARE NOT USED.
C
C     A(,)          LINEAR COEFFICIENT MATRIX OF AX=B, WITH MDA THE
C      MDA,M,N      ACTUAL FIRST DIMENSION OF A IN THE CALLING PROGRAM.
C                   M IS THE ROW DIMENSION (NO. OF EQUATIONS OF THE
C                   PROBLEM) AND N THE COL DIMENSION (NO. OF UNKNOWNS).
C                   MUST HAVE MDA .GE. M.
C
C     B(,)          RIGHT HAND SIDE(S), WITH MDB THE ACTUAL FIRST
C      MDB,NB       DIMENSION OF B IN THE CALLING PROGRAM. NB IS THE
C                   NUMBER OF M BY 1 RIGHT HAND SIDES. MUST HAVE
C                   MDB .GE. MAX(M,N). IF NB .LE. 0 THEN B AND MDB
C                   ARE IGNORED.
C
C     RE            RE IS THE MAXIMUM RELATIVE UNCERTAINTY OF THE
C                   ELEMENTS OF THE MATRIX A (0 .LE. RE .LT. 1).
C
C     AE            AE IS THE MAXIMUM ABSOLUTE UNCERTAINTY OF THE
C                   ELEMENTS OF THE MATRIX A (AE .GE. 0).
C
C     WORK()        A REAL WORK ARRAY DIMENSIONED 5*MIN(M,N).
C
C     LW            ACTUAL DIMENSION OF WORK
C
C     IWORK()       INTEGER WORK ARRAY DIMENSIONED AT LEAST N+M.
C
C     LIW           ACTUAL DIMENSION OF IWORK.
C
C     OUTPUT..
C
C     A(,)          CONTAINS THE TRIANGULAR PART OF THE REDUCED MATRIX
C                   AND THE TRANSFORMATION INFORMATION.IND TOGETHER WITH
C                   THE FIRST 2*MIN(M,N) ELEMENTS OF WORK (SEE BELOW)
C                   COMPLETELY SPECIFY THE FACTORIZATION OF A.
C
C     B(,)          CONTAINS THE N BY NB SOLUTION MATRIX FOR X.
C
C     KRANK,KSURE   THE NUMERICAL RANK OF A,  BASED UPON THE RELATIVE
C                   AND ABSOLUTE BOUNDS ON UNCERTAINTY, IS BOUNDED
C                   ABOVE BY KRANK AND BELOW BY KSURE. THE ALGORITHM
C                   RETURNS A SOLUTION BASED ON KRANK. KSURE PROVIDES
C                   AN INDICATION OF THE PRECISION OF THE RANK.
C
C     RNORM()       CONTAINS THE EUCLIDEAN LENGTH OF THE NB RESIDUAL
C                   VECTORS  B(I) - AX(I), I=1,...,NB.
C
C     WORK()        THE FIRST 2*MIN(M,N) LOCATIONS OF WORK CONTAIN
C                   THE VALUES NECESSARY TO REPRODUCE THE HOUSEHOLDER
C                   FACTORIZATION OF A.
C
C     IWORK()       AN ARRAY OF LENGTH M + N CONTAINING THE ORDERS IN
C                   WHICH THE ROWS AND COLUMNS WERE USED. IF M .GE. N
C                   THEN THE FIRST N LOCATIONS CONTAIN THE ORDER OF
C                   THE COLUMNS AND THE NEXT M LOCATIONS THE ORDER OF
C                   THE ROWS. IF M .LT. N THEN THE ORDER OF THE ROWS
C                   PRECEDES THE ORDER OF THE COLUMNS.
C
C     IERR          FLAG TO INDICATE THE STATUS OF THE RESULTS
C                     0     - SATISFACTORY COMPLETION
C                   .GT. 0  - INPUT ERROR
C
C----------------
C     THE SUBROUTINES DU11LS, DU12LS, DU11US, AND DU12US WERE WRITTEN BY
C     T. MANTEUFFEL (LANL) IN 1981. THE DRIVER ROUTINE DLSQR WAS WRITTEN
C     BY A.H. MORRIS (NSWC) IN 1991.
C----------------
C     REFERENCE.  MANTEUFFEL, T., *AN INTERVAL ANALYSIS APPROACH TO RANK
C                 DETERMINATION IN LINEAR LEAST SQUARES PROBLEMS*,
C                 SANDIA LABORATORIES REPORT SAND80-0655, JUNE, 1980.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(MDA,N), B(MDB,*), RE, AE, RNORM(*), WORK(LW)
      INTEGER IWORK(LIW)
      DOUBLE PRECISION EPS, RERR
      DOUBLE PRECISION DPMPAR
C----------------
C     NP            IF M .GE. N THEN THE FIRST NP COLUMNS OF A
C                   ARE NEVER INTERCHANGED.
C                   IF M .LT. N THEN THE FIRST NP ROWS OF A ARE
C                   NEVER INTERCHANGED. NP IS NOT REFERENCED ON
C                   A CONTINUATION CALL TO THE ROUTINE.
C
C     MODE          THE INTEGER MODE INDICATES HOW THE ROUTINE
C                   IS TO REACT IF RANK DEFICIENCY IS DETECTED.
C                   IF MODE = 0 RETURN IMMEDIATELY, NO SOLUTION
C                             1 COMPUTE TRUNCATED SOLUTION
C                             2 COMPUTE MINIMAL LENGTH SOLUTION
C                   MODE MUST NOT BE MODIFIED ON A CONTINUATION
C                   CALL TO THE ROUTINE. IF MODE LT. 2, ONLY THE
C                   FIRST N LOCATIONS OF WORK ARE USED.
C----------------
      NP = 0
      MODE = 2
C
C     CHECK THE INPUT
C
      IF (NB .LE. 0 .AND. IND .NE. 0) GO TO 200
      IF (M .LT. 1 .OR. N .LT. 1) GO TO 210
      IF (MDA .LT. M) GO TO 220
      IF (LIW .LT. M + N) GO TO 240
C
      M0 = MIN0(M,N)
      N0 = MAX0(M,N)
C     NUM = 0
C
      IF (NB .LE. 0) GO TO 10
      IF (MDB .LT. N0) GO TO 230
      IF (IND .NE. 0) GO TO 100
C
   10 IF (LW .LT. 5*M0) GO TO 250
      IF (RE .LT. 0.D0 .OR. AE .LT. 0.D0) GO TO 260
C
C     DEFINE THE RELATIVE AND ABSOLUTE TOLERANCE LISTS
C
      M1 = 1
      M2 = M1 + M0
      M3 = M2 + M0
      M4 = M3 + M0
      M5 = M4 + M0
C
      EPS = 10.D0*DPMPAR(1)
      RERR = DMAX1(EPS,RE)
C
      IMAX = M5 - 1
      DO 20 I = M4,IMAX
         WORK(I) = RERR
   20 CONTINUE
      IMAX = IMAX + M0
      DO 30 I = M5,IMAX
         WORK(I) = AE
   30 CONTINUE
C
C     FACTOR THE MATRIX A
C
C     NUM = NP
      IF (M .LT. N) GO TO 40
C
         CALL DU11LS (A,MDA,M,N,WORK(M4),WORK(M5),MODE,NP,KRANK,KSURE,
     *                WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2))
         GO TO 100
C
   40 CALL DU11US (A,MDA,M,N,WORK(M4),WORK(M5),MODE,NP,KRANK,KSURE,
     *             WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2))
C
C     SOLUTION PHASE
C
  100 IERR = 0
      INFO = 0
      IF (KRANK .EQ. M0) GO TO 110
      IF (KRANK .EQ. 0) GO TO 110
C     IF (KRANK .LT. NUM) GO TO 280
C     IF (MODE .EQ. 0) RETURN
      INFO = MODE
C
  110 IF (NB .LE. 0) RETURN
C
      M1 = 1
      M2 = 1 + M0
      IF (INFO .EQ. 2) GO TO 130
C
C     ONLY MIN(M,N) ELEMENTS OF WORK ARE NEEDED
C
      IF (LW .LT. M0) GO TO 250
      IF (M .LT. N) GO TO 120
C
         CALL DU12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,
     *                WORK(M1),WORK(M1),IWORK(M1),IWORK(M2))
         RETURN
C
  120 CALL DU12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,
     *             WORK(M1),WORK(M1),IWORK(M1),IWORK(M2))
      RETURN
C
C     HERE 2*MIN(M,N) ELEMENTS OF WORK ARE NEEDED
C
  130 IF (LW .LT. 2*M0) GO TO 250
      IF (M .LT. N) GO TO 140
C
         CALL DU12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,
     *                WORK(M1),WORK(M2),IWORK(M1),IWORK(M2))
         RETURN
C
 140  CALL DU12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,
     *             WORK(M1),WORK(M2),IWORK(M1),IWORK(M2))
      RETURN
C
C     ERROR RETURN
C
C                             NB .LE. 0  ON A CONTINUATION CALL
  200 IERR = 7
      RETURN
C                             M .LT. 1 OR N .LT. 1
  210 IERR = 1
      RETURN
C                             MDA .LT. M
  220 IERR = 2
      RETURN
C                             MDB .LT. MAX(M,N)
  230 IERR = 3
      RETURN
C                             LIW .LT. M + N
  240 IERR = 4
      RETURN
C                             LW TOO SMALL
  250 IERR = 5
      RETURN
C                             RE OR AE IS NEGATIVE
  260 IERR = 6
      RETURN
C                             0 .LT. KRANK .LT. NP
C 280 IERR = 8
C     RETURN
      END
      SUBROUTINE DU11LS (A,MDA,M,N,UB,DB,MODE,NP,KRANK,KSURE,H,W,EB,
     *                   IC,IR)
C
C       THIS ROUTINE PERFORMS A QR FACTORIZATION OF A
C       USING HOUSEHOLDER TRANSFORMATIONS. ROW AND
C       COLUMN PIVOTS ARE CHOSEN TO REDUCE THE GROWTH
C       OF ROUND-OFF AND TO HELP DETECT POSSIBLE RANK
C       DEFICIENCY.
C
      DOUBLE PRECISION A(MDA,N), UB(N), DB(N), H(N), W(N), EB(N)
      INTEGER IC(N), IR(M)
      DOUBLE PRECISION BB, RMIN, R2, SUM, T, TEMP, TN, TT
      DOUBLE PRECISION DDOT, DNRM2
C
C        INITIALIZATION
C
      J = 0
      KRANK = N
      DO 10 I = 1,N
         IC(I) = I
   10 CONTINUE
      DO 20 I = 1,M
         IR(I) = I
   20 CONTINUE
C
C        DETERMINE REL AND ABS ERROR VECTORS
C
C
C        CALCULATE COL LENGTH
C
      DO 30 I = 1,N
         H(I) = DNRM2(M,A(1,I),1)
         W(I) = H(I)
   30 CONTINUE
C
C         INITIALIZE ERROR BOUNDS
C
      DO 40 I = 1,N
         EB(I) = DMAX1(DB(I),UB(I)*H(I))
         UB(I) = EB(I)
         DB(I) = 0.D0
   40 CONTINUE
C
C          DISCARD SELF DEPENDENT COLUMNS
C
      I = 1
   50 IF (EB(I) .GE. H(I)) GO TO 60
      IF (I .EQ. KRANK) GO TO 70
      I = I + 1
      GO TO 50
C
C          MATRIX REDUCTION
C
   60 KK = KRANK
      KRANK = KRANK - 1
      IF (MODE .EQ. 0) RETURN
      IF (I .LE. NP) GO TO 400
      IF (I .GT. KRANK) GO TO 70
      CALL DSWAP (1,EB(I),1,EB(KK),1)
      CALL DSWAP (1,UB(I),1,UB(KK),1)
      CALL DSWAP (1,W(I),1,W(KK),1)
      CALL DSWAP (1,H(I),1,H(KK),1)
      CALL ISWAP (1,IC(I),1,IC(KK),1)
      CALL DSWAP (M,A(1,I),1,A(1,KK),1)
      GO TO 50
C
C           TEST FOR ZERO RANK
C
   70 IF (KRANK .GT. 0) GO TO 100
      KRANK = 0
      KSURE = 0
      RETURN
C
C        M A I N    L O O P
C
  100 J = J + 1
      JP1 = J + 1
      JM1 = J - 1
      KZ = KRANK
      IF (J .LE. NP) KZ = J
C
C        EACH COL HAS MM=M-J+1 COMPONENTS
C
      MM = M - J + 1
C
C         UB DETERMINES COLUMN PIVOT
C
  110 IMIN = J
      IF (H(J) .EQ. 0.D0) GO TO 170
      RMIN = UB(J)/H(J)
      DO 120 I = J,KZ
         IF (UB(I) .GE. H(I)*RMIN) GO TO 120
         RMIN = UB(I)/H(I)
         IMIN = I
  120 CONTINUE
C
C     TEST FOR RANK DEFICIENCY
C
      IF (RMIN .LT. 1.D0) GO TO 200
      TT = (EB(IMIN) + DABS(DB(IMIN)))/H(IMIN)
      IF (TT .GE. 1.D0) GO TO 170
C
C     COMPUTE EXACT UB
C
      DO 125 I = 1,JM1
         W(I) = A(I,IMIN)
  125 CONTINUE
C
      L = JM1
  130 W(L) = W(L)/A(L,L)
      IF (L .EQ. 1) GO TO 150
      LM1 = L - 1
      DO 140 I = L,JM1
         W(LM1) = W(LM1) - A(LM1,I)*W(I)
  140 CONTINUE
      L = LM1
      GO TO 130
C
  150 TT = EB(IMIN)
      DO 160 I = 1,JM1
         TT = TT + DABS(W(I))*EB(I)
  160 CONTINUE
      UB(IMIN) = TT
      IF (UB(IMIN)/H(IMIN) .GE. 1.D0) GO TO 170
      GO TO 200
C
C        MATRIX REDUCTION
C
  170 KK = KRANK
      KRANK = KRANK - 1
      KZ = KRANK
      IF (MODE .EQ. 0) RETURN
      IF (J .LE. NP) GO TO 410
      IF (IMIN .GT. KRANK) GO TO 180
         CALL ISWAP (1,IC(IMIN),1,IC(KK),1)
         CALL DSWAP (M,A(1,IMIN),1,A(1,KK),1)
         CALL DSWAP (1,EB(IMIN),1,EB(KK),1)
         CALL DSWAP (1,UB(IMIN),1,UB(KK),1)
         CALL DSWAP (1,DB(IMIN),1,DB(KK),1)
         CALL DSWAP (1,W(IMIN),1,W(KK),1)
         CALL DSWAP (1,H(IMIN),1,H(KK),1)
  180 IF (J .GT. KRANK) GO TO 300
      GO TO 110
C
C        COLUMN PIVOT
C
  200 IF (IMIN .EQ. J) GO TO 210
      CALL DSWAP (1,H(J),1,H(IMIN),1)
      CALL DSWAP (M,A(1,J),1,A(1,IMIN),1)
      CALL DSWAP (1,EB(J),1,EB(IMIN),1)
      CALL DSWAP (1,UB(J),1,UB(IMIN),1)
      CALL DSWAP (1,DB(J),1,DB(IMIN),1)
      CALL DSWAP (1,W(J),1,W(IMIN),1)
      CALL ISWAP (1,IC(J),1,IC(IMIN),1)
C
C        ROW PIVOT
C
  210 JMAX = IDAMAX(MM,A(J,J),1)
      JMAX = JMAX + J - 1
      IF (JMAX .EQ. J) GO TO 220
      CALL DSWAP (N,A(J,1),MDA,A(JMAX,1),MDA)
      CALL ISWAP (1,IR(J),1,IR(JMAX),1)
C
C     APPLY HOUSEHOLDER TRANSFORMATION
C
  220 TN = DNRM2(MM,A(J,J),1)
      IF (TN .EQ. 0.D0) GO TO 170
      IF (A(J,J) .NE. 0.D0) TN = DSIGN(TN,A(J,J))
      CALL DSCAL (MM,1.D0/TN,A(J,J),1)
      A(J,J) = A(J,J) + 1.D0
      IF (J .EQ. N) GO TO 250
      DO 240 I = JP1,N
         BB = -DDOT(MM,A(J,J),1,A(J,I),1)/A(J,J)
         CALL DAXPY (MM,BB,A(J,J),1,A(J,I),1)
         IF (I .LE. NP) GO TO 240
         IF (H(I) .EQ. 0.D0) GO TO 240
         TT = 1.D0 - (A(J,I)/H(I))**2
         TT = DMAX1(TT,0.D0)
         T = TT
         TT = 1.D0 + 0.05D0*TT*(H(I)/W(I))**2
         IF (TT .EQ. 1.D0) GO TO 230
            H(I) = H(I)*DSQRT(T)
            GO TO 240
  230    H(I) = DNRM2(M-J,A(J+1,I),1)
         W(I) = H(I)
  240 CONTINUE
C
  250 H(J) = A(J,J)
      A(J,J) = -TN
C
C          UPDATE UB, DB
C
      UB(J) = UB(J)/DABS(A(J,J))
      DB(J) = (DSIGN(EB(J),DB(J)) + DB(J))/A(J,J)
      IF (J .EQ. KRANK) GO TO 300
      DO 260 I = JP1,KRANK
         UB(I) = UB(I) + DABS(A(J,I))*UB(J)
         DB(I) = DB(I) - A(J,I)*DB(J)
  260 CONTINUE
      GO TO 100
C
C        E N D    M A I N    L O O P
C
  300 CONTINUE
C
C        COMPUTE KSURE
C
      KM1 = KRANK - 1
      DO 315 I = 1,KM1
         IS = 0
         KMI = KRANK - I
         DO 310 II = 1,KMI
            IF (UB(II) .LE. UB(II + 1)) GO TO 310
            IS = 1
            TEMP = UB(II)
            UB(II) = UB(II + 1)
            UB(II + 1) = TEMP
  310    CONTINUE
         IF (IS .EQ. 0) GO TO 320
  315 CONTINUE
C
  320 KSURE = 0
      SUM = 0.D0
      DO 325 I = 1,KRANK
         R2 = UB(I)*UB(I)
         IF (R2 + SUM .GE. 1.D0) GO TO 330
         SUM = SUM + R2
         KSURE = KSURE + 1
  325 CONTINUE
C
C     IF SYSTEM IS OF REDUCED RANK AND MODE = 2
C     COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION
C
  330 IF (KRANK .EQ. N .OR. MODE .LT. 2) RETURN
      NMK = N - KRANK
      KP1 = KRANK + 1
      I = KRANK
  340    TN = DNRM2(NMK,A(I,KP1),MDA)/A(I,I)
         TN = A(I,I)*DSQRT(1.D0 + TN*TN)
         CALL DSCAL (NMK,1.D0/TN,A(I,KP1),MDA)
         W(I) = A(I,I)/TN + 1.D0
         A(I,I) = -TN
         IF (I .EQ. 1) GO TO 350
         IM1 = I - 1
         DO 345 II = 1,IM1
            TT = -DDOT(NMK,A(II,KP1),MDA,A(I,KP1),MDA)/W(I)
            TT = TT - A(II,I)
            CALL DAXPY (NMK,TT,A(I,KP1),MDA,A(II,KP1),MDA)
            A(II,I) = A(II,I) + TT*W(I)
  345    CONTINUE
         I = I - 1
         GO TO 340
C
  350 CONTINUE
      RETURN
C
C     FIRST NP COLUMNS ARE LINEARLY DEPENDENT
C
  400 KRANK = I - 1
      RETURN
  410 KRANK = J - 1
      RETURN
      END
      SUBROUTINE DU12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,H,W,IC,IR)
C
C        GIVEN THE HOUSEHOLDER QR FACTORIZATION OF A, THIS
C        SUBROUTINE SOLVES THE SYSTEM AX=B. IF THE SYSTEM
C        IS OF REDUCED RANK, THIS ROUTINE RETURNS A SOLUTION
C        ACCORDING TO THE SELECTED MODE.
C
C       NOTE - IF MODE.NE.2, W IS NEVER ACCESSED.
C
      DOUBLE PRECISION A(MDA,N), B(MDB,NB), RNORM(NB), H(N), W(N)
      INTEGER IC(N), IR(M)
      DOUBLE PRECISION BB, TT
      DOUBLE PRECISION DDOT, DNRM2
C
      K = KRANK
      KP1 = K + 1
      IF (K .GT. 0) GO TO 30
C
C        RANK=0
C
      DO 10 JB = 1,NB
         RNORM(JB) = DNRM2(M,B(1,JB),1)
   10 CONTINUE
      DO 21 JB = 1,NB
         DO 20 I = 1,N
            B(I,JB) = 0.D0
   20    CONTINUE
   21 CONTINUE
      RETURN
C
   30 I = 0
C
C     REORDER B TO REFLECT ROW INTERCHANGES
C
   40    I = I + 1
         IF (I .EQ. M) GO TO 100
         J = IR(I)
         IF (J .EQ. I) GO TO 40
         IF (J .LT. 0) GO TO 40
C
         IR(I) = -IR(I)
         DO 50 JB = 1,NB
            RNORM(JB) = B(I,JB)
   50    CONTINUE
C
         IJ = I
   60       DO 70 JB = 1,NB
               B(IJ,JB) = B(J,JB)
   70       CONTINUE
            IJ = J
            J = IR(IJ)
            IR(IJ) = -IR(IJ)
         IF (J .NE. I) GO TO 60
C
         DO 80 JB = 1,NB
            B(IJ,JB) = RNORM(JB)
   80    CONTINUE
         GO TO 40
C
  100 DO 110 I = 1,M
         IR(I) = IABS(IR(I))
  110 CONTINUE
C
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO B
C
      DO 130 J = 1,K
         TT = A(J,J)
         A(J,J) = H(J)
         DO 120 I = 1,NB
            BB = -DDOT (M-J+1,A(J,J),1,B(J,I),1)/H(J)
            CALL DAXPY (M-J+1,BB,A(J,J),1,B(J,I),1)
  120    CONTINUE
         A(J,J) = TT
  130 CONTINUE
C
C        FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B)
C
      DO 140 JB = 1,NB
         RNORM(JB) = DNRM2(M-K,B(KP1,JB),1)
  140 CONTINUE
C
C     BACK SOLVE UPPER TRIANGULAR R
C
      I = K
  150 DO 160 JB = 1,NB
         B(I,JB) = B(I,JB)/A(I,I)
  160 CONTINUE
      IF (I .EQ. 1) GO TO 200
      IM1 = I - 1
      DO 170 JB = 1,NB
         CALL DAXPY (IM1,-B(I,JB),A(1,I),1,B(1,JB),1)
  170 CONTINUE
      I = IM1
      GO TO 150
C
C     RANK LT N
C
C      TRUNCATED SOLUTION
C
  200 IF (K .EQ. N) GO TO 230
      DO 211 JB = 1,NB
         DO 210 I = KP1,N
            B(I,JB) = 0.D0
  210    CONTINUE
  211 CONTINUE
      IF (MODE .EQ. 1) GO TO 230
C
C      MINIMAL LENGTH SOLUTION
C
      NMK = N - K
      DO 221 JB = 1,NB
         DO 220 I = 1,K
            TT = -DDOT(NMK,A(I,KP1),MDA,B(KP1,JB),1)/W(I)
            TT = TT - B(I,JB)
            CALL DAXPY (NMK,TT,A(I,KP1),MDA,B(KP1,JB),1)
            B(I,JB) = B(I,JB) + TT*W(I)
  220    CONTINUE
  221 CONTINUE
C
C     REORDER B TO REFLECT COLUMN INTERCHANGES
C
  230 I = 0
C
  240    I = I + 1
         IF (I .EQ. N) GO TO 260
         J = IC(I)
         IF (J .EQ. I) GO TO 240
         IF (J .LT. 0) GO TO 240
C
         IC(I) = -IC(I)
  250       CALL DSWAP (NB,B(J,1),MDB,B(I,1),MDB)
            IJ = IC(J)
            IC(J) = -IC(J)
            J = IJ
         IF (J .NE. I) GO TO 250
         GO TO 240
C
  260 DO 270 I = 1,N
         IC(I) = IABS(IC(I))
  270 CONTINUE
      RETURN
      END
      SUBROUTINE DU11US (A,MDA,M,N,UB,DB,MODE,NP,KRANK,KSURE,H,W,EB,
     *                   IR,IC)
C
C       THIS ROUTINE PERFORMS AN LQ FACTORIZATION OF THE
C       MATRIX A USING HOUSEHOLDER TRANSFORMATIONS. ROW
C       AND COLUMN PIVOTS ARE CHOSEN TO REDUCE THE GROWTH
C       OF ROUND-OFF AND TO HELP DETECT POSSIBLE RANK
C       DEFICIENCY.
C
      DOUBLE PRECISION A(MDA,N), UB(M), DB(M), H(M), W(M), EB(M)
      INTEGER IC(N), IR(M)
      DOUBLE PRECISION BB, RMIN, R2, SUM, T, TEMP, TN, TT
      DOUBLE PRECISION DDOT, DNRM2
C
C        INITIALIZATION
C
      J = 0
      KRANK = M
      DO 10 I = 1,N
         IC(I) = I
   10 CONTINUE
      DO 20 I = 1,M
         IR(I) = I
   20 CONTINUE
C
C        DETERMINE REL AND ABS ERROR VECTORS
C
C
C        CALCULATE ROW LENGTH
C
      DO 30 I = 1,M
         H(I) = DNRM2(N,A(I,1),MDA)
         W(I) = H(I)
   30 CONTINUE
C
C         INITIALIZE ERROR BOUNDS
C
      DO 40 I = 1,M
         EB(I) = DMAX1(DB(I),UB(I)*H(I))
         UB(I) = EB(I)
         DB(I) = 0.D0
   40 CONTINUE
C
C          DISCARD SELF DEPENDENT ROWS
C
      I = 1
   50 IF (EB(I) .GE. H(I)) GO TO 60
      IF (I .EQ. KRANK) GO TO 70
      I = I + 1
      GO TO 50
C
C          MATRIX REDUCTION
C
   60 KK = KRANK
      KRANK = KRANK - 1
      IF (MODE .EQ. 0) RETURN
      IF (I .LE. NP) GO TO 400
      IF (I .GT. KRANK) GO TO 70
      CALL DSWAP (1,EB(I),1,EB(KK),1)
      CALL DSWAP (1,UB(I),1,UB(KK),1)
      CALL DSWAP (1,W(I),1,W(KK),1)
      CALL DSWAP (1,H(I),1,H(KK),1)
      CALL ISWAP (1,IR(I),1,IR(KK),1)
      CALL DSWAP (N,A(I,1),MDA,A(KK,1),MDA)
      GO TO 50
C
C           TEST FOR ZERO RANK
C
   70 IF (KRANK .GT. 0) GO TO 100
      KRANK = 0
      KSURE = 0
      RETURN
C
C        M A I N    L O O P
C
  100 J = J + 1
      JP1 = J + 1
      JM1 = J - 1
      KZ = KRANK
      IF (J .LE. NP) KZ = J
C
C        EACH ROW HAS NN=N-J+1 COMPONENTS
C
      NN = N - J + 1
C
C         UB DETERMINES ROW PIVOT
C
  110 IMIN = J
      IF (H(J) .EQ. 0.D0) GO TO 170
      RMIN = UB(J)/H(J)
      DO 120 I = J,KZ
         IF (UB(I) .GE. H(I)*RMIN) GO TO 120
         RMIN = UB(I)/H(I)
         IMIN = I
  120 CONTINUE
C
C     TEST FOR RANK DEFICIENCY
C
      IF (RMIN .LT. 1.D0) GO TO 200
      TT = (EB(IMIN) + DABS(DB(IMIN)))/H(IMIN)
      IF (TT .GE. 1.D0) GO TO 170
C
C     COMPUTE EXACT UB
C
      DO 125 I = 1,JM1
         W(I) = A(IMIN,I)
  125 CONTINUE
C
      L = JM1
  130 W(L) = W(L)/A(L,L)
      IF (L .EQ. 1) GO TO 150
      LM1 = L - 1
      DO 140 I = L,JM1
         W(LM1) = W(LM1) - A(I,LM1)*W(I)
  140 CONTINUE
      L = LM1
      GO TO 130
C
  150 TT = EB(IMIN)
      DO 160 I = 1,JM1
         TT = TT + DABS(W(I))*EB(I)
  160 CONTINUE
      UB(IMIN) = TT
      IF (UB(IMIN)/H(IMIN) .GE. 1.D0) GO TO 170
      GO TO 200
C
C        MATRIX REDUCTION
C
  170 KK = KRANK
      KRANK = KRANK - 1
      KZ = KRANK
      IF (MODE .EQ. 0) RETURN
      IF (J .LE. NP) GO TO 410
      IF (IMIN .GT. KRANK) GO TO 180
         CALL ISWAP (1,IR(IMIN),1,IR(KK),1)
         CALL DSWAP (N,A(IMIN,1),MDA,A(KK,1),MDA)
         CALL DSWAP (1,EB(IMIN),1,EB(KK),1)
         CALL DSWAP (1,UB(IMIN),1,UB(KK),1)
         CALL DSWAP (1,DB(IMIN),1,DB(KK),1)
         CALL DSWAP (1,W(IMIN),1,W(KK),1)
         CALL DSWAP (1,H(IMIN),1,H(KK),1)
  180 IF (J .GT. KRANK) GO TO 300
      GO TO 110
C
C        ROW PIVOT
C
  200 IF (IMIN .EQ. J) GO TO 210
      CALL DSWAP (1,H(J),1,H(IMIN),1)
      CALL DSWAP (N,A(J,1),MDA,A(IMIN,1),MDA)
      CALL DSWAP (1,EB(J),1,EB(IMIN),1)
      CALL DSWAP (1,UB(J),1,UB(IMIN),1)
      CALL DSWAP (1,DB(J),1,DB(IMIN),1)
      CALL DSWAP (1,W(J),1,W(IMIN),1)
      CALL ISWAP (1,IR(J),1,IR(IMIN),1)
C
C        COLUMN PIVOT
C
  210 JMAX = IDAMAX(NN,A(J,J),MDA)
      JMAX = JMAX + J - 1
      IF (JMAX .EQ. J) GO TO 220
      CALL DSWAP (M,A(1,J),1,A(1,JMAX),1)
      CALL ISWAP (1,IC(J),1,IC(JMAX),1)
C
C     APPLY HOUSEHOLDER TRANSFORMATION
C
  220 TN = DNRM2(NN,A(J,J),MDA)
      IF (TN .EQ. 0.D0) GO TO 170
      IF (A(J,J) .NE. 0.D0) TN = DSIGN(TN,A(J,J))
      CALL DSCAL (NN,1.D0/TN,A(J,J),MDA)
      A(J,J) = A(J,J) + 1.D0
      IF (J .EQ. M) GO TO 250
      DO 240 I = JP1,M
         BB = -DDOT(NN,A(J,J),MDA,A(I,J),MDA)/A(J,J)
         CALL DAXPY (NN,BB,A(J,J),MDA,A(I,J),MDA)
         IF (I .LE. NP) GO TO 240
         IF (H(I) .EQ. 0.D0) GO TO 240
         TT = 1.0 - (A(I,J)/H(I))**2
         TT = DMAX1(TT,0.D0)
         T = TT
         TT = 1.D0 + 0.05D0*TT*(H(I)/W(I))**2
         IF (TT .EQ. 1.D0) GO TO 230
            H(I) = H(I)*DSQRT(T)
            GO TO 240
  230    H(I) = DNRM2(N-J,A(I,J+1),MDA)
         W(I) = H(I)
  240 CONTINUE
C
  250 H(J) = A(J,J)
      A(J,J) = -TN
C
C          UPDATE UB, DB
C
      UB(J) = UB(J)/DABS(A(J,J))
      DB(J) = (DSIGN(EB(J),DB(J)) + DB(J))/A(J,J)
      IF (J .EQ. KRANK) GO TO 300
      DO 260 I = JP1,KRANK
         UB(I) = UB(I) + DABS(A(I,J))*UB(J)
         DB(I) = DB(I) - A(I,J)*DB(J)
  260 CONTINUE
      GO TO 100
C
C        E N D    M A I N    L O O P
C
  300 CONTINUE
C
C        COMPUTE KSURE
C
      KM1 = KRANK - 1
      DO 315 I = 1,KM1
         IS = 0
         KMI = KRANK - I
         DO 310 II = 1,KMI
            IF (UB(II) .LE. UB(II + 1)) GO TO 310
            IS = 1
            TEMP = UB(II)
            UB(II) = UB(II + 1)
            UB(II + 1) = TEMP
  310    CONTINUE
         IF (IS .EQ. 0) GO TO 320
  315 CONTINUE
C
  320 KSURE = 0
      SUM = 0.D0
      DO 325 I = 1,KRANK
         R2 = UB(I)*UB(I)
         IF (R2 + SUM .GE. 1.D0) GO TO 330
         SUM = SUM + R2
         KSURE = KSURE + 1
  325 CONTINUE
C
C     IF SYSTEM IS OF REDUCED RANK AND MODE = 2
C     COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION
C
  330 IF (KRANK .EQ. M .OR. MODE .LT. 2) RETURN
      MMK = M - KRANK
      KP1 = KRANK + 1
      I = KRANK
  340    TN = DNRM2(MMK,A(KP1,I),1)/A(I,I)
         TN = A(I,I)*DSQRT(1.D0 + TN*TN)
         CALL DSCAL (MMK,1.D0/TN,A(KP1,I),1)
         W(I) = A(I,I)/TN + 1.D0
         A(I,I) = -TN
         IF (I .EQ. 1) GO TO 350
         IM1 = I - 1
         DO 345 II = 1,IM1
            TT = -DDOT(MMK,A(KP1,II),1,A(KP1,I),1)/W(I)
            TT = TT - A(I,II)
            CALL DAXPY (MMK,TT,A(KP1,I),1,A(KP1,II),1)
            A(I,II) = A(I,II) + TT*W(I)
  345    CONTINUE
         I = I - 1
         GO TO 340
C
  350 CONTINUE
      RETURN
C
C     FIRST NP ROWS ARE LINEARLY DEPENDENT
C
  400 KRANK = I - 1
      RETURN
  410 KRANK = J - 1
      RETURN
      END
      SUBROUTINE DU12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,H,W,IR,IC)
C
C        GIVEN THE HOUSEHOLDER LQ FACTORIZATION OF A, THIS
C        SUBROUTINE SOLVES THE SYSTEM AX=B. IF THE SYSTEM
C        IS OF REDUCED RANK, THIS ROUTINE RETURNS A SOLUTION
C        ACCORDING TO THE SELECTED MODE.
C
C       NOTE - IF MODE.NE.2, W IS NEVER ACCESSED.
C
      DOUBLE PRECISION A(MDA,N), B(MDB,NB), RNORM(NB), H(M), W(M)
      INTEGER IC(N), IR(M)
      DOUBLE PRECISION BB, TT
      DOUBLE PRECISION DDOT, DNRM2
C
      K = KRANK
      KP1 = K + 1
      IF (K .GT. 0) GO TO 30
C
C        RANK=0
C
      DO 10 JB = 1,NB
         RNORM(JB) = DNRM2(M,B(1,JB),1)
   10 CONTINUE
      DO 21 JB = 1,NB
         DO 20 I = 1,N
            B(I,JB) = 0.D0
   20    CONTINUE
   21 CONTINUE
      RETURN
C
   30 I = 0
C
C     REORDER B TO REFLECT ROW INTERCHANGES
C
   40    I = I + 1
         IF (I .EQ. M) GO TO 100
         J = IR(I)
         IF (J .EQ. I) GO TO 40
         IF (J .LT. 0) GO TO 40
C
         IR(I) = -IR(I)
         DO 50 JB = 1,NB
            RNORM(JB) = B(I,JB)
   50    CONTINUE
C
         IJ = I
   60       DO 70 JB = 1,NB
               B(IJ,JB) = B(J,JB)
   70       CONTINUE
            IJ = J
            J = IR(IJ)
            IR(IJ) = -IR(IJ)
         IF (J .NE. I) GO TO 60
C
         DO 80 JB = 1,NB
            B(IJ,JB) = RNORM(JB)
   80    CONTINUE
         GO TO 40
C
  100 DO 110 I = 1,M
         IR(I) = IABS(IR(I))
  110 CONTINUE
C
C     IF A IS OF REDUCED RANK AND MODE=2,
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO B
C
      IF (MODE .LT. 2 .OR. K .EQ. M) GO TO 140
      MMK = M - K
      DO 130 JB = 1,NB
         DO 120 J = 1,K
            I = KP1 - J
            TT = -DDOT(MMK,A(KP1,I),1,B(KP1,JB),1)/W(I)
            TT = TT - B(I,JB)
            CALL DAXPY (MMK,TT,A(KP1,I),1,B(KP1,JB),1)
            B(I,JB) = B(I,JB) + TT*W(I)
  120    CONTINUE
  130 CONTINUE
C
C     FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B)
C
  140 DO 150 JB = 1,NB
         RNORM(JB) = DNRM2(M-K,B(KP1,JB),1)
  150 CONTINUE
C
C     BACK SOLVE LOWER TRIANGULAR L
C
      DO 170 JB = 1,NB
         DO 160 I = 1,K
            B(I,JB) = B(I,JB)/A(I,I)
            IF (I .EQ. K) GO TO 170
            IP1 = I + 1
            CALL DAXPY(K-I,-B(I,JB),A(IP1,I),1,B(IP1,JB),1)
  160    CONTINUE
  170 CONTINUE
C
C      TRUNCATED SOLUTION
C
      IF (K .EQ. N) GO TO 210
      DO 201 JB = 1,NB
         DO 200 I = KP1,N
            B(I,JB) = 0.D0
  200    CONTINUE
  201 CONTINUE
C
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO B
C
  210 DO 230 I = 1,K
         J = KP1 - I
         TT = A(J,J)
         A(J,J) = H(J)
         DO 220 JB = 1,NB
            BB = -DDOT(N-J+1,A(J,J),MDA,B(J,JB),1)/H(J)
            CALL DAXPY(N-J+1,BB,A(J,J),MDA,B(J,JB),1)
  220    CONTINUE
         A(J,J) = TT
  230 CONTINUE
C
C     REORDER B TO REFLECT COLUMN INTERCHANGES
C
      I = 0
C
  240    I = I + 1
         IF (I .EQ. N) GO TO 260
         J = IC(I)
         IF (J .EQ. I) GO TO 240
         IF (J .LT. 0) GO TO 240
C
         IC(I) = -IC(I)
  250       CALL DSWAP (NB,B(J,1),MDB,B(I,1),MDB)
            IJ = IC(J)
            IC(J) = -IC(J)
            J = IJ
         IF (J .NE. I) GO TO 250
         GO TO 240
C
  260 DO 270 I = 1,N
         IC(I) = IABS(IC(I))
  270 CONTINUE
      RETURN
      END
      SUBROUTINE HFTI (A,MDA,M,N,B,MDB,NB,TAU,K,RNORM,H,G,IP)
C-----------------------------------------------------------------------
C     DIMENSION A(MDA,N),(B(MDB,NB) OR B(M)),RNORM(NB),H(N),G(N),IP(N)
C
C     WRITTEN BY C.L. LAWSON AND R.J. HANSON.
C     FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974.
C     FOR ALGORITHMIC DETAILS SEE ALGORITHM HFTI IN CHAPTER 14.
C
C     ABSTRACT
C
C     THIS SUBROUTINE SOLVES A LINEAR LEAST SQUARES PROBLEM OR A SET OF
C     LINEAR LEAST SQUARES PROBLEMS HAVING THE SAME MATRIX BUT DIFFERENT
C     RIGHT-SIDE VECTORS.  THE PROBLEM DATA CONSISTS OF AN M BY N MATRIX
C     A, AN M BY NB MATRIX B, AND AN ABSOLUTE TOLERANCE PARAMETER TAU
C     WHOSE USAGE IS DESCRIBED BELOW.  THE NB COLUMN VECTORS OF B
C     REPRESENT RIGHT-SIDE VECTORS FOR NB DISTINCT LINEAR LEAST SQUARES
C     PROBLEMS.
C
C     THIS SET OF PROBLEMS CAN ALSO BE WRITTEN AS THE MATRIX LEAST
C     SQUARES PROBLEM
C
C                       AX = B,
C
C     WHERE X IS THE N BY NB SOLUTION MATRIX.
C
C     NOTE THAT IF B IS THE M BY M IDENTITY MATRIX, THEN X WILL BE THE
C     PSEUDO-INVERSE OF A.
C
C     THIS SUBROUTINE FIRST TRANSFORMS THE AUGMENTED MATRIX (A B) TO A
C     MATRIX (R C) USING PREMULTIPLYING HOUSEHOLDER TRANSFORMATIONS WITH
C     COLUMN INTERCHANGES.  ALL SUBDIAGONAL ELEMENTS IN THE MATRIX R ARE
C     ZERO AND ITS DIAGONAL ELEMENTS SATISFY
C
C                       ABS(R(I,I)).GE.ABS(R(I+1,I+1)),
C
C                       I = 1,...,L-1, WHERE
C
C                       L = MIN(M,N).
C
C     THE SUBROUTINE SETS K TO BE THE NUMBER OF DIAGONAL ELEMENTS
C     OF R THAT EXCEED TAU IN MAGNITUDE. THEN THE SOLUTION OF MINIMUM
C     EUCLIDEAN LENGTH IS COMPUTED USING THE FIRST K ROWS OF (R C).
C
C     TO BE SPECIFIC WE SUGGEST THAT THE USER CONSIDER AN EASILY
C     COMPUTABLE MATRIX NORM, SUCH AS, THE MAXIMUM OF ALL COLUMN SUMS OF
C     MAGNITUDES.
C
C     NOW IF THE RELATIVE UNCERTAINTY OF B IS EPS, (NORM OF UNCERTAINTY/
C     NORM OF B), IT IS SUGGESTED THAT TAU BE SET APPROXIMATELY EQUAL TO
C     EPS*(NORM OF A).
C
C     THE ENTIRE SET OF PARAMETERS FOR HFTI ARE
C
C     INPUT..
C
C     A(*,*),MDA,M,N    THE ARRAY A(*,*) INITIALLY CONTAINS THE M BY N
C                       MATRIX A OF THE LEAST SQUARES PROBLEM AX = B.
C                       THE FIRST DIMENSIONING PARAMETER OF THE ARRAY
C                       A(*,*) IS MDA, WHICH MUST SATISFY MDA.GE.M
C                       EITHER M.GE.N OR M.LT.N IS PERMITTED.  THERE
C                       IS NO RESTRICTION ON THE RANK OF A.  THE
C                       CONDITION MDA.LT.M IS CONSIDERED AN ERROR.
C
C     B(*),MDB,NB       IF NB = 0 THE SUBROUTINE WILL PERFORM THE
C                       ORTHOGONAL DECOMPOSITION BUT WILL MAKE NO
C                       REFERENCES TO THE ARRAY B(*).  IF NB.GT.0
C                       THE ARRAY B(*) MUST INITIALLY CONTAIN THE M BY
C                       NB MATRIX B OF THE LEAST SQUARES PROBLEM AX =
C                       B.  IF NB.GE.2 THE ARRAY B(*) MUST BE DOUBLY
C                       SUBSCRIPTED WITH FIRST DIMENSIONING PARAMETER
C                       MDB.GE.MAX(M,N).  IF NB = 1 THE ARRAY B(*) MAY
C                       BE EITHER DOUBLY OR SINGLY SUBSCRIPTED.  IN
C                       THE LATTER CASE THE VALUE OF MDB IS ARBITRARY
C                       BUT IT SHOULD BE SET TO SOME VALID INTEGER
C                       VALUE SUCH AS MDB = M.
C
C                       THE CONDITION OF NB.GT.1.AND.MDB.LT. MAX(M,N)
C                       IS CONSIDERED AN ERROR.
C
C     TAU               ABSOLUTE TOLERANCE PARAMETER PROVIDED BY USER
C                       FOR PSEUDORANK DETERMINATION.
C
C     H(*),G(*),IP(*)   ARRAYS OF WORKING SPACE USED BY HFTI.
C
C     OUTPUT..
C
C     A(*,*)            THE CONTENTS OF THE ARRAY A(*,*) WILL BE
C                       MODIFIED BY THE SUBROUTINE.  THESE CONTENTS
C                       ARE NOT GENERALLY REQUIRED BY THE USER.
C
C     B(*)              ON RETURN THE ARRAY B(*) WILL CONTAIN THE N BY
C                       NB SOLUTION MATRIX X.
C
C     K                 SET BY THE SUBROUTINE TO INDICATE THE
C                       PSEUDORANK OF A.
C
C     RNORM(*)          ON RETURN, RNORM(J) WILL CONTAIN THE EUCLIDEAN
C                       NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM
C                       DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY
C                       B(*,*) FOR J = 1,...,NB.
C
C     H(*),G(*)         ON RETURN THESE ARRAYS RESPECTIVELY CONTAIN
C                       ELEMENTS OF THE PRE- AND POST-MULTIPLYING
C                       HOUSEHOLDER TRANSFORMATIONS USED TO COMPUTE
C                       THE MINIMUM EUCLIDEAN LENGTH SOLUTION.
C
C     IP(*)             ARRAY IN WHICH THE SUBROUTINE RECORDS INDICES
C                       DESCRIBING THE PERMUTATION OF COLUMN VECTORS.
C                       THE CONTENTS OF ARRAYS H(*),G(*) AND IP(*)
C                       ARE NOT GENERALLY REQUIRED BY THE USER.
C-----------------------------------------------------------------------
      DIMENSION A(MDA,N),B(MDB,*),RNORM(*),H(N),G(N)
      INTEGER IP(N)
      DOUBLE PRECISION SM
C---------------------
      DATA FACTOR /1.E-3/
C
      K = 0
      LDIAG = MIN0(M,N)
      IF (LDIAG .LE. 0) GO TO 270
          DO 80 J = 1,LDIAG
          IF (J .EQ. 1) GO TO 20
C
C     UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
          LMAX = J
              DO 10 L = J,N
              H(L) = H(L) - A(J-1,L)**2
              IF (H(L) .GT. H(LMAX)) LMAX = L
   10         CONTINUE
          Z = HMAX + FACTOR*H(LMAX)
          IF (Z .GT. HMAX) GO TO 50
C
C     COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
   20     LMAX=J
              DO 40 L = J,N
              H(L) = 0.0
                  DO 30 I = J,M
   30             H(L) = H(L) + A(I,L)**2
              IF (H(L) .GT. H(LMAX)) LMAX = L
   40         CONTINUE
          HMAX = H(LMAX)
C    ..
C     LMAX HAS BEEN DETERMINED
C
C     DO COLUMN INTERCHANGES IF NEEDED.
C    ..
   50     IP(J) = LMAX
          IF (IP(J) .EQ. J) GO TO 70
              DO 60 I = 1,M
              TMP = A(I,J)
              A(I,J) = A(I,LMAX)
   60         A(I,LMAX) = TMP
          H(LMAX) = H(J)
C
C     COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B.
C    ..
   70     CALL H12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J)
   80     CALL H12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)
C
C     DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU.
C    ..
          DO 90 J = 1,LDIAG
          IF (ABS(A(J,J)) .LE. TAU) GO TO 100
   90     CONTINUE
      K = LDIAG
      GO TO 110
  100 K = J - 1
  110 KP1 = K + 1
C
C     COMPUTE THE NORMS OF THE RESIDUAL VECTORS.
C
      IF (NB .LE. 0) GO TO 140
          DO 130 JB = 1,NB
          TMP = 0.0
          IF (KP1 .GT. M) GO TO 130
              DO 120 I = KP1,M
  120         TMP = TMP + B(I,JB)**2
  130     RNORM(JB) = SQRT(TMP)
  140 CONTINUE
C                                           SPECIAL FOR PSEUDORANK = 0
      IF (K .GT. 0) GO TO 160
      IF (NB .LE. 0) GO TO 270
          DO 151 JB = 1,NB
              DO 150 I = 1,N
  150         B(I,JB) = 0.0
  151     CONTINUE
      GO TO 270
C
C     IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER
C     DECOMPOSITION OF FIRST K ROWS.
C    ..
  160 IF (K .EQ. N) GO TO 180
          DO 170 II = 1,K
          I = KP1 - II
  170     CALL H12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  180 CONTINUE
C
C
      IF (NB .LE. 0) GO TO 270
          DO 260 JB = 1,NB
C
C     SOLVE THE K BY K TRIANGULAR SYSTEM.
C    ..
              DO 210 L = 1,K
              SM = 0.D0
              I = KP1 - L
              IF (I .EQ. K) GO TO 200
              IP1 = I + 1
                  DO 190 J = IP1,K
  190             SM = SM + DBLE(A(I,J))*DBLE(B(J,JB))
  200         SM1 = DBLE(B(I,JB)) - SM
  210         B(I,JB) = SM1/A(I,I)
C
C     COMPLETE COMPUTATION OF SOLUTION VECTOR.
C    ..
          IF (K .EQ. N) GO TO 240
              DO 220 J = KP1,N
  220         B(J,JB) = 0.0
              DO 230 I = 1,K
  230         CALL H12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1)
C
C      RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE
C      COLUMN INTERCHANGES.
C    ..
  240         DO 250 JJ = 1,LDIAG
              J = LDIAG + 1 - JJ
              IF (IP(J) .EQ. J) GO TO 250
              L = IP(J)
              TMP = B(L,JB)
              B(L,JB) = B(J,JB)
              B(J,JB) = TMP
  250         CONTINUE
  260     CONTINUE
C    ..
C     THE SOLUTION VECTORS, X, ARE NOW
C     IN THE FIRST  N  ROWS OF THE ARRAY B(,).
C
  270 RETURN
      END
      SUBROUTINE HFTI2(A,MDA,M,N,B,MDB,NB,D,TAU,K,RNORM,H,G,IP,IERR)
C-----------------------------------------------------------------------
C     DIMENSION A(MDA,N),(B(MDB,NB) OR B(M))
C     DIMENSION D(L) WHERE L = MIN(M,N)
C     DIMENSION RNORM(NB),H(N),G(N),IP(N)
C
C     WRITTEN BY C.L. LAWSON AND R.J. HANSON. MODIFIED BY A.H. MORRIS.
C     FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974.
C     FOR ALGORITHMIC DETAILS SEE ALGORITHM HFTI IN CHAPTER 14.
C
C     ABSTRACT
C
C     THIS SUBROUTINE SOLVES A LINEAR LEAST SQUARES PROBLEM OR A SET OF
C     LINEAR LEAST SQUARES PROBLEMS HAVING THE SAME MATRIX BUT DIFFERENT
C     RIGHT-SIDE VECTORS.  THE PROBLEM DATA CONSISTS OF AN M BY N MATRIX
C     A, AN M BY NB MATRIX B, AND AN ABSOLUTE TOLERANCE PARAMETER TAU
C     WHOSE USAGE IS DESCRIBED BELOW.  THE NB COLUMN VECTORS OF B
C     REPRESENT RIGHT-SIDE VECTORS FOR NB DISTINCT LINEAR LEAST SQUARES
C     PROBLEMS.
C
C     THIS SET OF PROBLEMS CAN ALSO BE WRITTEN AS THE MATRIX LEAST
C     SQUARES PROBLEM
C
C                       AX = B,
C
C     WHERE X IS THE N BY NB SOLUTION MATRIX.
C
C     NOTE THAT IF B IS THE M BY M IDENTITY MATRIX, THEN X WILL BE THE
C     PSEUDO-INVERSE OF A.
C
C     THIS SUBROUTINE FIRST TRANSFORMS THE AUGMENTED MATRIX (A B) TO A
C     MATRIX (R C) USING PREMULTIPLYING HOUSEHOLDER TRANSFORMATIONS WITH
C     COLUMN INTERCHANGES.  ALL SUBDIAGONAL ELEMENTS IN THE MATRIX R ARE
C     ZERO AND ITS DIAGONAL ELEMENTS SATISFY
C
C                       ABS(R(I,I)).GE.ABS(R(I+1,I+1)),
C
C                       I = 1,...,L-1, WHERE
C
C                       L = MIN(M,N).
C
C     THE ARRAY D WILL CONTAIN THE DIAGONAL ELEMENTS R(1,1),...,R(L,L).
C     THE SUBROUTINE SETS K TO BE THE NUMBER OF DIAGONAL ELEMENTS THAT
C     EXCEED TAU IN MAGNITUDE.  THEN THE SOLUTION OF MINIMUM EUCLIDEAN
C     LENGTH IS COMPUTED USING THE FIRST K ROWS OF (R C).
C
C     TO BE SPECIFIC WE SUGGEST THAT THE USER CONSIDER AN EASILY
C     COMPUTABLE MATRIX NORM, SUCH AS, THE MAXIMUM OF ALL COLUMN SUMS OF
C     MAGNITUDES.
C
C     NOW IF THE RELATIVE UNCERTAINTY OF B IS EPS, (NORM OF UNCERTAINTY/
C     NORM OF B), IT IS SUGGESTED THAT TAU BE SET APPROXIMATELY EQUAL TO
C     EPS*(NORM OF A).
C
C     THE ENTIRE SET OF PARAMETERS FOR HFTI2 ARE
C
C     INPUT..
C
C     A(*,*),MDA,M,N    THE ARRAY A(*,*) INITIALLY CONTAINS THE M BY N
C                       MATRIX A OF THE LEAST SQUARES PROBLEM AX = B.
C                       THE FIRST DIMENSIONING PARAMETER OF THE ARRAY
C                       A(*,*) IS MDA, WHICH MUST SATISFY MDA.GE.M
C                       EITHER M.GE.N OR M.LT.N IS PERMITTED.  THERE
C                       IS NO RESTRICTION ON THE RANK OF A.  THE
C                       CONDITION MDA.LT.M IS CONSIDERED AN ERROR.
C
C     B(*),MDB,NB       IF NB = 0 THE SUBROUTINE WILL PERFORM THE
C                       ORTHOGONAL DECOMPOSITION BUT WILL MAKE NO
C                       REFERENCES TO THE ARRAY B(*).  IF NB.GT.0
C                       THE ARRAY B(*) MUST INITIALLY CONTAIN THE M BY
C                       NB MATRIX B OF THE LEAST SQUARES PROBLEM AX =
C                       B.  IF NB.GE.2 THE ARRAY B(*) MUST BE DOUBLY
C                       SUBSCRIPTED WITH FIRST DIMENSIONING PARAMETER
C                       MDB.GE.MAX(M,N).  IF NB = 1 THE ARRAY B(*) MAY
C                       BE EITHER DOUBLY OR SINGLY SUBSCRIPTED.  IN
C                       THE LATTER CASE THE VALUE OF MDB IS ARBITRARY
C                       BUT IT SHOULD BE SET TO SOME VALID INTEGER
C                       VALUE SUCH AS MDB = M.
C
C                       THE CONDITION OF NB.GT.1.AND.MDB.LT. MAX(M,N)
C                       IS CONSIDERED AN ERROR.
C
C     TAU               ABSOLUTE TOLERANCE PARAMETER PROVIDED BY USER
C                       FOR PSEUDORANK DETERMINATION.
C
C     H(*),G(*),IP(*)   ARRAYS OF WORKING SPACE USED BY HFTI2.
C
C     OUTPUT..
C
C     A(*,*)            THE CONTENTS OF THE ARRAY A(*,*) WILL BE
C                       MODIFIED BY THE SUBROUTINE.  THESE CONTENTS
C                       ARE NOT GENERALLY REQUIRED BY THE USER.
C
C     B(*)              ON RETURN THE ARRAY B(*) WILL CONTAIN THE N BY
C                       NB SOLUTION MATRIX X.
C
C     D(*)              THE ARRAY OF DIAGONAL ELEMENTS OF THE
C                       TRIANGULAR MATRIX R
C
C     K                 SET BY THE SUBROUTINE TO INDICATE THE
C                       PSEUDORANK OF A.
C
C     RNORM(*)          ON RETURN, RNORM(J) WILL CONTAIN THE EUCLIDEAN
C                       NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM
C                       DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY
C                       B(*,*) FOR J = 1,...,NB.
C
C     H(*),G(*)         ON RETURN THESE ARRAYS RESPECTIVELY CONTAIN
C                       ELEMENTS OF THE PRE- AND POST-MULTIPLYING
C                       HOUSEHOLDER TRANSFORMATIONS USED TO COMPUTE
C                       THE MINIMUM EUCLIDEAN LENGTH SOLUTION.
C
C     IP(*)             ARRAY IN WHICH THE SUBROUTINE RECORDS INDICES
C                       DESCRIBING THE PERMUTATION OF COLUMN VECTORS.
C                       THE CONTENTS OF ARRAYS H(*),G(*) AND IP(*)
C                       ARE NOT GENERALLY REQUIRED BY THE USER.
C
C     IERR              ERROR INDICATOR. IF NO INPUT ERRORS ARE
C                       DETECTED THEN IERR IS SET TO 0. OTHERWISE
C                          IERR = 1  IF MDA.LT.M
C                          IERR = 2  IF NB.GT.1 AND MDB.LT.MAX(M,N)
C                       THESE ERRORS ARE FATAL.
C-----------------------------------------------------------------------
      DIMENSION A(MDA,N),B(MDB,*),D(*),RNORM(*),H(N),G(N)
      INTEGER IP(N)
      DOUBLE PRECISION SM
C---------------------
      DATA FACTOR /1.E-3/
C
      K = 0
      LDIAG = MIN0(M,N)
      IF (LDIAG .LE. 0) GO TO 270
      IF (M .GT. MDA) GO TO 300
      IF (NB .GT. 1 .AND. MAX0(M,N) .GT. MDB) GO TO 310
C
          DO 80 J = 1,LDIAG
          IF (J .EQ. 1) GO TO 20
C
C     UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
          LMAX = J
              DO 10 L = J,N
              H(L) = H(L) - A(J-1,L)**2
              IF (H(L) .GT. H(LMAX)) LMAX = L
   10         CONTINUE
          Z = HMAX + FACTOR*H(LMAX)
          IF (Z .GT. HMAX) GO TO 50
C
C     COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
   20     LMAX = J
              DO 40 L = J,N
              H(L) = 0.0
                  DO 30 I = J,M
   30             H(L) = H(L) + A(I,L)**2
              IF (H(L) .GT. H(LMAX)) LMAX = L
   40         CONTINUE
          HMAX = H(LMAX)
C    ..
C     LMAX HAS BEEN DETERMINED
C
C     DO COLUMN INTERCHANGES IF NEEDED.
C    ..
   50     IP(J) = LMAX
          IF (IP(J) .EQ. J) GO TO 70
              DO 60 I = 1,M
              TMP = A(I,J)
              A(I,J) = A(I,LMAX)
   60         A(I,LMAX) = TMP
          H(LMAX) = H(J)
C
C     COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B.
C    ..
   70     CALL H12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J)
   80     CALL H12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)
C
C     DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU.
C     ALSO STORE THE DIAGONAL ELEMENTS IN THE ARRAY D.
C    ..
          DO 90 J = 1,LDIAG
          IF (ABS(A(J,J)) .LE. TAU) GO TO 100
   90     D(J) = A(J,J)
          K = LDIAG
          KP1 = K + 1
          GO TO 110
C
  100     K = J - 1
          KP1 = J
          DO 105 J = KP1,LDIAG
  105     D(J) = A(J,J)
C
C     COMPUTE THE NORMS OF THE RESIDUAL VECTORS.
C
  110 IF (NB .LE. 0) GO TO 140
          DO 130 JB = 1,NB
          TMP = 0.0
          IF (KP1 .GT. M) GO TO 130
              DO 120 I = KP1,M
  120         TMP = TMP + B(I,JB)**2
  130     RNORM(JB) = SQRT(TMP)
  140 CONTINUE
C                                           SPECIAL FOR PSEUDORANK = 0
      IF (K .GT. 0) GO TO 160
      IF (NB .LE. 0) GO TO 270
          DO 151 JB = 1,NB
              DO 150 I = 1,N
  150         B(I,JB) = 0.0
  151     CONTINUE
      GO TO 270
C
C     IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER
C     DECOMPOSITION OF FIRST K ROWS.
C    ..
  160 IF (K .EQ. N) GO TO 180
          DO 170 II = 1,K
          I = KP1 - II
  170     CALL H12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  180 CONTINUE
C
C
      IF (NB .LE. 0) GO TO 270
          DO 260 JB = 1,NB
C
C     SOLVE THE K BY K TRIANGULAR SYSTEM.
C    ..
              DO 210 L = 1,K
              SM = 0.D0
              I = KP1 - L
              IF (I .EQ. K) GO TO 200
              IP1 = I + 1
                  DO 190 J = IP1,K
  190             SM = SM + DBLE(A(I,J))*DBLE(B(J,JB))
  200         SM1 = DBLE(B(I,JB)) - SM
  210         B(I,JB)=SM1/A(I,I)
C
C     COMPLETE COMPUTATION OF SOLUTION VECTOR.
C    ..
          IF (K .EQ. N) GO TO 240
              DO 220 J = KP1,N
  220         B(J,JB) = 0.0
              DO 230 I = 1,K
  230         CALL H12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1)
C
C      RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE
C      COLUMN INTERCHANGES.
C    ..
  240         DO 250 JJ = 1,LDIAG
              J = LDIAG + 1 - JJ
              IF (IP(J) .EQ. J) GO TO 250
              L = IP(J)
              TMP = B(L,JB)
              B(L,JB) = B(J,JB)
              B(J,JB) = TMP
  250         CONTINUE
  260     CONTINUE
C    ..
C     THE SOLUTION VECTORS, X, ARE NOW
C     IN THE FIRST  N  ROWS OF THE ARRAY B(,).
C
  270 IERR = 0
      RETURN
C
C     ERROR RETURN
C
  300 IERR = 1
      RETURN
  310 IERR = 2
      RETURN
      END
      SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV)
C-----------------------------------------------------------------------
C     WRITTEN BY C.L. LAWSON AND R.J. HANSON.  MODIFIED BY A.H. MORRIS.
C     FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974.
C
C     CONSTRUCTION AND/OR APPLICATION OF A SINGLE
C     HOUSEHOLDER TRANSFORMATION..     Q = I + U*(U**T)/B
C
C     MODE    = 1 OR 2   TO SELECT ALGORITHM  H1  OR  H2 .
C     LPIVOT IS THE INDEX OF THE PIVOT ELEMENT.
C     L1,M   IF L1 .LE. M   THE TRANSFORMATION WILL BE CONSTRUCTED TO
C            ZERO ELEMENTS INDEXED FROM L1 THROUGH M.   IF L1 GT. M
C            THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION.
C     U(),IUE,UP    ON ENTRY TO H1 U() CONTAINS THE PIVOT VECTOR.
C                   IUE IS THE STORAGE INCREMENT BETWEEN ELEMENTS.
C                                       ON EXIT FROM H1 U() AND UP
C                   CONTAIN QUANTITIES DEFINING THE VECTOR U OF THE
C                   HOUSEHOLDER TRANSFORMATION.   ON ENTRY TO H2 U()
C                   AND UP SHOULD CONTAIN QUANTITIES PREVIOUSLY COMPUTED
C                   BY H1.  THESE WILL NOT BE MODIFIED BY H2.
C     C()    ON ENTRY TO H1 OR H2 C() CONTAINS A MATRIX WHICH WILL BE
C            REGARDED AS A SET OF VECTORS TO WHICH THE HOUSEHOLDER
C            TRANSFORMATION IS TO BE APPLIED.  ON EXIT C() CONTAINS THE
C            SET OF TRANSFORMED VECTORS.
C     ICE    STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C().
C     ICV    STORAGE INCREMENT BETWEEN VECTORS IN C().
C     NCV    NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0
C            NO OPERATIONS WILL BE DONE ON C().
C-----------------------------------------------------------------------
      DIMENSION U(IUE,M), C(*)
      DOUBLE PRECISION SM,B
C
      IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) RETURN
      CL = ABS(U(1,LPIVOT))
      IF (MODE .EQ. 2) GO TO 60
C
C                            ****** CONSTRUCT THE TRANSFORMATION. ******
C
          DO 10 J = L1,M
   10     CL = AMAX1(ABS(U(1,J)),CL)
      IF (CL .LE. 0.0) GO TO 130
      D = U(1,LPIVOT)/CL
      SM = D*D
          DO 20 J = L1,M
          D = U(1,J)/CL
   20     SM = SM + DBLE(D*D)
C
      SM1 = SM
      CL = CL*SQRT(SM1)
      IF (U(1,LPIVOT) .GT. 0.0) CL = -CL
      UP = U(1,LPIVOT) - CL
      U(1,LPIVOT) = CL
      GO TO 70
C
C            ****** APPLY THE TRANSFORMATION  I+U*(U**T)/B  TO C. ******
C
   60 IF (CL) 130,130,70
   70 IF (NCV .LE. 0) RETURN
      B = DBLE(UP)*DBLE(U(1,LPIVOT))
C
C                       B  MUST BE NONPOSITIVE HERE.  IF B = 0., RETURN.
C
      IF (B .GE. 0.D0) GO TO 130
      B = 1.D0/B
      I2 = 1 - ICV + ICE*(LPIVOT - 1)
      INCR = ICE*(L1 - LPIVOT)
          DO 120 J = 1,NCV
          I2 = I2 + ICV
          I3 = I2 + INCR
          I4 = I3
          SM = DBLE(C(I2))*DBLE(UP)
              DO 90 I = L1,M
              SM = SM + DBLE(C(I3))*DBLE(U(1,I))
   90         I3 = I3 + ICE
          IF (SM .EQ. 0.D0) GO TO 120
          SM = SM*B
          C(I2) = C(I2) + SM*DBLE(UP)
              DO 110 I = L1,M
              C(I4) = C(I4) + SM*DBLE(U(1,I))
  110         I4 = I4 + ICE
  120     CONTINUE
  130 RETURN
      END
      SUBROUTINE DHFTI (A,MDA,M,N,B,MDB,NB,TAU,K,RNORM,H,G,IP)
C-----------------------------------------------------------------------
C     DOUBLE PRECISION A(MDA,N),(B(MDB,NB) OR B(M))
C     DOUBLE PRECISION TAU,RNORM(NB),H(N),G(N)
C     INTEGER IP(N)
C
C     WRITTEN BY C.L. LAWSON AND R.J. HANSON.
C     FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974.
C     FOR ALGORITHMIC DETAILS SEE ALGORITHM HFTI IN CHAPTER 14.
C
C     ABSTRACT
C
C     THIS SUBROUTINE SOLVES A LINEAR LEAST SQUARES PROBLEM OR A SET OF
C     LINEAR LEAST SQUARES PROBLEMS HAVING THE SAME MATRIX BUT DIFFERENT
C     RIGHT-SIDE VECTORS.  THE PROBLEM DATA CONSISTS OF AN M BY N MATRIX
C     A, AN M BY NB MATRIX B, AND AN ABSOLUTE TOLERANCE PARAMETER TAU
C     WHOSE USAGE IS DESCRIBED BELOW.  THE NB COLUMN VECTORS OF B
C     REPRESENT RIGHT-SIDE VECTORS FOR NB DISTINCT LINEAR LEAST SQUARES
C     PROBLEMS.
C
C     THIS SET OF PROBLEMS CAN ALSO BE WRITTEN AS THE MATRIX LEAST
C     SQUARES PROBLEM
C
C                       AX = B,
C
C     WHERE X IS THE N BY NB SOLUTION MATRIX.
C
C     NOTE THAT IF B IS THE M BY M IDENTITY MATRIX, THEN X WILL BE THE
C     PSEUDO-INVERSE OF A.
C
C     THIS SUBROUTINE FIRST TRANSFORMS THE AUGMENTED MATRIX (A B) TO A
C     MATRIX (R C) USING PREMULTIPLYING HOUSEHOLDER TRANSFORMATIONS WITH
C     COLUMN INTERCHANGES.  ALL SUBDIAGONAL ELEMENTS IN THE MATRIX R ARE
C     ZERO AND ITS DIAGONAL ELEMENTS SATISFY
C
C                       DABS(R(I,I)).GE.DABS(R(I+1,I+1)),
C
C                       I = 1,...,L-1, WHERE
C
C                       L = MIN(M,N).
C
C     THE SUBROUTINE SETS K TO BE THE NUMBER OF DIAGONAL ELEMENTS
C     OF R THAT EXCEED TAU IN MAGNITUDE. THEN THE SOLUTION OF MINIMUM
C     EUCLIDEAN LENGTH IS COMPUTED USING THE FIRST K ROWS OF (R C).
C
C     TO BE SPECIFIC WE SUGGEST THAT THE USER CONSIDER AN EASILY
C     COMPUTABLE MATRIX NORM, SUCH AS, THE MAXIMUM OF ALL COLUMN SUMS OF
C     MAGNITUDES.
C
C     NOW IF THE RELATIVE UNCERTAINTY OF B IS EPS, (NORM OF UNCERTAINTY/
C     NORM OF B), IT IS SUGGESTED THAT TAU BE SET APPROXIMATELY EQUAL TO
C     EPS*(NORM OF A).
C
C     THE ENTIRE SET OF PARAMETERS FOR DHFTI ARE
C
C     INPUT..
C
C     A(*,*),MDA,M,N    THE ARRAY A(*,*) INITIALLY CONTAINS THE M BY N
C                       MATRIX A OF THE LEAST SQUARES PROBLEM AX = B.
C                       THE FIRST DIMENSIONING PARAMETER OF THE ARRAY
C                       A(*,*) IS MDA, WHICH MUST SATISFY MDA.GE.M
C                       EITHER M.GE.N OR M.LT.N IS PERMITTED.  THERE
C                       IS NO RESTRICTION ON THE RANK OF A.  THE
C                       CONDITION MDA.LT.M IS CONSIDERED AN ERROR.
C
C     B(*),MDB,NB       IF NB = 0 THE SUBROUTINE WILL PERFORM THE
C                       ORTHOGONAL DECOMPOSITION BUT WILL MAKE NO
C                       REFERENCES TO THE ARRAY B(*).  IF NB.GT.0
C                       THE ARRAY B(*) MUST INITIALLY CONTAIN THE M BY
C                       NB MATRIX B OF THE LEAST SQUARES PROBLEM AX =
C                       B.  IF NB.GE.2 THE ARRAY B(*) MUST BE DOUBLY
C                       SUBSCRIPTED WITH FIRST DIMENSIONING PARAMETER
C                       MDB.GE.MAX(M,N).  IF NB = 1 THE ARRAY B(*) MAY
C                       BE EITHER DOUBLY OR SINGLY SUBSCRIPTED.  IN
C                       THE LATTER CASE THE VALUE OF MDB IS ARBITRARY
C                       BUT IT SHOULD BE SET TO SOME VALID INTEGER
C                       VALUE SUCH AS MDB = M.
C
C                       THE CONDITION OF NB.GT.1.AND.MDB.LT. MAX(M,N)
C                       IS CONSIDERED AN ERROR.
C
C     TAU               ABSOLUTE TOLERANCE PARAMETER PROVIDED BY USER
C                       FOR PSEUDORANK DETERMINATION.
C
C     H(*),G(*),IP(*)   ARRAYS OF WORKING SPACE USED BY DHFTI.
C
C     OUTPUT..
C
C     A(*,*)            THE CONTENTS OF THE ARRAY A(*,*) WILL BE
C                       MODIFIED BY THE SUBROUTINE.  THESE CONTENTS
C                       ARE NOT GENERALLY REQUIRED BY THE USER.
C
C     B(*)              ON RETURN THE ARRAY B(*) WILL CONTAIN THE N BY
C                       NB SOLUTION MATRIX X.
C
C     K                 SET BY THE SUBROUTINE TO INDICATE THE
C                       PSEUDORANK OF A.
C
C     RNORM(*)          ON RETURN, RNORM(J) WILL CONTAIN THE EUCLIDEAN
C                       NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM
C                       DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY
C                       B(*,*) FOR J = 1,...,NB.
C
C     H(*),G(*)         ON RETURN THESE ARRAYS RESPECTIVELY CONTAIN
C                       ELEMENTS OF THE PRE- AND POST-MULTIPLYING
C                       HOUSEHOLDER TRANSFORMATIONS USED TO COMPUTE
C                       THE MINIMUM EUCLIDEAN LENGTH SOLUTION.
C
C     IP(*)             ARRAY IN WHICH THE SUBROUTINE RECORDS INDICES
C                       DESCRIBING THE PERMUTATION OF COLUMN VECTORS.
C                       THE CONTENTS OF ARRAYS H(*),G(*) AND IP(*)
C                       ARE NOT GENERALLY REQUIRED BY THE USER.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(MDA,N),B(MDB,*),TAU,RNORM(*),H(N),G(N)
      INTEGER IP(N)
      DOUBLE PRECISION FACTOR,HMAX,SM,SM1,TMP,Z
C---------------------
      DATA FACTOR /1.D-3/
C
      K = 0
      LDIAG = MIN0(M,N)
      IF (LDIAG .LE. 0) GO TO 270
          DO 80 J = 1,LDIAG
          IF (J .EQ. 1) GO TO 20
C
C     UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
          LMAX = J
              DO 10 L = J,N
              H(L) = H(L) - A(J-1,L)**2
              IF (H(L) .GT. H(LMAX)) LMAX = L
   10         CONTINUE
          Z = HMAX + FACTOR*H(LMAX)
          IF (Z .GT. HMAX) GO TO 50
C
C     COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
   20     LMAX=J
              DO 40 L = J,N
              H(L) = 0.D0
                  DO 30 I = J,M
   30             H(L) = H(L) + A(I,L)**2
              IF (H(L) .GT. H(LMAX)) LMAX = L
   40         CONTINUE
          HMAX = H(LMAX)
C    ..
C     LMAX HAS BEEN DETERMINED
C
C     DO COLUMN INTERCHANGES IF NEEDED.
C    ..
   50     IP(J) = LMAX
          IF (IP(J) .EQ. J) GO TO 70
              DO 60 I = 1,M
              TMP = A(I,J)
              A(I,J) = A(I,LMAX)
   60         A(I,LMAX) = TMP
          H(LMAX) = H(J)
C
C     COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B.
C    ..
   70     CALL DH12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J)
   80     CALL DH12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)
C
C     DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU.
C    ..
          DO 90 J = 1,LDIAG
          IF (DABS(A(J,J)) .LE. TAU) GO TO 100
   90     CONTINUE
      K = LDIAG
      GO TO 110
  100 K = J - 1
  110 KP1 = K + 1
C
C     COMPUTE THE NORMS OF THE RESIDUAL VECTORS.
C
      IF (NB .LE. 0) GO TO 140
          DO 130 JB = 1,NB
          TMP = 0.D0
          IF (KP1 .GT. M) GO TO 130
              DO 120 I = KP1,M
  120         TMP = TMP + B(I,JB)**2
  130     RNORM(JB) = DSQRT(TMP)
  140 CONTINUE
C                                           SPECIAL FOR PSEUDORANK = 0
      IF (K .GT. 0) GO TO 160
      IF (NB .LE. 0) GO TO 270
          DO 151 JB = 1,NB
              DO 150 I = 1,N
  150         B(I,JB) = 0.D0
  151     CONTINUE
      GO TO 270
C
C     IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER
C     DECOMPOSITION OF FIRST K ROWS.
C    ..
  160 IF (K .EQ. N) GO TO 180
          DO 170 II = 1,K
          I = KP1 - II
  170     CALL DH12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  180 CONTINUE
C
C
      IF (NB .LE. 0) GO TO 270
          DO 260 JB = 1,NB
C
C     SOLVE THE K BY K TRIANGULAR SYSTEM.
C    ..
              DO 210 L = 1,K
              SM = 0.D0
              I = KP1 - L
              IF (I .EQ. K) GO TO 200
              IP1 = I + 1
                  DO 190 J = IP1,K
  190             SM = SM + A(I,J)*B(J,JB)
  200         SM1 = B(I,JB) - SM
  210         B(I,JB) = SM1/A(I,I)
C
C     COMPLETE COMPUTATION OF SOLUTION VECTOR.
C    ..
          IF (K .EQ. N) GO TO 240
              DO 220 J = KP1,N
  220         B(J,JB) = 0.D0
              DO 230 I = 1,K
  230         CALL DH12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1)
C
C      RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE
C      COLUMN INTERCHANGES.
C    ..
  240         DO 250 JJ = 1,LDIAG
              J = LDIAG + 1 - JJ
              IF (IP(J) .EQ. J) GO TO 250
              L = IP(J)
              TMP = B(L,JB)
              B(L,JB) = B(J,JB)
              B(J,JB) = TMP
  250         CONTINUE
  260     CONTINUE
C    ..
C     THE SOLUTION VECTORS, X, ARE NOW
C     IN THE FIRST  N  ROWS OF THE ARRAY B(,).
C
  270 RETURN
      END
      SUBROUTINE DHFTI2(A,MDA,M,N,B,MDB,NB,D,TAU,K,RNORM,H,G,IP,IERR)
C-----------------------------------------------------------------------
C     DOUBLE PRECISION A(MDA,N),(B(MDB,NB) OR B(M))
C     DOUBLE PRECISION D(L) WHERE L = MIN(M,N)
C     DOUBLE PRECISION TAU,RNORM(NB),H(N),G(N)
C     INTEGER IP(N)
C
C     WRITTEN BY C.L. LAWSON AND R.J. HANSON. MODIFIED BY A.H. MORRIS.
C     FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974.
C     FOR ALGORITHMIC DETAILS SEE ALGORITHM HFTI IN CHAPTER 14.
C
C     ABSTRACT
C
C     THIS SUBROUTINE SOLVES A LINEAR LEAST SQUARES PROBLEM OR A SET OF
C     LINEAR LEAST SQUARES PROBLEMS HAVING THE SAME MATRIX BUT DIFFERENT
C     RIGHT-SIDE VECTORS.  THE PROBLEM DATA CONSISTS OF AN M BY N MATRIX
C     A, AN M BY NB MATRIX B, AND AN ABSOLUTE TOLERANCE PARAMETER TAU
C     WHOSE USAGE IS DESCRIBED BELOW.  THE NB COLUMN VECTORS OF B
C     REPRESENT RIGHT-SIDE VECTORS FOR NB DISTINCT LINEAR LEAST SQUARES
C     PROBLEMS.
C
C     THIS SET OF PROBLEMS CAN ALSO BE WRITTEN AS THE MATRIX LEAST
C     SQUARES PROBLEM
C
C                       AX = B,
C
C     WHERE X IS THE N BY NB SOLUTION MATRIX.
C
C     NOTE THAT IF B IS THE M BY M IDENTITY MATRIX, THEN X WILL BE THE
C     PSEUDO-INVERSE OF A.
C
C     THIS SUBROUTINE FIRST TRANSFORMS THE AUGMENTED MATRIX (A B) TO A
C     MATRIX (R C) USING PREMULTIPLYING HOUSEHOLDER TRANSFORMATIONS WITH
C     COLUMN INTERCHANGES.  ALL SUBDIAGONAL ELEMENTS IN THE MATRIX R ARE
C     ZERO AND ITS DIAGONAL ELEMENTS SATISFY
C
C                       DABS(R(I,I)).GE.DABS(R(I+1,I+1)),
C
C                       I = 1,...,L-1, WHERE
C
C                       L = MIN(M,N).
C
C     THE ARRAY D WILL CONTAIN THE DIAGONAL ELEMENTS R(1,1),...,R(L,L).
C     THE SUBROUTINE SETS K TO BE THE NUMBER OF DIAGONAL ELEMENTS THAT
C     EXCEED TAU IN MAGNITUDE.  THEN THE SOLUTION OF MINIMUM EUCLIDEAN
C     LENGTH IS COMPUTED USING THE FIRST K ROWS OF (R C).
C
C     TO BE SPECIFIC WE SUGGEST THAT THE USER CONSIDER AN EASILY
C     COMPUTABLE MATRIX NORM, SUCH AS, THE MAXIMUM OF ALL COLUMN SUMS OF
C     MAGNITUDES.
C
C     NOW IF THE RELATIVE UNCERTAINTY OF B IS EPS, (NORM OF UNCERTAINTY/
C     NORM OF B), IT IS SUGGESTED THAT TAU BE SET APPROXIMATELY EQUAL TO
C     EPS*(NORM OF A).
C
C     THE ENTIRE SET OF PARAMETERS FOR DHFTI2 ARE
C
C     INPUT..
C
C     A(*,*),MDA,M,N    THE ARRAY A(*,*) INITIALLY CONTAINS THE M BY N
C                       MATRIX A OF THE LEAST SQUARES PROBLEM AX = B.
C                       THE FIRST DIMENSIONING PARAMETER OF THE ARRAY
C                       A(*,*) IS MDA, WHICH MUST SATISFY MDA.GE.M
C                       EITHER M.GE.N OR M.LT.N IS PERMITTED.  THERE
C                       IS NO RESTRICTION ON THE RANK OF A.  THE
C                       CONDITION MDA.LT.M IS CONSIDERED AN ERROR.
C
C     B(*),MDB,NB       IF NB = 0 THE SUBROUTINE WILL PERFORM THE
C                       ORTHOGONAL DECOMPOSITION BUT WILL MAKE NO
C                       REFERENCES TO THE ARRAY B(*).  IF NB.GT.0
C                       THE ARRAY B(*) MUST INITIALLY CONTAIN THE M BY
C                       NB MATRIX B OF THE LEAST SQUARES PROBLEM AX =
C                       B.  IF NB.GE.2 THE ARRAY B(*) MUST BE DOUBLY
C                       SUBSCRIPTED WITH FIRST DIMENSIONING PARAMETER
C                       MDB.GE.MAX(M,N).  IF NB = 1 THE ARRAY B(*) MAY
C                       BE EITHER DOUBLY OR SINGLY SUBSCRIPTED.  IN
C                       THE LATTER CASE THE VALUE OF MDB IS ARBITRARY
C                       BUT IT SHOULD BE SET TO SOME VALID INTEGER
C                       VALUE SUCH AS MDB = M.
C
C                       THE CONDITION OF NB.GT.1.AND.MDB.LT. MAX(M,N)
C                       IS CONSIDERED AN ERROR.
C
C     TAU               ABSOLUTE TOLERANCE PARAMETER PROVIDED BY USER
C                       FOR PSEUDORANK DETERMINATION.
C
C     H(*),G(*),IP(*)   ARRAYS OF WORKING SPACE USED BY DHFTI2.
C
C     OUTPUT..
C
C     A(*,*)            THE CONTENTS OF THE ARRAY A(*,*) WILL BE
C                       MODIFIED BY THE SUBROUTINE.  THESE CONTENTS
C                       ARE NOT GENERALLY REQUIRED BY THE USER.
C
C     B(*)              ON RETURN THE ARRAY B(*) WILL CONTAIN THE N BY
C                       NB SOLUTION MATRIX X.
C
C     D(*)              THE ARRAY OF DIAGONAL ELEMENTS OF THE
C                       TRIANGULAR MATRIX R
C
C     K                 SET BY THE SUBROUTINE TO INDICATE THE
C                       PSEUDORANK OF A.
C
C     RNORM(*)          ON RETURN, RNORM(J) WILL CONTAIN THE EUCLIDEAN
C                       NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM
C                       DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY
C                       B(*,*) FOR J = 1,...,NB.
C
C     H(*),G(*)         ON RETURN THESE ARRAYS RESPECTIVELY CONTAIN
C                       ELEMENTS OF THE PRE- AND POST-MULTIPLYING
C                       HOUSEHOLDER TRANSFORMATIONS USED TO COMPUTE
C                       THE MINIMUM EUCLIDEAN LENGTH SOLUTION.
C
C     IP(*)             ARRAY IN WHICH THE SUBROUTINE RECORDS INDICES
C                       DESCRIBING THE PERMUTATION OF COLUMN VECTORS.
C                       THE CONTENTS OF ARRAYS H(*),G(*) AND IP(*)
C                       ARE NOT GENERALLY REQUIRED BY THE USER.
C
C     IERR              ERROR INDICATOR. IF NO INPUT ERRORS ARE
C                       DETECTED THEN IERR IS SET TO 0. OTHERWISE
C                          IERR = 1  IF MDA.LT.M
C                          IERR = 2  IF NB.GT.1 AND MDB.LT.MAX(M,N)
C                       THESE ERRORS ARE FATAL.
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(MDA,N),B(MDB,*),D(*),TAU,RNORM(*),H(N),G(N)
      INTEGER IP(N)
      DOUBLE PRECISION FACTOR,HMAX,SM,SM1,TMP,Z
C---------------------
      DATA FACTOR /1.D-3/
C
      K = 0
      LDIAG = MIN0(M,N)
      IF (LDIAG .LE. 0) GO TO 270
      IF (M .GT. MDA) GO TO 300
      IF (NB .GT. 1 .AND. MAX0(M,N) .GT. MDB) GO TO 310
C
          DO 80 J = 1,LDIAG
          IF (J .EQ. 1) GO TO 20
C
C     UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
          LMAX = J
              DO 10 L = J,N
              H(L) = H(L) - A(J-1,L)**2
              IF (H(L) .GT. H(LMAX)) LMAX = L
   10         CONTINUE
          Z = HMAX + FACTOR*H(LMAX)
          IF (Z .GT. HMAX) GO TO 50
C
C     COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
   20     LMAX = J
              DO 40 L = J,N
              H(L) = 0.D0
                  DO 30 I = J,M
   30             H(L) = H(L) + A(I,L)**2
              IF (H(L) .GT. H(LMAX)) LMAX = L
   40         CONTINUE
          HMAX = H(LMAX)
C    ..
C     LMAX HAS BEEN DETERMINED
C
C     DO COLUMN INTERCHANGES IF NEEDED.
C    ..
   50     IP(J) = LMAX
          IF (IP(J) .EQ. J) GO TO 70
              DO 60 I = 1,M
              TMP = A(I,J)
              A(I,J) = A(I,LMAX)
   60         A(I,LMAX) = TMP
          H(LMAX) = H(J)
C
C     COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B.
C    ..
   70     CALL DH12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J)
   80     CALL DH12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)
C
C     DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU.
C     ALSO STORE THE DIAGONAL ELEMENTS IN THE ARRAY D.
C    ..
          DO 90 J = 1,LDIAG
          IF (DABS(A(J,J)) .LE. TAU) GO TO 100
   90     D(J) = A(J,J)
          K = LDIAG
          KP1 = K + 1
          GO TO 110
C
  100     K = J - 1
          KP1 = J
          DO 105 J = KP1,LDIAG
  105     D(J) = A(J,J)
C
C     COMPUTE THE NORMS OF THE RESIDUAL VECTORS.
C
  110 IF (NB .LE. 0) GO TO 140
          DO 130 JB = 1,NB
          TMP = 0.D0
          IF (KP1 .GT. M) GO TO 130
              DO 120 I = KP1,M
  120         TMP = TMP + B(I,JB)**2
  130     RNORM(JB) = DSQRT(TMP)
  140 CONTINUE
C                                           SPECIAL FOR PSEUDORANK = 0
      IF (K .GT. 0) GO TO 160
      IF (NB .LE. 0) GO TO 270
          DO 151 JB = 1,NB
              DO 150 I = 1,N
  150         B(I,JB) = 0.D0
  151     CONTINUE
      GO TO 270
C
C     IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER
C     DECOMPOSITION OF FIRST K ROWS.
C    ..
  160 IF (K .EQ. N) GO TO 180
          DO 170 II = 1,K
          I = KP1 - II
  170     CALL DH12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  180 CONTINUE
C
C
      IF (NB .LE. 0) GO TO 270
          DO 260 JB = 1,NB
C
C     SOLVE THE K BY K TRIANGULAR SYSTEM.
C    ..
              DO 210 L = 1,K
              SM = 0.D0
              I = KP1 - L
              IF (I .EQ. K) GO TO 200
              IP1 = I + 1
                  DO 190 J = IP1,K
  190             SM = SM + A(I,J)*B(J,JB)
  200         SM1 = B(I,JB) - SM
  210         B(I,JB)=SM1/A(I,I)
C
C     COMPLETE COMPUTATION OF SOLUTION VECTOR.
C    ..
          IF (K .EQ. N) GO TO 240
              DO 220 J = KP1,N
  220         B(J,JB) = 0.D0
              DO 230 I = 1,K
  230         CALL DH12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1)
C
C      RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE
C      COLUMN INTERCHANGES.
C    ..
  240         DO 250 JJ = 1,LDIAG
              J = LDIAG + 1 - JJ
              IF (IP(J) .EQ. J) GO TO 250
              L = IP(J)
              TMP = B(L,JB)
              B(L,JB) = B(J,JB)
              B(J,JB) = TMP
  250         CONTINUE
  260     CONTINUE
C    ..
C     THE SOLUTION VECTORS, X, ARE NOW
C     IN THE FIRST  N  ROWS OF THE ARRAY B(,).
C
  270 IERR = 0
      RETURN
C
C     ERROR RETURN
C
  300 IERR = 1
      RETURN
  310 IERR = 2
      RETURN
      END
      SUBROUTINE DH12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV)
C-----------------------------------------------------------------------
C     WRITTEN BY C.L. LAWSON AND R.J. HANSON.  MODIFIED BY A.H. MORRIS.
C     FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974.
C
C     CONSTRUCTION AND/OR APPLICATION OF A SINGLE
C     HOUSEHOLDER TRANSFORMATION..     Q = I + U*(U**T)/B
C
C     MODE    = 1 OR 2   TO SELECT ALGORITHM  H1  OR  H2 .
C     LPIVOT IS THE INDEX OF THE PIVOT ELEMENT.
C     L1,M   IF L1 .LE. M   THE TRANSFORMATION WILL BE CONSTRUCTED TO
C            ZERO ELEMENTS INDEXED FROM L1 THROUGH M.   IF L1 GT. M
C            THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION.
C     U(),IUE,UP    ON ENTRY TO H1 U() CONTAINS THE PIVOT VECTOR.
C                   IUE IS THE STORAGE INCREMENT BETWEEN ELEMENTS.
C                                       ON EXIT FROM H1 U() AND UP
C                   CONTAIN QUANTITIES DEFINING THE VECTOR U OF THE
C                   HOUSEHOLDER TRANSFORMATION.   ON ENTRY TO H2 U()
C                   AND UP SHOULD CONTAIN QUANTITIES PREVIOUSLY COMPUTED
C                   BY H1.  THESE WILL NOT BE MODIFIED BY H2.
C     C()    ON ENTRY TO H1 OR H2 C() CONTAINS A MATRIX WHICH WILL BE
C            REGARDED AS A SET OF VECTORS TO WHICH THE HOUSEHOLDER
C            TRANSFORMATION IS TO BE APPLIED.  ON EXIT C() CONTAINS THE
C            SET OF TRANSFORMED VECTORS.
C     ICE    STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C().
C     ICV    STORAGE INCREMENT BETWEEN VECTORS IN C().
C     NCV    NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0
C            NO OPERATIONS WILL BE DONE ON C().
C-----------------------------------------------------------------------
      DOUBLE PRECISION U(IUE,M),UP,C(*)
      DOUBLE PRECISION B,CL,D,SM
C
      IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) RETURN
      CL = DABS(U(1,LPIVOT))
      IF (MODE .EQ. 2) GO TO 60
C
C                            ****** CONSTRUCT THE TRANSFORMATION. ******
C
          DO 10 J = L1,M
   10     CL = DMAX1(DABS(U(1,J)),CL)
      IF (CL .LE. 0.D0) GO TO 130
      D = U(1,LPIVOT)/CL
      SM = D*D
          DO 20 J = L1,M
          D = U(1,J)/CL
   20     SM = SM + D*D
C
      CL = CL*DSQRT(SM)
      IF (U(1,LPIVOT) .GT. 0.D0) CL = -CL
      UP = U(1,LPIVOT) - CL
      U(1,LPIVOT) = CL
      GO TO 70
C
C            ****** APPLY THE TRANSFORMATION  I+U*(U**T)/B  TO C. ******
C
   60 IF (CL) 130,130,70
   70 IF (NCV .LE. 0) RETURN
      B = UP*U(1,LPIVOT)
C
C                       B  MUST BE NONPOSITIVE HERE.  IF B = 0., RETURN.
C
      IF (B .GE. 0.D0) GO TO 130
      B = 1.D0/B
      I2 = 1 - ICV + ICE*(LPIVOT - 1)
      INCR = ICE*(L1 - LPIVOT)
          DO 120 J = 1,NCV
          I2 = I2 + ICV
          I3 = I2 + INCR
          I4 = I3
          SM = C(I2)*UP
              DO 90 I = L1,M
              SM = SM + C(I3)*U(1,I)
   90         I3 = I3 + ICE
          IF (SM .EQ. 0.D0) GO TO 120
          SM = SM*B
          C(I2) = C(I2) + SM*UP
              DO 110 I = L1,M
              C(I4) = C(I4) + SM*U(1,I)
  110         I4 = I4 + ICE
  120     CONTINUE
  130 RETURN
      END
      SUBROUTINE LSEI(W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML,
     * MODE, WS, IP)
C
C     DIMENSION W(MDW,N+1),PRGOPT(*),X(N),
C     WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2)
C     ABOVE, K=MAX(MA+MG,N).
C
C     WRITTEN BY R. J. HANSON AND K. H. HASKELL.  FOR FURTHER MATH.
C     AND ALGORITHMIC DETAILS SEE SANDIA LABORATORIES TECH. REPTS.
C     SAND77-0552, (1978), AND SAND78-1290, (1979), AND MATH.
C     PROGRAMMING (21), 1981, PP. 98-118. MODIFIED BY A.H. MORRIS.
C
C     ABSTRACT
C
C     THIS SUBPROGRAM SOLVES A LINEARLY CONSTRAINED LEAST SQUARES
C     PROBLEM WITH BOTH EQUALITY AND INEQUALITY CONSTRAINTS, AND, IF THE
C     USER REQUESTS, OBTAINS A COVARIANCE MATRIX OF THE SOLUTION
C     PARAMETERS.
C
C     SUPPOSE THERE ARE GIVEN MATRICES E, A AND G OF RESPECTIVE
C     DIMENSIONS ME BY N, MA BY N AND MG BY N, AND VECTORS F, B AND H OF
C     RESPECTIVE LENGTHS ME, MA AND MG.  THIS SUBROUTINE SOLVES THE
C     LINEARLY CONSTRAINED LEAST SQUARES PROBLEM
C
C                   EX = F, (E ME BY N) (EQUATIONS TO BE EXACTLY
C                                       SATISFIED)
C                   AX = B, (A MA BY N) (EQUATIONS TO BE
C                                       APPROXIMATELY SATISFIED,
C                                       LEAST SQUARES SENSE)
C                   GX.GE.H,(G MG BY N) (INEQUALITY CONSTRAINTS)
C
C     THE INEQUALITIES GX.GE.H MEAN THAT EVERY COMPONENT OF THE PRODUCT
C     GX MUST BE .GE. THE CORRESPONDING COMPONENT OF H.
C
C     IN CASE THE EQUALITY CONSTRAINTS CANNOT BE SATISFIED, A
C     GENERALIZED INVERSE SOLUTION RESIDUAL VECTOR LENGTH IS OBTAINED
C     FOR F-EX. THIS IS THE MINIMAL LENGTH POSSIBLE FOR F-EX.
C
C
C     ANY VALUES ME.GE.0, MA.GE.0, OR MG.GE.0 ARE PERMITTED.  THE
C     RANK OF THE MATRIX E IS ESTIMATED DURING THE COMPUTATION. WE CALL
C     THIS VALUE KRANKE. IT IS AN OUTPUT PARAMETER IN IP(1) DEFINED
C     BELOW. USING A GENERALIZED INVERSE SOLUTION OF EX=F, A REDUCED
C     LEAST SQUARES PROBLEM WITH INEQUALITY CONSTRAINTS IS OBTAINED.
C     THE TOLERANCES USED IN THESE TESTS FOR DETERMINING THE RANK
C     OF E AND THE RANK OF THE REDUCED LEAST SQUARES PROBLEM ARE
C     GIVEN IN SANDIA TECH. REPT. SAND78-1290. THEY CAN BE
C     MODIFIED BY THE USER IF NEW VALUES ARE PROVIDED IN
C     THE OPTION LIST OF THE ARRAY PRGOPT(*).
C
C     THE USER MUST DIMENSION ALL ARRAYS APPEARING IN THE CALL LIST..
C     W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2)
C     WHERE K=MAX(MA+MG,N).  THIS ALLOWS FOR A SOLUTION OF A RANGE OF
C     PROBLEMS IN THE GIVEN WORKING SPACE.  THE DIMENSION OF WS(*)
C     GIVEN IS A NECESSARY OVERESTIMATE.  ONCE A PARTICULAR PROBLEM
C     HAS BEEN RUN, THE OUTPUT PARAMETER IP(3) GIVES THE ACTUAL
C     DIMENSION REQUIRED FOR THAT PROBLEM.
C
C     THE PARAMETERS FOR LSEI( ) ARE
C
C     INPUT..
C
C     W(*,*),MDW,   THE ARRAY W(*,*) IS DOUBLY SUBSCRIPTED WITH
C     ME,MA,MG,N    FIRST DIMENSIONING PARAMETER EQUAL TO MDW.
C                   FOR THIS DISCUSSION LET US CALL M = ME+MA+MG.  THEN
C                   MDW MUST SATISFY MDW.GE.M.  THE CONDITION
C                   MDW.LT.M IS AN ERROR.
C
C                   THE ARRAY W(*,*) CONTAINS THE MATRICES AND VECTORS
C
C                                  (E  F)
C                                  (A  B)
C                                  (G  H)
C
C                   IN ROWS AND COLUMNS 1,...,M AND 1,...,N+1
C                   RESPECTIVELY.
C
C                   THE INTEGERS ME, MA, AND MG ARE THE
C                   RESPECTIVE MATRIX ROW DIMENSIONS
C                   OF E, A AND G. EACH MATRIX HAS N COLUMNS.
C
C     PRGOPT(*)    THIS REAL-VALUED ARRAY IS THE OPTION VECTOR.
C                  IF THE USER IS SATISFIED WITH THE NOMINAL
C                  SUBPROGRAM FEATURES SET
C
C                  PRGOPT(1)=1 (OR PRGOPT(1)=1.0)
C
C                  OTHERWISE PRGOPT(*) IS A LINKED LIST CONSISTING OF
C                  GROUPS OF DATA OF THE FOLLOWING FORM
C
C                  LINK
C                  KEY
C                  DATA SET
C
C                  THE PARAMETERS LINK AND KEY ARE EACH ONE WORD.
C                  THE DATA SET CAN BE COMPRISED OF SEVERAL WORDS.
C                  THE NUMBER OF ITEMS DEPENDS ON THE VALUE OF KEY.
C                  THE VALUE OF LINK POINTS TO THE FIRST
C                  ENTRY OF THE NEXT GROUP OF DATA WITHIN
C                  PRGOPT(*).  THE EXCEPTION IS WHEN THERE ARE
C                  NO MORE OPTIONS TO CHANGE.  IN THAT
C                  CASE LINK=1 AND THE VALUES KEY AND DATA SET
C                  ARE NOT REFERENCED. THE GENERAL LAYOUT OF
C                  PRGOPT(*) IS AS FOLLOWS.
C
C               ...PRGOPT(1)=LINK1 (LINK TO FIRST ENTRY OF NEXT GROUP)
C               .  PRGOPT(2)=KEY1 (KEY TO THE OPTION CHANGE)
C               .  PRGOPT(3)=DATA VALUE (DATA VALUE FOR THIS CHANGE)
C               .       .
C               .       .
C               .       .
C               ...PRGOPT(LINK1)=LINK2 (LINK TO THE FIRST ENTRY OF
C               .                       NEXT GROUP)
C               .  PRGOPT(LINK1+1)=KEY2 (KEY TO THE OPTION CHANGE)
C               .  PRGOPT(LINK1+2)=DATA VALUE
C               ...     .
C               .       .
C               .       .
C               ...PRGOPT(LINK)=1 (NO MORE OPTIONS TO CHANGE)
C
C                  VALUES OF LINK THAT ARE NONPOSITIVE ARE ERRORS.
C                  A VALUE OF LINK.GT.NLINK=100000 IS ALSO AN ERROR.
C                  THIS HELPS PREVENT USING INVALID BUT POSITIVE
C                  VALUES OF LINK THAT WILL PROBABLY EXTEND
C                  BEYOND THE PROGRAM LIMITS OF PRGOPT(*).
C                  UNRECOGNIZED VALUES OF KEY ARE IGNORED.  THE
C                  ORDER OF THE OPTIONS IS ARBITRARY AND ANY NUMBER
C                  OF OPTIONS CAN BE CHANGED WITH THE FOLLOWING
C                  RESTRICTION.  TO PREVENT CYCLING IN THE
C                  PROCESSING OF THE OPTION ARRAY A COUNT OF THE
C                  NUMBER OF OPTIONS CHANGED IS MAINTAINED.
C                  WHENEVER THIS COUNT EXCEEDS NOPT=1000 THE
C                  ROUTINE TERMINATES.
C
C                  OPTIONS..
C
C                  KEY=1
C                         COMPUTE IN W(*,*) THE N BY N
C                  COVARIANCE MATRIX OF THE SOLUTION VARIABLES
C                  AS AN OUTPUT PARAMTER.  NOMINALLY THE
C                  COVARIANCE MATRIX WILL NOT BE COMPUTED.
C                  (THIS REQUIRES NO USER INPUT.)
C                  THE DATA SET FOR THIS OPTION IS A SINGLE VALUE.
C                  IT MUST BE NONZERO WHEN THE COVARIANCE MATRIX
C                  IS DESIRED.  IF IT IS ZERO, THE COVARIANCE
C                  MATRIX IS NOT COMPUTED.  WHEN THE COVARIANCE MATRIX
C                  IS COMPUTED, THE FIRST DIMENSIONING PARAMETER
C                  OF THE ARRAY W(*,*) MUST SATISFY MDW.GE.MAX0(M,N).
C
C                  KEY=2
C                         SCALE THE NONZERO COLUMNS OF THE
C                         ENTIRE DATA MATRIX.
C                  (E)
C                  (A)
C                  (G)
C
C                  TO HAVE LENGTH ONE.  THE DATA SET FOR THIS
C                  OPTION IS A SINGLE VALUE.  IT MUST BE
C                  NONZERO IF UNIT LENGTH COLUMN SCALING
C                  IS DESIRED.
C
C                  KEY=3
C                         SCALE COLUMNS OF THE ENTIRE DATA MATRIX
C                  (E)
C                  (A)
C                  (G)
C
C                  WITH A USER-PROVIDED DIAGONAL MATRIX.
C                  THE DATA SET FOR THIS OPTION CONSISTS
C                  OF THE N DIAGONAL SCALING FACTORS, ONE FOR
C                  EACH MATRIX COLUMN.
C
C                  KEY=4
C                         CHANGE THE RANK DETERMINATION TOLERANCE FOR
C                  THE EQUALITY CONSTRAINT EQUATIONS FROM
C                  THE NOMINAL VALUE OF SQRT(SRELPR).  THIS QUANTITY
C                  CAN BE NO SMALLER THAN SRELPR, THE ARITHMETIC-
C                  STORAGE PRECISION.  THE QUANTITY SRELPR IS THE
C                  LARGEST POSITIVE NUMBER SUCH THAT T=1.+SRELPR
C                  SATISFIES T.EQ.1.  THE QUANTITY USED
C                  HERE IS INTERNALLY RESTRICTED TO BE AT
C                  LEAST SRELPR.  THE DATA SET FOR THIS OPTION
C                  IS THE NEW TOLERANCE.
C
C                  KEY=5
C                         CHANGE THE RANK DETERMINATION TOLERANCE FOR
C                  THE REDUCED LEAST SQUARES EQUATIONS FROM
C                  THE NOMINAL VALUE OF SQRT(SRELPR).  THIS QUANTITY
C                  CAN BE NO SMALLER THAN SRELPR, THE ARITHMETIC-
C                  STORAGE PRECISION.  THE QUANTITY USED
C                  HERE IS INTERNALLY RESTRICTED TO BE AT
C                  LEAST SRELPR.  THE DATA SET FOR THIS OPTION
C                  IS THE NEW TOLERANCE.
C
C                  FOR EXAMPLE, SUPPOSE WE WANT TO CHANGE
C                  THE TOLERANCE FOR THE REDUCED LEAST SQUARES
C                  PROBLEM, COMPUTE THE COVARIANCE MATRIX OF
C                  THE SOLUTION PARAMETERS, AND PROVIDE
C                  COLUMN SCALING FOR THE DATA MATRIX.  FOR
C                  THESE OPTIONS THE DIMENSION OF PRGOPT(*)
C                  MUST BE AT LEAST N+9.  THE FORTRAN STATEMENTS
C                  DEFINING THESE OPTIONS WOULD BE AS FOLLOWS.
C
C                  PRGOPT(1)=4 (LINK TO ENTRY 4 IN PRGOPT(*))
C                  PRGOPT(2)=1 (COVARIANCE MATRIX KEY)
C                  PRGOPT(3)=1 (COVARIANCE MATRIX WANTED)
C
C                  PRGOPT(4)=7 (LINK TO ENTRY 7 IN PRGOPT(*))
C                  PRGOPT(5)=5 (LEAST SQUARES EQUAS. TOLERANCE KEY)
C                  PRGOPT(6)=... (NEW VALUE OF THE TOLERANCE)
C
C                  PRGOPT(7)=N+9 (LINK TO ENTRY N+9 IN PRGOPT(*))
C                  PRGOPT(8)=3 (USER-PROVIDED COLUMN SCALING KEY)
C
C                  CALL SCOPY(N,D,1,PRGOPT(9),1)  (COPY THE N
C                    SCALING FACTORS FROM THE USER ARRAY D(*)
C                    TO PRGOPT(9)-PRGOPT(N+8))
C
C                  PRGOPT(N+9)=1 (NO MORE OPTIONS TO CHANGE)
C
C                  THE CONTENTS OF PRGOPT(*) ARE NOT MODIFIED
C                  BY THE SUBPROGRAM.
C                  THE KEY 8 AND 9 OPTIONS FOR WNNLS( ) CAN ALSO
C                  BE INCLUDED IN THIS ARRAY.  THEIR FUNCTIONS
C                  ARE DOCUMENTED IN THE USAGE INSTRUCTIONS FOR
C                  SUBPROGRAM WNNLS( ).
C
C     OUTPUT..
C
C     X(*),RNORME,  THE ARRAY X(*) CONTAINS THE SOLUTION PARAMETERS
C     RNORML        IF THE INTEGER OUTPUT FLAG MODE = 0 OR 1.
C                   THE DEFINITION OF MODE IS GIVEN DIRECTLY BELOW.
C                   WHEN MODE = 0 OR 1, RNORME AND RNORML
C                   RESPECTIVELY CONTAIN THE RESIDUAL VECTOR
C                   EUCLIDEAN LENGTHS OF F - EX AND B - AX.  WHEN
C                   MODE=1 THE EQUALITY CONSTRAINT EQUATIONS EX=F
C                   ARE CONTRADICTORY, SO RNORME.NE.0. THE RESIDUAL
C                   VECTOR F-EX HAS MINIMAL EUCLIDEAN LENGTH. FOR
C                   MODE.GE.2, NONE OF THESE PARAMETERS ARE
C                   DEFINED.
C
C     MODE          INTEGER FLAG THAT INDICATES THE SUBPROGRAM
C                   STATUS AFTER COMPLETION.  IF MODE.GE.2, NO
C                   SOLUTION HAS BEEN COMPUTED.
C
C                   MODE =
C
C                   0  BOTH EQUALITY AND INEQUALITY CONSTRAINTS
C                      ARE COMPATIBLE AND HAVE BEEN SATISFIED.
C
C                   1  EQUALITY CONSTRAINTS ARE CONTRADICTORY.
C                      A GENERALIZED INVERSE SOLUTION OF EX=F WAS USED
C                      TO MINIMIZE THE RESIDUAL VECTOR LENGTH F-EX.
C                      IN THIS SENSE, THE SOLUTION IS STILL MEANINGFUL.
C
C                   2  NO SOLUTION COULD BE OBTAINED. THE CONSTRAINTS
C                      ARE CONTRADICTORY.
C
C                   4  USAGE ERROR OCCURRED.  THE VALUE
C                      OF MDW IS .LT. ME+MA+MG, MDW IS
C                      .LT. N AND A COVARIANCE MATRIX IS
C                      REQUESTED, OR THE OPTION VECTOR
C                      PRGOPT(*) IS NOT PROPERLY DEFINED.
C
C     W(*,*)        THE ARRAY W(*,*) CONTAINS THE N BY N SYMMETRIC
C                   COVARIANCE MATRIX OF THE SOLUTION PARAMETERS,
C                   PROVIDED THIS WAS REQUESTED ON INPUT WITH
C                   THE OPTION VECTOR PRGOPT(*) AND THE OUTPUT
C                   FLAG IS RETURNED WITH MODE = 0 OR 1.
C
C     IP(*)         THE INTEGER WORKING ARRAY HAS THREE ENTRIES
C                   THAT PROVIDE RANK AND WORKING ARRAY LENGTH
C                   INFORMATION AFTER COMPLETION.
C
C                      IP(1) = RANK OF EQUALITY CONSTRAINT
C                              MATRIX.  DEFINE THIS QUANTITY
C                              AS KRANKE.
C
C                      IP(2) = RANK OF REDUCED LEAST SQUARES
C                              PROBLEM.
C
C                      IP(3) = THE AMOUNT OF STORAGE IN THE
C                              WORKING ARRAY WS(*) THAT WAS
C                              ACTUALLY USED BY THE SUBPROGRAM.
C                              THE FORMULA GIVEN ABOVE FOR THE LENGTH
C                              OF WS(*) IS A NECESSARY OVERESTIMATE.
C     USER DESIGNATED
C     WORKING ARRAYS..
C
C     WS(*),IP(*)              THESE ARE RESPECTIVELY TYPE REAL
C                              AND TYPE INTEGER WORKING ARRAYS.
C                              THEIR REQUIRED MINIMAL LENGTHS ARE
C                              GIVEN ABOVE.
C
C
C     SUBROUTINES CALLED
C
C     LSI           PART OF THIS PACKAGE.  SOLVES A
C                   CONSTRAINED LEAST SQUARES PROBLEM WITH
C                   INEQUALITY CONSTRAINTS.
C
C     SDOT,SSCAL,   SUBROUTINES FROM THE BLAS PACKAGE.
C     SAXPY,SASUM,  SEE TRANS. MATH SOFTWARE (5), P. 308.
C     SCOPY,SNRM2,
C     SSWAP,ISAMAX
C
C     H12           SUBROUTINE TO CONSTRUCT AND APPLY A
C                   HOUSEHOLDER TRANSFORMATION.
C
C     SPMPAR        FUNCTION TO COMPUTE THE RELATIVE MACHINE
C                   PRECISION.
C
C     REVISED OCT. 1, 1989.
C
      REAL W(MDW,*), PRGOPT(*), X(*), WS(*)
      INTEGER IP(*)
      LOGICAL COV
      DATA ZERO /0.E0/, ONE /1.E0/, HALF /0.5E0/
C
C     COMPUTE MACHINE PRECISION
C
      SRELPR = SPMPAR(1)
C
C     COMPUTE NUMBER OF POSSIBLE RIGHT MULTIPLYING HOUSEHOLDER
C     TRANSFORMATIONS.
C
      M = ME + MA + MG
      MODE = 0
      IF (N .LE. 0 .OR. ME + MA .LE. 0) RETURN
      IF (.NOT.(MDW.LT.M)) GO TO 80
      MODE = 4
      RETURN
   80 NP1 = N + 1
      KRANKE = MIN0(ME,N)
      N1 = 2*KRANKE + 1
      N2 = N1 + N
C
C     PROCESS-OPTION-VECTOR
C
      GO TO 480
   90 IF (.NOT.(COV .AND. MDW.LT.N)) GO TO 100
      MODE = 4
      RETURN
  100 L = KRANKE
C
C     COMPUTE NORM OF EQUALITY CONSTRAINT MATRIX AND RT SIDE.
C
      ENORM = ZERO
      DO 110 J = 1,N
        ENORM = AMAX1(ENORM,SASUM(ME,W(1,J),1))
  110 CONTINUE
      FNORM = SASUM(ME,W(1,NP1),1)
      IF (.NOT.(L.GT.0)) GO TO 200
      SNMAX = ZERO
      RNMAX = ZERO
      DO 180 I = 1,L
C
C     COMPUTE MAXIMUM RATIO OF VECTOR LENGTHS. PARTITION
C     IS AT COL. I.
        DO 150 K = I,ME
           SN = SDOT(N-I+1,W(K,I),MDW,W(K,I),MDW)
           RN = SDOT(I-1,W(K,1),MDW,W(K,1),MDW)
           IF (.NOT.(RN.EQ.ZERO .AND. SN.GT.SNMAX)) GO TO 120
           SNMAX = SN
           IMAX = K
           GO TO 150
  120      IF (.NOT.(K.EQ.I .OR. (SN*RNMAX.GT.RN*SNMAX))) GO TO 150
           SNMAX = SN
           RNMAX = RN
           IMAX = K
  150   CONTINUE
C
C     INTERCHANGE ROWS IF NECESSARY.
        IF (I.NE.IMAX) CALL SSWAP(NP1, W(I,1), MDW, W(IMAX,1), MDW)
        IF (.NOT.(SNMAX.GT.TAU**2*RNMAX)) GO TO 160
C
C     ELIMINATE ELEMS I+1,...,N IN ROW I.
        CALL H12(1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, 1,
     *   M-I)
        GO TO 180
  160   KRANKE = I - 1
        GO TO 200
  180 CONTINUE
C
C     SAVE DIAG. TERMS OF LOWER TRAP. MATRIX.
C
  200 CALL SCOPY(KRANKE, W, MDW+1, WS(KRANKE+1), 1)
C
C     USE HOUSEHOLDER TRANS FROM LEFT TO ACHIEVE KRANKE BY KRANKE UPPER
C     TRIANGULAR FORM.
C
      IF (.NOT.(KRANKE.GT.0 .AND. KRANKE.LT.ME)) GO TO 220
      DO 210 KK = 1,KRANKE
        K = KRANKE + 1 - KK
C
C     APPLY TRANFORMATION TO MATRIX COLS. 1,...,K-1.
        CALL H12(1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, K-1)
C
C     APPLY TO RT SIDE VECTOR.
        CALL H12(2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, 1, 1)
  210 CONTINUE
  220 IF (.NOT.(KRANKE.GT.0)) GO TO 240
C
C     SOLVE FOR VARIABLES 1,...,KRANKE IN NEW COORDINATES.
      CALL SCOPY(KRANKE, W(1,NP1), 1, X, 1)
      DO 230 I=1,KRANKE
        X(I) = (X(I)-SDOT(I-1,W(I,1),MDW,X,1))/W(I,I)
  230 CONTINUE
C
C     COMPUTE RESIDUALS FOR REDUCED PROBLEM.
C
  240 MEP1 = ME + 1
      RNORML = ZERO
      IF (.NOT.(ME.LT.M)) GO TO 270
      DO 260 I = MEP1,M
        W(I,NP1) = W(I,NP1) - SDOT(KRANKE,W(I,1),MDW,X,1)
        SN = SDOT(KRANKE,W(I,1),MDW,W(I,1),MDW)
        RN = SDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW)
        IF (.NOT.(RN.LE.TAU**2*SN .AND. KRANKE.LT.N)) GO TO 260
        W(I,KRANKE+1) = ZERO
        CALL SCOPY(N-KRANKE, W(I,KRANKE+1), 0, W(I,KRANKE+1), MDW)
  260 CONTINUE
C
C     COMPUTE EQUAL. CONSTRAINT EQUAS. RESIDUAL LENGTH.
  270 RNORME = SNRM2(ME-KRANKE,W(KRANKE+1,NP1),1)
C
C     MOVE REDUCED PROBLEM DATA UPWARD IF KRANKE.LT.ME.
C
      IF (.NOT.(KRANKE.LT.ME)) GO TO 290
      DO 280 J=1,NP1
        CALL SCOPY(M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1)
  280 CONTINUE
C
C     COMPUTE SOLN OF REDUCED PROBLEM.
C
  290 CALL LSI(W(KRANKE+1,KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT,
     * X(KRANKE+1), RNORML, MODE, WS(N2), IP(2))
      IF (MODE .GT. 1) GO TO 470
      IF (.NOT.(ME.GT.0)) GO TO 330
C
C     TEST FOR CONSISTENCY OF EQUALITY CONSTRAINTS.
C
      MDEQC = 0
      XNRME = SASUM(KRANKE,W(1,NP1),1)
      IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1
      MODE = MODE + MDEQC
C
C     CHECK IF SOLN TO EQUAL. CONSTRAINTS SATISFIES INEQUAL.
C     CONSTRAINTS WHEN THERE ARE NO DEGREES OF FREEDOM LEFT.
C
      IF (.NOT.(KRANKE.EQ.N .AND. MG.GT.0)) GO TO 330
      XNORM = SASUM(N,X,1)
      MAPKE1 = MA + KRANKE + 1
      MEND = MA + KRANKE + MG
      DO 310 I=MAPKE1,MEND
        SIZE = SASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1))
        IF (.NOT.(W(I,NP1).GT.TAU*SIZE)) GO TO 310
        MODE = 2
        GO TO 470
  310 CONTINUE
  330 IF (.NOT.(KRANKE.GT.0)) GO TO 420
C
C     REPLACE DIAG. TERMS OF LOWER TRAP. MATRIX.
      CALL SCOPY(KRANKE, WS(KRANKE+1), 1, W, MDW+1)
C
C     REAPPLY TRANS TO PUT SOLN IN ORIGINAL COORDINATES.
C
      DO 340 II = 1,KRANKE
        I = KRANKE + 1 - II
        CALL H12(2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1)
  340 CONTINUE
C
C     COMPUTE COV MATRIX OF EQUAL. CONSTRAINED PROBLEM.
C
      IF (.NOT.(COV)) GO TO 450
      DO 400 JJ=1,KRANKE
        J = KRANKE + 1 - JJ
        IF (.NOT.(J.LT.N)) GO TO 400
        RB = WS(J)*W(J,J)
        IF (RB.NE.ZERO) RB = ONE/RB
        JP1 = J + 1
        DO 350 I=JP1,N
          W(I,J) = SDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW)*RB
  350   CONTINUE
        GAM = SDOT(N-J,W(JP1,J),1,W(J,JP1),MDW)*RB
        GAM = HALF*GAM
        CALL SAXPY(N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1)
        DO 370 I=JP1,N
          DO 360 K=I,N
            W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K)
            W(K,I) = W(I,K)
  360     CONTINUE
  370   CONTINUE
        UJ = WS(J)
        VJ = GAM*UJ
        W(J,J) = UJ*VJ + UJ*VJ
        DO 380 I=JP1,N
          W(J,I) = UJ*W(I,J) + VJ*W(J,I)
  380   CONTINUE
        CALL SCOPY(N-J, W(J,JP1), MDW, W(JP1,J), 1)
  400 CONTINUE
C
C     APPLY THE SCALING TO THE COVARIANCE MATRIX.
C
  420 IF (.NOT.(COV)) GO TO 450
      DO 430 I = 1,N
        L = N1 + I
        CALL SSCAL(N, WS(L-1), W(I,1), MDW)
        CALL SSCAL(N, WS(L-1), W(1,I), 1)
  430 CONTINUE
C
C     RESCALE SOLN. VECTOR.
C
  450 IF (MODE .GT. 1) GO TO 470
      DO 460 J = 1,N
        L = N1 + J
        X(J) = X(J)*WS(L-1)
  460 CONTINUE
  470 IP(1) = KRANKE
      IP(3) = IP(3) + 2*KRANKE + N
      RETURN
  480 CONTINUE
C     TO PROCESS-OPTION-VECTOR
C
C     THE NOMINAL TOLERANCE USED IN THE CODE
C     FOR THE EQUALITY CONSTRAINT EQUATIONS.
      TAU = SQRT(SRELPR)
C
C     THE NOMINAL COLUMN SCALING USED IN THE CODE IS
C     THE IDENTITY SCALING.
      WS(N1) = ONE
      CALL SCOPY(N, WS(N1), 0, WS(N1), 1)
C
C     NO COVARIANCE MATRIX IS NOMINALLY COMPUTED.
      COV = .FALSE.
C
C     DEFINE BOUND FOR NUMBER OF OPTIONS TO CHANGE.
      NOPT = 1000
      NTIMES = 0
C
C     DEFINE BOUND FOR POSITIVE VALUES OF LINK.
      NLINK = 100000
      LAST = 1
      LINK = PRGOPT(1)
      IF (.NOT.(LINK.LE.0 .OR. LINK.GT.NLINK)) GO TO 490
      MODE = 4
      RETURN
  490 IF (.NOT.(LINK.GT.1)) GO TO 540
      NTIMES = NTIMES + 1
      IF (.NOT.(NTIMES.GT.NOPT)) GO TO 500
      MODE = 4
      RETURN
  500 KEY = PRGOPT(LAST+1)
      IF (KEY.EQ.1) COV = PRGOPT(LAST+2).NE.ZERO
      IF (.NOT.(KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.ZERO)) GO TO 520
      DO 510 J=1,N
        T = SNRM2(M,W(1,J),1)
        IF (T.NE.ZERO) T = ONE/T
        L = N1 + J
        WS(L-1) = T
  510 CONTINUE
  520 IF (KEY.EQ.3) CALL SCOPY(N, PRGOPT(LAST+2), 1, WS(N1), 1)
      IF (KEY.EQ.4) TAU = AMAX1(SRELPR,PRGOPT(LAST+2))
      NEXT = PRGOPT(LINK)
      IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.NLINK)) GO TO 530
      MODE = 4
      RETURN
  530 LAST = LINK
      LINK = NEXT
      GO TO 490
  540 DO 550 J=1,N
        L = N1 + J
        CALL SSCAL(M, WS(L-1), W(1,J), 1)
  550 CONTINUE
      GO TO 90
      END
      SUBROUTINE LSI(W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, IP)
C
C     THIS IS A COMPANION SUBPROGRAM TO LSEI( ).
C     THE DOCUMENTATION FOR LSEI( ) HAS MORE COMPLETE
C     USAGE INSTRUCTIONS.
C     WRITTEN BY R. J. HANSON, SLA.
C
C     SOLVE..
C              AX = B,  A  MA BY N  (LEAST SQUARES EQUATIONS)
C     SUBJECT TO..
C
C              GX.GE.H, G  MG BY N  (INEQUALITY CONSTRAINTS)
C
C     INPUT..
C
C      W(*,*) CONTAINS  (A B) IN ROWS 1,...,MA+MG, COLS 1,...,N+1.
C                       (G H)
C
C     MDW,MA,MG,N
C              CONTAIN (RESP) VAR. DIMENSION OF W(*,*),
C              AND MATRIX DIMENSIONS.
C
C     PRGOPT(*),
C              PROGRAM OPTION VECTOR.
C
C     OUTPUT..
C
C      X(*),RNORM
C
C              SOLUTION VECTOR(UNLESS MODE=2), LENGTH OF AX-B.
C
C      MODE
C              =0   INEQUALITY CONSTRAINTS ARE COMPATIBLE.
C              =2   INEQUALITY CONSTRAINTS CONTRADICTORY.
C
C      WS(*),
C              WORKING STORAGE OF DIMENSION K+N+(MG+2)*(N+7),
C              WHERE K=MAX(MA+MG,N).
C      IP(MG+2*N+1)
C              INTEGER WORKING STORAGE
C
C     SUBROUTINES CALLED
C
C     LPDP          THIS SUBPROGRAM MINIMIZES A SUM OF SQUARES
C                   OF UNKNOWNS SUBJECT TO LINEAR INEQUALITY
C                   CONSTRAINTS.  PART OF THIS PACKAGE.
C
C     SDOT,SSCAL    SUBROUTINES FROM THE BLAS PACKAGE.
C     SAXPY,SASUM,  SEE TRANS. MATH SOFTWARE (5), P. 308.
C     SCOPY,SSWAP
C
C     HFTI          SOLVES AN UNCONSTRAINED LINEAR LEAST SQUARES
C                   PROBLEM.
C
C     H12           SUBROUTINE TO CONSTRUCT AND APPLY A HOUSEHOLDER
C                   TRANSFORMATION.
C
C     SPMPAR        FUNCTION TO COMPUTE THE RELATIVE MACHINE
C                   PRECISION.
C
      REAL W(MDW,*), PRGOPT(*), X(*), WS(*), RNRM(1), OPT(7)
      INTEGER IP(*)
      LOGICAL COV
C
      DATA ZERO /0.E0/, ONE /1.E0/, HALF /0.5E0/
C
      SRELPR = SPMPAR(1)
      MODE = 0
      RNORM = ZERO
      M = MA + MG
      NP1 = N + 1
      KRANK = 0
      IF (N.LE.0 .OR. M.LE.0) GO TO 70
C
C     PROCESS-OPTION-VECTOR
C
      GO TO 500
C
C     COMPUTE MATRIX NORM OF LEAST SQUARES EQUAS.
C
   40 ANORM = ZERO
      DO 50 J = 1,N
        ANORM = AMAX1(ANORM,SASUM(MA,W(1,J),1))
   50 CONTINUE
C
C     SET TOL FOR HFTI( ) RANK TEST.
      TAU = TOL*ANORM
C
C     COMPUTE HOUSEHOLDER ORTHOGONAL DECOMP OF MATRIX.
C
      IF (N.GT.0) WS(1) = ZERO
      CALL SCOPY(N, WS, 0, WS, 1)
      CALL SCOPY(MA, W(1,NP1), 1, WS, 1)
      K = MAX0(M,N)
      MINMAN = MIN0(MA,N)
      N1 = K + 1
      N2 = N1 + N
      CALL HFTI(W, MDW, MA, N, WS, 1, 1, TAU, KRANK, RNRM, WS(N2),
     * WS(N1), IP)
      RNORM = RNRM(1)
      FAC = ONE
      GAM = MA - KRANK
      IF (KRANK .LT. MA) FAC = RNORM**2/GAM
      GO TO 80
C
C     REDUCE-TO-LPDP-AND-SOLVE
C
   70 IP(1) = KRANK
      IP(2) = N + MAX0(M,N) + (MG+2)*(N+7)
      RETURN
C
C     TO REDUCE-TO-LPDP-AND-SOLVE
C
   80 MAP1 = MA + 1
C
C     COMPUTE INEQ. RT-HAND SIDE FOR LPDP.
C
      IF (.NOT.(MA.LT.M)) GO TO 260
      IF (.NOT.(MINMAN.GT.0)) GO TO 160
      DO 90 I = MAP1,M
        W(I,NP1) = W(I,NP1) - SDOT(N,W(I,1),MDW,WS,1)
   90 CONTINUE
      DO 100 I = 1,MINMAN
        J = IP(I)
C
C     APPLY PERMUTATIONS TO COLS OF INEQ. CONSTRAINT MATRIX.
        CALL SSWAP(MG, W(MAP1,I), 1, W(MAP1,J), 1)
  100 CONTINUE
C
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO CONSTRAINT MATRIX.
C
      IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 120
      DO 110 II = 1,KRANK
        I = KRANK + 1 - II
        L = N1 + I
        CALL H12(2, I, KRANK+1, N, W(I,1), MDW, WS(L-1), W(MAP1,1),
     *   MDW, 1, MG)
  110 CONTINUE
C
C     COMPUTE PERMUTED INEQ. CONSTR. MATRIX TIMES R-INVERSE.
C
  120 DO 150 I=MAP1,M
        IF (.NOT.(0.LT.KRANK)) GO TO 150
        DO 130 J=1,KRANK
          W(I,J) = (W(I,J)-SDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J)
  130   CONTINUE
  150 CONTINUE
C
C     SOLVE THE REDUCED PROBLEM WITH LPDP ALGORITHM,
C     THE LEAST PROJECTED DISTANCE PROBLEM.
C
  160 CALL LPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, OPT, X, XNORM,
     * MDLPDP, WS(N2), IP(N+1))
      IF (MDLPDP .NE. 1) GO TO 240
      IF (.NOT.(KRANK.GT.0)) GO TO 180
C
C     COMPUTE SOLN IN ORIGINAL COORDINATES.
C
      DO 170 II = 1,KRANK
        I = KRANK + 1 - II
        X(I) = (X(I)-SDOT(II-1,W(I,I+1),MDW,X(I+1),1))/W(I,I)
  170 CONTINUE
C
C     APPLY HOUSEHOLDER TRANS. TO SOLN VECTOR.
C
  180 IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 200
      DO 190 I = 1,KRANK
        L = N1 + I
        CALL H12(2, I, KRANK+1, N, W(I,1), MDW, WS(L-1), X, 1, 1, 1)
  190 CONTINUE
  200 IF (.NOT.(MINMAN.GT.0)) GO TO 270
C
C     REPERMUTE VARIABLES TO THEIR INPUT ORDER.
      DO 210 II=1,MINMAN
        I = MINMAN + 1 - II
        J = IP(I)
        CALL SSWAP(1, X(I), 1, X(J), 1)
  210 CONTINUE
C
C     VARIABLES ARE NOW IN ORIG. COORDINATES.
C     ADD SOLN OF UNSCONSTRAINED PROB.
      DO 220 I = 1,N
        X(I) = X(I) + WS(I)
  220 CONTINUE
C
C     COMPUTE THE RESIDUAL VECTOR NORM.
      RNORM = SQRT(RNORM**2+XNORM**2)
      GO TO 270
  240 MODE = 2
      GO TO 270
  260 CALL SCOPY(N, WS, 1, X, 1)
  270 IF (.NOT.(COV .AND. KRANK.GT.0)) GO TO 70
C
C     COMPUTE COVARIANCE MATRIX BASED ON THE ORTHOGONAL DECOMP.
C     FROM HFTI( ).
C
      KRM1 = KRANK - 1
      KRP1 = KRANK + 1
C
C     COPY DIAG. TERMS TO WORKING ARRAY.
      CALL SCOPY(KRANK, W, MDW+1, WS(N2), 1)
C
C     RECIPROCATE DIAG. TERMS.
      DO 280 J = 1,KRANK
        W(J,J) = ONE/W(J,J)
  280 CONTINUE
      IF (.NOT.(KRANK.GT.1)) GO TO 310
C
C     INVERT THE UPPER TRIANGULAR QR FACTOR ON ITSELF.
      DO 300 I=1,KRM1
        IP1 = I + 1
        DO 290 J=IP1,KRANK
          W(I,J) = -SDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J)
  290   CONTINUE
  300 CONTINUE
C
C     COMPUTE THE INVERTED FACTOR TIMES ITS TRANSPOSE.
  310 DO 330 I=1,KRANK
        DO 320 J=I,KRANK
          W(I,J) = SDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW)
  320   CONTINUE
  330 CONTINUE
      IF (.NOT.(KRANK.LT.N)) GO TO 450
C
C     ZERO OUT LOWER TRAPEZOIDAL PART.
C     COPY UPPER TRI. TO LOWER TRI. PART.
      DO 340 J=1,KRANK
        CALL SCOPY(J, W(1,J), 1, W(J,1), MDW)
  340 CONTINUE
      DO 350 I=KRP1,N
        W(I,1) = ZERO
        CALL SCOPY(I, W(I,1), 0, W(I,1), MDW)
  350 CONTINUE
C
C     APPLY RIGHT SIDE TRANSFORMATIONS TO LOWER TRI.
      N3 = N2 + KRP1
      DO 430 I=1,KRANK
        L = N1 + I
        K = N2 + I
        RB = WS(L-1)*WS(K-1)
        IF (.NOT.(RB.LT.ZERO)) GO TO 420
C
C     IF RB.GE.ZERO, TRANSFORMATION CAN BE REGARDED AS ZERO.
        RB = ONE/RB
C
C     STORE UNSCALED RANK-ONE HOUSEHOLDER UPDATE IN WORK ARRAY.
        WS(N3) = ZERO
        CALL SCOPY(N, WS(N3), 0, WS(N3), 1)
        L = N1 + I
        K = N3 + I
        WS(K-1) = WS(L-1)
        DO 360 J=KRP1,N
          K = N3 + J
          WS(K-1) = W(I,J)
  360   CONTINUE
        DO 370 J=1,N
          L = N3 + I
          K = N3 + J
          WS(J) = SDOT(J-I,W(J,I),MDW,WS(L-1),1) + SDOT(N-J+1,W(J,J),1,
     *     WS(K-1),1)
          WS(J) = WS(J)*RB
  370   CONTINUE
        L = N3 + I
        GAM = SDOT(N-I+1,WS(L-1),1,WS(I),1)*RB
        GAM = GAM*HALF
        CALL SAXPY(N-I+1, GAM, WS(L-1), 1, WS(I), 1)
        DO 410 J=I,N
          IF (.NOT.(I.GT.1)) GO TO 390
          IM1 = I - 1
          K = N3 + J
          DO 380 L=1,IM1
            W(J,L) = W(J,L) + WS(K-1)*WS(L)
  380     CONTINUE
  390     K = N3 + J
          DO 400 L=I,J
            IL = N3 + L
            W(J,L) = W(J,L) + WS(J)*WS(IL-1) + WS(L)*WS(K-1)
  400     CONTINUE
  410   CONTINUE
  420   CONTINUE
  430 CONTINUE
C
C     COPY LOWER TRI. TO UPPER TRI. TO SYMMETRIZE THE COVARIANCE MATRIX.
C
      DO 440 I = 1,N
        CALL SCOPY(I, W(I,1), MDW, W(1,I), 1)
  440 CONTINUE
C
C     REPERMUTE ROWS AND COLS.
C
  450 DO 470 II = 1,MINMAN
        I = MINMAN + 1 - II
        K = IP(I)
        IF (.NOT.(I.NE.K)) GO TO 470
        CALL SSWAP(1, W(I,I), 1, W(K,K), 1)
        CALL SSWAP(I-1, W(1,I), 1, W(1,K), 1)
        CALL SSWAP(K-I-1, W(I,I+1), MDW, W(I+1,K), 1)
        CALL SSWAP(N-K, W(I,K+1), MDW, W(K,K+1), MDW)
  470 CONTINUE
C
C     PUT IN NORMALIZED RESIDUAL SUM OF SQUARES SCALE FACTOR
C     AND SYMMETRIZE THE RESULTING COVARIANCE MARIX.
C
      DO 480 J = 1,N
        CALL SSCAL(J, FAC, W(1,J), 1)
        CALL SCOPY(J, W(1,J), 1, W(J,1), MDW)
  480 CONTINUE
      GO TO 70
C
C     TO PROCESS-OPTION-VECTOR
C
C     THE NOMINAL TOLERANCE USED IN THE CODE,
  500 TOL = SQRT(SRELPR)
      COV = .FALSE.
      LAST = 1
      LINK = PRGOPT(1)
      KEY8 = 0
      KEY9 = 0
  510    IF (.NOT.(LINK.GT.1)) GO TO 540
         KEY = PRGOPT(LAST+1)
         IF (KEY .EQ. 1) COV = PRGOPT(LAST+2).NE.ZERO
         IF (KEY .EQ. 5) TOL = AMAX1(SRELPR,PRGOPT(LAST+2))
         IF (KEY .NE. 8) GO TO 520
            KEY8 = 1
            EPS = PRGOPT(LAST+2)
            GO TO 530
  520    IF (KEY .NE. 9) GO TO 530
            KEY9 = 1
            BLOWUP = PRGOPT(LAST+2)
  530    NEXT = PRGOPT(LINK)
         LAST = LINK
         LINK = NEXT
         GO TO 510
C
C     PREPARE THE OPTION VECTOR FOR WNNLS
C
  540 J = 1
      IF (KEY8 .EQ. 0) GO TO 550
         OPT(1) = 4.0
         OPT(2) = 8.0
         OPT(3) = EPS
         J = 4
  550 IF (KEY9 .EQ. 0) GO TO 560
         OPT(J) = J + 3
         OPT(J+1) = 9.0
         OPT(J+2) = BLOWUP
         J = J + 3
  560 OPT(J) = 1.0
      GO TO 40
      END
      SUBROUTINE LPDP(A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, IS)
C
C     DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1),
C     WHERE N=N1+N2.  THIS IS A SLIGHT OVERESTIMATE FOR WS(*).
C
C     WRITTEN BY R. J. HANSON AND K. H. HASKELL, SANDIA LABS
C
C     DETERMINE AN N1-VECTOR W, AND
C               AN N2-VECTOR Z
C     WHICH MINIMIZES THE EUCLIDEAN LENGTH OF W
C     SUBJECT TO G*W+H*Z .GE. Y.
C     THIS IS THE LEAST PROJECTED DISTANCE PROBLEM, LPDP.
C     THE MATRICES G AND H ARE OF RESPECTIVE
C     DIMENSIONS M BY N1 AND M BY N2.
C
C     CALLED BY SUBPROGRAM LSI( ).
C
C     THE MATRIX
C                (G H Y)
C
C     OCCUPIES ROWS 1,...,M AND COLS 1,...,N1+N2+1 OF A(*,*).
C
C     THE SOLUTION (W) IS RETURNED IN X(*).
C                  (Z)
C
C     THE VALUE OF MODE INDICATES THE STATUS OF
C     THE COMPUTATION AFTER RETURNING TO THE USER.
C
C          MODE=1  THE SOLUTION WAS SUCCESSFULLY OBTAINED.
C
C          MODE=2  THE INEQUALITIES ARE INCONSISTENT.
C
C     SUBROUTINES CALLED
C
C     WNNLS         SOLVES A NONNEGATIVELY CONSTRAINED LINEAR LEAST
C                   SQUARES PROBLEM WITH LINEAR EQUALITY CONSTRAINTS.
C                   PART OF THIS PACKAGE.
C
C     SDOT,SCOPY    SUBROUTINES FROM THE BLAS PACKAGE.
C     SSCAL,SNRM2   SEE TRANS. MATH SOFTWARE (5), P. 308.
C
      DIMENSION A(MDA,*), PRGOPT(*), X(*), WS(*), IS(*)
      DATA ZERO, ONE /0.E0,1.E0/, FAC /0.1E0/
C
      N = N1 + N2
      MODE = 1
      IF (.NOT.(M.LE.0)) GO TO 20
      IF (.NOT.(N.GT.0)) GO TO 10
      X(1) = ZERO
      CALL SCOPY(N, X, 0, X, 1)
   10 WNORM = ZERO
      RETURN
   20 NP1 = N + 1
C
C     SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE.
C
      DO 40 I = 1,M
         SC = SNRM2(N,A(I,1),MDA)
         IF (SC .EQ. ZERO) GO TO 40
         SC = ONE/SC
         CALL SSCAL(NP1, SC, A(I,1), MDA)
   40 CONTINUE
C
C     SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO).
      YNORM = SNRM2(M,A(1,NP1),1)
      IF (YNORM .EQ. ZERO) GO TO 50
      SC = ONE/YNORM
      CALL SSCAL(M, SC, A(1,NP1), 1)
C
C     SCALE COLS OF MATRIX H.
   50 J = N1 + 1
   60 IF (J .GT. N) GO TO 70
      SC = SNRM2(M,A(1,J),1)
      IF (SC .NE. ZERO) SC = ONE/SC
      CALL SSCAL(M, SC, A(1,J), 1)
      X(J) = SC
      J = J + 1
      GO TO 60
   70 IF (.NOT.(N1.GT.0)) GO TO 130
C
C     COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*).
      IW = 0
      DO 80 I=1,M
C
C     MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY.
         CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1)
         IW = IW + N2
C
C     MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY.
         CALL SCOPY(N1, A(I,1), MDA, WS(IW+1), 1)
         IW = IW + N1
C
C     MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY.
         WS(IW+1) = A(I,NP1)
         IW = IW + 1
   80 CONTINUE
      WS(IW+1) = ZERO
      CALL SCOPY(N, WS(IW+1), 0, WS(IW+1), 1)
      IW = IW + N
      WS(IW+1) = ONE
      IW = IW + 1
C
C     SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0.  THE
C     MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR
C     F = TRANSPOSE OF (0,...,0,1).
      IX = IW + 1
      IW = IW + M
      CALL WNNLS(WS, NP1, N2, NP1-N2, M, 0, PRGOPT, WS(IX), RNORM,
     * MODEW, IS, WS(IW+1))
C
C     COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W.
      SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1)
      IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 110
      SC = ONE/SC
      DO 90 J=1,N1
         X(J) = SC*SDOT(M,A(1,J),1,WS(IX),1)
   90 CONTINUE
C
C     COMPUTE THE VECTOR Q=Y-GW.  OVERWRITE Y WITH THIS VECTOR.
      DO 100 I=1,M
         A(I,NP1) = A(I,NP1) - SDOT(N1,A(I,1),MDA,X,1)
  100 CONTINUE
      GO TO 130
  110 MODE = 2
      RETURN
  130 IF (.NOT.(N2.GT.0)) GO TO 180
C
C     COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*).
      IW = 0
      DO 140 I=1,M
         CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1)
         IW = IW + N2
         WS(IW+1) = A(I,NP1)
         IW = IW + 1
  140 CONTINUE
      WS(IW+1) = ZERO
      CALL SCOPY(N2, WS(IW+1), 0, WS(IW+1), 1)
      IW = IW + N2
      WS(IW+1) = ONE
      IW = IW + 1
      IX = IW + 1
      IW = IW + M
C
C     SOLVE RV=S SUBJECT TO V.GE.0.  THE MATRIX R =(TRANSPOSE
C     OF (H Q)), WHERE Q=Y-GW.  THE (N2+1)-VECTOR S =(TRANSPOSE
C     OF (0,...,0,1)).
C
      CALL WNNLS(WS, N2+1, 0, N2+1, M, 0, PRGOPT, WS(IX), RNORM, MODEW,
     * IS, WS(IW+1))
C
C     COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z.
C
      SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1)
      IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 160
      SC = ONE/SC
      DO 150 J=1,N2
         L = N1 + J
         X(L) = SC*SDOT(M,A(1,L),1,WS(IX),1)*X(L)
  150 CONTINUE
      GO TO 180
  160 MODE = 2
      RETURN
C
C     ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION.
  180 CALL SSCAL(N, YNORM, X, 1)
      WNORM = SNRM2(N1,X,1)
      RETURN
      END
      SUBROUTINE WNNLS(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE,
     * IWORK, WORK)
C
C     DIMENSION W(MDW,N+1),PRGOPT(*),X(N),IWORK(M+N),WORK(M+5*N)
C
C     ABSTRACT
C
C     THIS SUBPROGRAM SOLVES A LINEARLY CONSTRAINED LEAST SQUARES
C     PROBLEM.  SUPPOSE THERE ARE GIVEN MATRICES E AND A OF
C     RESPECTIVE DIMENSIONS ME BY N AND MA BY N, AND VECTORS F
C     AND B OF RESPECTIVE LENGTHS ME AND MA.  THIS SUBROUTINE
C     SOLVES THE PROBLEM
C
C               EX = F, (EQUATIONS TO BE EXACTLY SATISFIED)
C
C               AX = B, (EQUATIONS TO BE APPROXIMATELY SATISFIED,
C                        IN THE LEAST SQUARES SENSE)
C
C               SUBJECT TO COMPONENTS L+1,...,N NONNEGATIVE
C
C     ANY VALUES ME.GE.0, MA.GE.0 AND 0.LE. L .LE.N ARE PERMITTED.
C
C     THE PROBLEM IS REPOSED AS PROBLEM WNNLS
C
C               (WT*E)X = (WT*F)
C               (   A)    (   B), (LEAST SQUARES)
C               SUBJECT TO COMPONENTS L+1,...,N NONNEGATIVE.
C
C     THE SUBPROGRAM CHOOSES THE HEAVY WEIGHT (OR PENALTY PARAMETER) WT.
C
C     THE PARAMETERS FOR WNNLS ARE
C
C     INPUT..
C
C     W(*,*),MDW,  THE ARRAY W(*,*) IS DOUBLE SUBSCRIPTED WITH FIRST
C     ME,MA,N,L    DIMENSIONING PARAMETER EQUAL TO MDW.  FOR THIS
C                  DISCUSSION LET US CALL M = ME + MA.  THEN MDW
C                  MUST SATISFY MDW.GE.M.  THE CONDITION MDW.LT.M
C                  IS AN ERROR.
C
C                  THE ARRAY W(*,*) CONTAINS THE MATRICES AND VECTORS
C
C                       (E  F)
C                       (A  B)
C
C                  IN ROWS AND COLUMNS 1,...,M AND 1,...,N+1
C                  RESPECTIVELY.  COLUMNS 1,...,L CORRESPOND TO
C                  UNCONSTRAINED VARIABLES X(1),...,X(L).  THE
C                  REMAINING VARIABLES ARE CONSTRAINED TO BE
C                  NONNEGATIVE.  THE CONDITION L.LT.0 .OR. L.GT.N IS
C                  AN ERROR.
C
C     PRGOPT(*)    THIS ARRAY IS THE OPTION VECTOR.
C                  IF THE USER IS SATISFIED WITH THE NOMINAL
C                  SUBPROGRAM FEATURES SET
C
C                  PRGOPT(1)=1 (OR PRGOPT(1)=1.0)
C
C                  OTHERWISE PRGOPT(*) IS A LINKED LIST CONSISTING OF
C                  GROUPS OF DATA OF THE FOLLOWING FORM
C
C                  LINK
C                  KEY
C                  DATA SET
C
C                  THE PARAMETERS LINK AND KEY ARE EACH ONE WORD.
C                  THE DATA SET CAN BE COMPRISED OF SEVERAL WORDS.
C                  THE NUMBER OF ITEMS DEPENDS ON THE VALUE OF KEY.
C                  THE VALUE OF LINK POINTS TO THE FIRST
C                  ENTRY OF THE NEXT GROUP OF DATA WITHIN
C                  PRGOPT(*).  THE EXCEPTION IS WHEN THERE ARE
C                  NO MORE OPTIONS TO CHANGE.  IN THAT
C                  CASE LINK=1 AND THE VALUES KEY AND DATA SET
C                  ARE NOT REFERENCED. THE GENERAL LAYOUT OF
C                  PRGOPT(*) IS AS FOLLOWS.
C
C               ...PRGOPT(1)=LINK1 (LINK TO FIRST ENTRY OF NEXT GROUP)
C               .  PRGOPT(2)=KEY1 (KEY TO THE OPTION CHANGE)
C               .  PRGOPT(3)=DATA VALUE (DATA VALUE FOR THIS CHANGE)
C               .       .
C               .       .
C               .       .
C               ...PRGOPT(LINK1)=LINK2 (LINK TO THE FIRST ENTRY OF
C               .                       NEXT GROUP)
C               .  PRGOPT(LINK1+1)=KEY2 (KEY TO THE OPTION CHANGE)
C               .  PRGOPT(LINK1+2)=DATA VALUE
C               ...     .
C               .       .
C               .       .
C               ...PRGOPT(LINK)=1 (NO MORE OPTIONS TO CHANGE)
C
C                  VALUES OF LINK THAT ARE NONPOSITIVE ARE ERRORS.
C                  A VALUE OF LINK.GT.NLINK=100000 IS ALSO AN ERROR.
C                  THIS HELPS PREVENT USING INVALID BUT POSITIVE
C                  VALUES OF LINK THAT WILL PROBABLY EXTEND
C                  BEYOND THE PROGRAM LIMITS OF PRGOPT(*).
C                  UNRECOGNIZED VALUES OF KEY ARE IGNORED.  THE
C                  ORDER OF THE OPTIONS IS ARBITRARY AND ANY NUMBER
C                  OF OPTIONS CAN BE CHANGED WITH THE FOLLOWING
C                  RESTRICTION.  TO PREVENT CYCLING IN THE
C                  PROCESSING OF THE OPTION ARRAY A COUNT OF THE
C                  NUMBER OF OPTIONS CHANGED IS MAINTAINED.
C                  WHENEVER THIS COUNT EXCEEDS NOPT=1000 THE
C                  ROUTINE TERMINATES.
C
C                  OPTIONS..
C
C                  KEY=6
C                         SCALE THE NONZERO COLUMNS OF THE
C                  ENTIRE DATA MATRIX
C                  (E)
C                  (A)
C                  TO HAVE LENGTH ONE.  THE DATA SET FOR
C                  THIS OPTION IS A SINGLE VALUE.  IT MUST
C                  BE NONZERO IF UNIT LENGTH COLUMN SCALING IS
C                  DESIRED.
C
C                  KEY=7
C                         SCALE COLUMNS OF THE ENTIRE DATA MATRIX
C                  (E)
C                  (A)
C                  WITH A USER-PROVIDED DIAGONAL MATRIX.
C                  THE DATA SET FOR THIS OPTION CONSISTS
C                  OF THE N DIAGONAL SCALING FACTORS, ONE FOR
C                  EACH MATRIX COLUMN.
C
C                  KEY=8
C                         CHANGE THE RANK DETERMINATION TOLERANCE FROM
C                  THE NOMINAL VALUE OF SQRT(EPS).  THIS QUANTITY CAN
C                  BE NO SMALLER THAN EPS, THE ARITHMETIC-
C                  STORAGE PRECISION.  THE QUANTITY USED
C                  HERE IS INTERNALLY RESTRICTED TO BE AT
C                  LEAST EPS.  THE DATA SET FOR THIS OPTION
C                  IS THE NEW TOLERANCE.
C
C                  KEY=9
C                         CHANGE THE BLOW-UP PARAMETER FROM THE
C                  NOMINAL VALUE OF SQRT(EPS).  THE RECIPROCAL OF
C                  THIS PARAMETER IS USED IN REJECTING SOLUTION
C                  COMPONENTS AS TOO LARGE WHEN A VARIABLE IS
C                  FIRST BROUGHT INTO THE ACTIVE SET.  TOO LARGE
C                  MEANS THAT THE PROPOSED COMPONENT TIMES THE
C                  RECIPROCAL OF THE PARAMETERIS NOT LESS THAN
C                  THE RATIO OF THE NORMS OF THE RIGHT-SIDE
C                  VECTOR AND THE DATA MATRIX.
C                  THIS PARAMETER CAN BE NO SMALLER THAN EPS,
C                  THE ARITHMETIC-STORAGE PRECISION.
C
C                  FOR EXAMPLE, SUPPOSE WE WANT TO PROVIDE
C                  A DIAGONAL MATRIX TO SCALE THE PROBLEM
C                  MATRIX AND CHANGE THE TOLERANCE USED FOR
C                  DETERMINING LINEAR DEPENDENCE OF DROPPED COL
C                  VECTORS.  FOR THESE OPTIONS THE DIMENSIONS OF
C                  PRGOPT(*) MUST BE AT LEAST N+6.  THE FORTRAN
C                  STATEMENTS DEFINING THESE OPTIONS WOULD
C                  BE AS FOLLOWS.
C
C                  PRGOPT(1)=N+3 (LINK TO ENTRY N+3 IN PRGOPT(*))
C                  PRGOPT(2)=7 (USER-PROVIDED SCALING KEY)
C
C                  CALL SCOPY(N,D,1,PRGOPT(3),1) (COPY THE N
C                  SCALING FACTORS FROM A USER ARRAY CALLED D(*)
C                  INTO PRGOPT(3)-PRGOPT(N+2))
C
C                  PRGOPT(N+3)=N+6 (LINK TO ENTRY N+6 OF PRGOPT(*))
C                  PRGOPT(N+4)=8 (LINEAR DEPENDENCE TOLERANCE KEY)
C                  PRGOPT(N+5)=... (NEW VALUE OF THE TOLERANCE)
C
C                  PRGOPT(N+6)=1 (NO MORE OPTIONS TO CHANGE)
C
C     OUTPUT..
C
C     X(*)         AN ARRAY DIMENSIONED AT LEAST N, WHICH WILL
C                  CONTAIN THE N COMPONENTS OF THE SOLUTION VECTOR
C                  ON OUTPUT.
C
C     RNORM        THE RESIDUAL NORM OF THE SOLUTION.  THE VALUE OF
C                  RNORM CONTAINS THE RESIDUAL VECTOR LENGTH OF THE
C                  EQUALITY CONSTRAINTS AND LEAST SQUARES EQUATIONS.
C
C     MODE         THE VALUE OF MODE INDICATES THE SUCCESS OR FAILURE
C                  OF THE SUBPROGRAM.
C
C                  MODE = 0  SUBPROGRAM COMPLETED SUCCESSFULLY.
C
C                       = 1  MAX. NUMBER OF ITERATIONS (EQUAL TO
C                            3*(N-L)) EXCEEDED. NEARLY ALL PROBLEMS
C                            SHOULD COMPLETE IN FEWER THAN THIS
C                            NUMBER OF ITERATIONS. AN APPROXIMATE
C                            SOLUTION AND ITS CORRESPONDING RESIDUAL
C                            VECTOR LENGTH ARE IN X(*) AND RNORM.
C
C                       = 2  USAGE ERROR OCCURRED.  EITHER
C                            MDW .LT. ME + MA, L .LT. 0, L .GT. N,
C                            OR THE OPTION VECTOR PRGOPT(*) IS
C                            NOT PROPERLY DEFINED.
C
C     USER-DESIGNATED
C     WORKING ARRAYS..
C
C     WORK(*)      A WORKING ARRAY OF LENGTH AT LEAST
C                  M + 5*N.
C
C     IWORK(*)     AN INTEGER-VALUED WORKING ARRAY OF LENGTH AT LEAST
C                  M+N.
C
C     WRITTEN BY KAREN H. HASKELL, SANDIA LABORATORIES,
C     AND R.J. HANSON, SANDIA LABORATORIES.
C     REVISED OCT. 1, 1989.
C
C
C     SUBROUTINES CALLED BY WNNLS( )
C
C     WNLSM         COMPANION SUBROUTINE TO WNNLS( ), WHERE
C                   MOST OF THE COMPUTATION TAKES PLACE.
C
C
C     REFERENCES
C
C     1. SOLVING LEAST SQUARES PROBLEMS, BY C.L. LAWSON
C        AND R.J. HANSON.  PRENTICE-HALL, INC. (1974).
C
C     2. BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE, BY
C        C.L. LAWSON, R.J. HANSON, D.R. KINCAID, AND F.T. KROGH.
C        TOMS, V. 5, NO. 3, P. 308.  ALSO AVAILABLE AS
C        SANDIA TECHNICAL REPORT NO. SAND77-0898.
C
C     3. AN ALGORITHM FOR LINEAR LEAST SQUARES WITH EQUALITY
C        AND NONNEGATIVITY CONSTRAINTS, BY K.H. HASKELL AND
C        R.J. HANSON.  AVAILABLE AS SANDIA TECHNICAL REPORT NO.
C        SAND77-0552, AND MATH. PROGRAMMING, VOL. 21, (1981), P. 98-118.
C
      REAL W(MDW,*), PRGOPT(*), X(N), WORK(*)
      INTEGER IWORK(*)
C
      MODE = 0
      IF (MA+ME .LE. 0 .OR. N .LE. 0) RETURN
      IF (.NOT.(MDW.LT.ME+MA)) GO TO 10
      MODE = 2
      RETURN
   10 IF (0.LE.L .AND. L.LE.N) GO TO 20
      MODE = 2
      RETURN
C
C     THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS
C     WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS
C     REQUIRED BY THE MAIN SUBROUTINE WNLSM( ).
C
   20 L1 = N + 1
      L2 = L1 + N
      L3 = L2 + ME + MA
      L4 = L3 + N
      L5 = L4 + N
C
      CALL WNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK,
     * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), WORK(L4),
     * WORK(L5))
      RETURN
      END
      SUBROUTINE WNLSM(W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE,
     * IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D)
C
C     THIS IS A COMPANION SUBPROGRAM TO WNNLS( ).
C     THE DOCUMENTATION FOR WNNLS( ) HAS MORE COMPLETE
C     USAGE INSTRUCTIONS.
C
C     WRITTEN BY KAREN H. HASKELL, SANDIA LABORATORIES,
C     WITH THE HELP OF R.J. HANSON, SANDIA LABORATORIES.
C
C     IN ADDITION TO THE PARAMETERS DISCUSSED IN THE PROLOGUE TO
C     SUBROUTINE WNNLS, THE FOLLOWING WORK ARRAYS ARE USED IN
C     SUBROUTINE WNLSM  (THEY ARE PASSED THROUGH THE CALLING
C     SEQUENCE FROM WNNLS FOR PURPOSES OF VARIABLE DIMENSIONING).
C     THEIR CONTENTS WILL IN GENERAL BE OF NO INTEREST TO THE USER.
C
C         IPIVOT(*)
C            AN ARRAY OF LENGTH N.  UPON COMPLETION IT CONTAINS THE
C         PIVOTING INFORMATION FOR THE COLS OF W(*,*).
C
C         ITYPE(*)
C            AN ARRAY OF LENGTH M WHICH IS USED TO KEEP TRACK
C         OF THE CLASSIFICATION OF THE EQUATIONS.  ITYPE(I)=0
C         DENOTES EQUATION I AS AN EQUALITY CONSTRAINT.
C         ITYPE(I)=1 DENOTES EQUATION I AS A LEAST SQUARES
C         EQUATION.
C
C         WD(*)
C            AN ARRAY OF LENGTH N.  UPON COMPLETION IT CONTAINS THE
C         DUAL SOLUTION VECTOR.
C
C         H(*)
C            AN ARRAY OF LENGTH N.  UPON COMPLETION IT CONTAINS THE
C         PIVOT SCALARS OF THE HOUSEHOLDER TRANSFORMATIONS PERFORMED
C         IN THE CASE KRANK.LT.L.
C
C         SCALE(*)
C            AN ARRAY OF LENGTH M WHICH IS USED BY THE SUBROUTINE
C         TO STORE THE DIAGONAL MATRIX OF WEIGHTS.
C         THESE ARE USED TO APPLY THE MODIFIED GIVENS
C         TRANSFORMATIONS.
C
C         Z(*),TEMP(*)
C            WORKING ARRAYS OF LENGTH N.
C
C         D(*)
C            AN ARRAY OF LENGTH N THAT CONTAINS THE
C         COLUMN SCALING FOR THE MATRIX (E).
C                                       (A)
C
C
      REAL W(MDW,*), X(*), WD(*), H(*), SCALE(*), DOPE(4)
      REAL Z(*), TEMP(*), PRGOPT(*), D(*), SPARAM(5)
      INTEGER IPIVOT(*), ITYPE(*), IDOPE(8)
      LOGICAL HITCON, FEASBL, DONE, POS
      DATA ZERO /0.E0/, ONE /1.E0/, TWO /2.E0/
C
C     INITIALIZE-VARIABLES
C
      GO TO 180
C
C     PERFORM INITIAL TRIANGULARIZATION IN THE SUBMATRIX
C     CORRESPONDING TO THE UNCONSTRAINED VARIABLES USING
C     THE PROCEDURE INITIALLY-TRIANGULARIZE.
C
   10 GO TO 280
C
C     PERFORM WNNLS ALGORITHM USING THE FOLLOWING STEPS.
C
C     UNTIL(DONE)
C
C        COMPUTE-SEARCH-DIRECTION-AND-FEASIBLE-POINT
C
C        WHEN (HITCON) ADD-CONSTRAINTS
C
C        ELSE PERFORM-MULTIPLIER-TEST-AND-DROP-A-CONSTRAINT
C
C        FIN
C
C     COMPUTE-FINAL-SOLUTION
C
   20 IF (DONE) GO TO 80
      GO TO 300
C
C     COMPUTE-SEARCH-DIRECTION-AND-FEASIBLE-POINT
C
   30 IF (.NOT.(HITCON)) GO TO 50
      GO TO 370
C
C     WHEN (HITCON) ADD-CONSTRAINTS
C
   50 GO TO 640
C
C     ELSE PERFORM-MULTIPLIER-TEST-AND-DROP-A-CONSTRAINT
C
   80 GO TO 1000
C
C     COMPUTE-FINAL-SOLUTION
C
  100 CONTINUE
C
C     TO PROCESS-OPTION-VECTOR
      FAC = 1.E-4
C
C     THE NOMINAL TOLERANCE USED IN THE CODE,
      TAU = SQRT(SRELPR)
C
C     THE NOMINAL BLOW-UP FACTOR USED IN THE CODE.
      BLOWUP = TAU
C
C     THE NOMINAL COLUMN SCALING USED IN THE CODE IS
C     THE IDENTITY SCALING.
      D(1) = ONE
      CALL SCOPY(N, D, 0, D, 1)
C
C     DEFINE BOUND FOR NUMBER OF OPTIONS TO CHANGE.
      NOPT = 1000
C
C     DEFINE BOUND FOR POSITIVE VALUE OF LINK.
      NLINK = 100000
      NTIMES = 0
      LAST = 1
      LINK = PRGOPT(1)
      IF (.NOT.(LINK.LE.0 .OR. LINK.GT.NLINK)) GO TO 110
      MODE = 2
      RETURN
  110 IF (.NOT.(LINK.GT.1)) GO TO 160
      NTIMES = NTIMES + 1
      IF (.NOT.(NTIMES.GT.NOPT)) GO TO 120
      MODE = 2
      RETURN
  120 KEY = PRGOPT(LAST+1)
      IF (.NOT.(KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.ZERO)) GO TO 140
      DO 130 J=1,N
        T = SNRM2(M,W(1,J),1)
        IF (T.NE.ZERO) T = ONE/T
        D(J) = T
  130 CONTINUE
  140 IF (KEY.EQ.7) CALL SCOPY(N, PRGOPT(LAST+2), 1, D, 1)
      IF (KEY.EQ.8) TAU = AMAX1(SRELPR,PRGOPT(LAST+2))
      IF (KEY.EQ.9) BLOWUP = AMAX1(SRELPR,PRGOPT(LAST+2))
      NEXT = PRGOPT(LINK)
      IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.NLINK)) GO TO 150
      MODE = 2
      RETURN
  150 LAST = LINK
      LINK = NEXT
      GO TO 110
  160 DO 170 J=1,N
        CALL SSCAL(M, D(J), W(1,J), 1)
  170 CONTINUE
      GO TO 220
C
C     TO INITIALIZE-VARIABLES
C
C     SRELPR IS THE PRECISION FOR THE MACHINE BEING USED.
C
  180 SRELPR = SPMPAR(1)
C
      M = MA + MME
      ME = MME
      MEP1 = ME + 1
      GO TO 100
C
C     PROCESS-OPTION-VECTOR
  220 DONE = .FALSE.
      ITER = 0
      ITMAX = 3*(N-L)
      MODE = 0
      LP1 = L + 1
      NSOLN = L
      NSP1 = NSOLN + 1
      NP1 = N + 1
      NM1 = N - 1
      L1 = MIN0(M,L)
C
C     COMPUTE SCALE FACTOR TO APPLY TO EQUAL. CONSTRAINT EQUAS.
      DO 230 J=1,N
        WD(J) = SASUM(M,W(1,J),1)
  230 CONTINUE
      IMAX = ISAMAX(N,WD,1)
      EANORM = WD(IMAX)
      BNORM = SASUM(M,W(1,NP1),1)
      ALAMDA = EANORM/(SRELPR*FAC)
C
C     DEFINE SCALING DIAG MATRIX FOR MOD GIVENS USAGE AND
C     CLASSIFY EQUATION TYPES.
      ALSQ = ALAMDA**2
      DO 260 I=1,M
C
C     WHEN EQU I IS HEAVILY WEIGHTED ITYPE(I)=0, ELSE ITYPE(I)=1.
        IF (.NOT.(I.LE.ME)) GO TO 240
        T = ALSQ
        ITEMP = 0
        GO TO 250
  240   T = ONE
        ITEMP = 1
  250   SCALE(I) = T
        ITYPE(I) = ITEMP
  260 CONTINUE
C
C     SET THE SOLN VECTOR X(*) TO ZERO AND THE COL INTERCHANGE
C     MATRIX TO THE IDENTITY.
      X(1) = ZERO
      CALL SCOPY(N, X, 0, X, 1)
      DO 270 I=1,N
        IPIVOT(I) = I
  270 CONTINUE
      GO TO 10
  280 CONTINUE
C
C     TO INITIALLY-TRIANGULARIZE
C
C     SET FIRST L COMPS. OF DUAL VECTOR TO ZERO BECAUSE
C     THESE CORRESPOND TO THE UNCONSTRAINED VARIABLES.
      IF (.NOT.(L.GT.0)) GO TO 290
      WD(1) = ZERO
      CALL SCOPY(L, WD, 0, WD, 1)
C
C     THE ARRAYS IDOPE(*) AND DOPE(*) ARE USED TO PASS
C     INFORMATION TO WNLIT().  THIS WAS DONE TO AVOID
C     A LONG CALLING SEQUENCE OR THE USE OF COMMON.
  290 IDOPE(1) = ME
      IDOPE(2) = MEP1
      IDOPE(3) = 0
      IDOPE(4) = 1
      IDOPE(5) = NSOLN
      IDOPE(6) = 0
      IDOPE(7) = 1
      IDOPE(8) = L1
C
      DOPE(1) = ALSQ
      DOPE(2) = EANORM
      DOPE(3) = FAC
      DOPE(4) = TAU
      CALL WNLIT(W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM,
     * IDOPE, DOPE, DONE)
      ME = IDOPE(1)
      MEP1 = IDOPE(2)
      KRANK = IDOPE(3)
      KRP1 = IDOPE(4)
      NSOLN = IDOPE(5)
      NIV = IDOPE(6)
      NIV1 = IDOPE(7)
      L1 = IDOPE(8)
      GO TO 20
  300 CONTINUE
C
C     TO COMPUTE-SEARCH-DIRECTION-AND-FEASIBLE-POINT
C
C     SOLVE THE TRIANGULAR SYSTEM OF CURRENTLY NON-ACTIVE
C     VARIABLES AND STORE THE SOLUTION IN Z(*).
C
C     SOLVE-SYSTEM
      ASSIGN 310 TO IGO958
      GO TO 1110
C
C     INCREMENT ITERATION COUNTER AND CHECK AGAINST MAX. NUMBER
C     OF ITERATIONS.
  310 ITER = ITER + 1
      IF (.NOT.(ITER.GT.ITMAX)) GO TO 320
      MODE = 1
      DONE = .TRUE.
C
C     CHECK TO SEE IF ANY CONSTRAINTS HAVE BECOME ACTIVE.
C     IF SO, CALCULATE AN INTERPOLATION FACTOR SO THAT ALL
C     ACTIVE CONSTRAINTS ARE REMOVED FROM THE BASIS.
  320 ALPHA = TWO
      HITCON = .FALSE.
      IF (.NOT.(L.LT.NSOLN)) GO TO 360
      DO 350 J=LP1,NSOLN
        ZZ = Z(J)
        IF (.NOT.(ZZ.LE.ZERO)) GO TO 350
        T = X(J)/(X(J)-ZZ)
        IF (.NOT.(T.LT.ALPHA)) GO TO 330
        ALPHA = T
        JCON = J
  330   HITCON = .TRUE.
  350 CONTINUE
  360 GO TO 30
  370 CONTINUE
C
C     TO ADD-CONSTRAINTS
C
C     USE COMPUTED ALPHA TO INTERPOLATE BETWEEN LAST
C     FEASIBLE SOLUTION X(*) AND CURRENT UNCONSTRAINED
C     (AND INFEASIBLE) SOLUTION Z(*).
      IF (.NOT.(LP1.LE.NSOLN)) GO TO 390
      DO 380 J=LP1,NSOLN
        X(J) = X(J) + ALPHA*(Z(J)-X(J))
  380 CONTINUE
  390 FEASBL = .FALSE.
      GO TO 410
  400 IF (FEASBL) GO TO 20
C
C     REMOVE COL JCON AND SHIFT COLS JCON+1 THROUGH N TO THE
C     LEFT. SWAP COL JCON INTO THE N-TH POSITION.  THIS ACHIEVES
C     UPPER HESSENBERG FORM FOR THE NONACTIVE CONSTRAINTS AND
C     LEAVES AN UPPER HESSENBERG MATRIX TO RETRIANGULARIZE.
  410 DO 420 I=1,M
        T = W(I,JCON)
        CALL SCOPY(N-JCON, W(I,JCON+1), MDW, W(I,JCON), MDW)
        W(I,N) = T
  420 CONTINUE
C
C     UPDATE PERMUTED INDEX VECTOR TO REFLECT THIS SHIFT AND SWAP.
      ITEMP = IPIVOT(JCON)
      IF (.NOT.(JCON.LT.N)) GO TO 440
      DO 430 I=JCON,NM1
        IPIVOT(I) = IPIVOT(I+1)
  430 CONTINUE
  440 IPIVOT(N) = ITEMP
C
C     SIMILARLY REPERMUTE X(*) VECTOR.
      CALL SCOPY(N-JCON, X(JCON+1), 1, X(JCON), 1)
      X(N) = ZERO
      NSP1 = NSOLN
      NSOLN = NSOLN - 1
      NIV1 = NIV
      NIV = NIV - 1
C
C     RETRIANGULARIZE UPPER HESSENBERG MATRIX AFTER ADDING CONSTRAINTS.
      J = JCON
      I = KRANK + JCON - L
  450 IF (.NOT.(J.LE.NSOLN)) GO TO 570
      IF (.NOT.(ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0)) GO TO 470
      ASSIGN 460 TO IGO938
      GO TO 620
C
C     (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) ZERO-IP1-TO-I-IN-COL-J
  460 GO TO 560
  470 IF (.NOT.(ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1)) GO TO 490
      ASSIGN 480 TO IGO938
      GO TO 620
C
C     (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) ZERO-IP1-TO-I-IN-COL-J
  480 GO TO 560
  490 IF (.NOT.(ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0)) GO TO 510
      CALL SSWAP(NP1, W(I,1), MDW, W(I+1,1), MDW)
      CALL SSWAP(1, SCALE(I), 1, SCALE(I+1), 1)
      ITEMP = ITYPE(I+1)
      ITYPE(I+1) = ITYPE(I)
      ITYPE(I) = ITEMP
C
C     SWAPPED ROW WAS FORMERLY A PIVOT ELT., SO IT WILL
C     BE LARGE ENOUGH TO PERFORM ELIM.
      ASSIGN 500 TO IGO938
      GO TO 620
C
C     ZERO-IP1-TO-I-IN-COL-J
  500 GO TO 560
  510 IF (.NOT.(ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1)) GO TO 550
      T = SCALE(I)*W(I,J)**2/ALSQ
      IF (.NOT.(T.GT.TAU**2*EANORM**2)) GO TO 530
      ASSIGN 520 TO IGO938
      GO TO 620
  520 GO TO 540
  530 CALL SSWAP(NP1, W(I,1), MDW, W(I+1,1), MDW)
      CALL SSWAP(1, SCALE(I), 1, SCALE(I+1), 1)
      ITEMP = ITYPE(I+1)
      ITYPE(I+1) = ITYPE(I)
      ITYPE(I) = ITEMP
      W(I+1,J) = ZERO
  540 CONTINUE
  550 CONTINUE
  560 I = I + 1
      J = J + 1
      GO TO 450
C
C     SEE IF THE REMAINING COEFFS IN THE SOLN SET ARE FEASIBLE.  THEY
C     SHOULD BE BECAUSE OF THE WAY ALPHA WAS DETERMINED.  IF ANY ARE
C     INFEASIBLE IT IS DUE TO ROUNDOFF ERROR.  ANY THAT ARE NON-
C     POSITIVE WILL BE SET TO ZERO AND REMOVED FROM THE SOLN SET.
  570 IF (.NOT.(LP1.LE.NSOLN)) GO TO 590
      DO 580 JCON=LP1,NSOLN
        IF (X(JCON).LE.ZERO) GO TO 600
  580 CONTINUE
  590 FEASBL = .TRUE.
  600 CONTINUE
      GO TO 400
  620 CONTINUE
C
C     TO ZERO-IP1-TO-I-IN-COL-J
      IF (.NOT.(W(I+1,J).NE.ZERO)) GO TO 630
      CALL SROTMG(SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), SPARAM)
      W(I+1,J) = ZERO
      CALL SROTM(NP1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, SPARAM)
  630 GO TO 1290
C
C     TO PERFORM-MULTIPLIER-TEST-AND-DROP-A-CONSTRAINT
C
  640 CALL SCOPY(NSOLN, Z, 1, X, 1)
      IF (.NOT.(NSOLN.LT.N)) GO TO 650
      X(NSP1) = ZERO
      CALL SCOPY(N-NSOLN, X(NSP1), 0, X(NSP1), 1)
  650 I = NIV1
  660 IF (.NOT.(I.LE.ME)) GO TO 690
C
C     RECLASSIFY LEAST SQUARES EQATIONS AS EQUALITIES AS
C     NECESSARY.
      IF (.NOT.(ITYPE(I).EQ.0)) GO TO 670
      I = I + 1
      GO TO 680
  670 CALL SSWAP(NP1, W(I,1), MDW, W(ME,1), MDW)
      CALL SSWAP(1, SCALE(I), 1, SCALE(ME), 1)
      ITEMP = ITYPE(I)
      ITYPE(I) = ITYPE(ME)
      ITYPE(ME) = ITEMP
      MEP1 = ME
      ME = ME - 1
  680 GO TO 660
C
C     FORM INNER PRODUCT VECTOR WD(*) OF DUAL COEFFS.
  690 IF (.NOT.(NSP1.LE.N)) GO TO 730
      DO 720 J=NSP1,N
        SM = ZERO
        IF (.NOT.(NSOLN.LT.M)) GO TO 710
        DO 700 I=NSP1,M
          SM = SM + SCALE(I)*W(I,J)*W(I,NP1)
  700   CONTINUE
  710   WD(J) = SM
  720 CONTINUE
  730 GO TO 750
  740 IF (POS .OR. DONE) GO TO 970
C
C     FIND J SUCH THAT WD(J)=WMAX IS MAXIMUM.  THIS DETERMINES
C     THAT THE INCOMING COL J WILL REDUCE THE RESIDUAL VECTOR
C     AND BE POSITIVE.
  750 WMAX = ZERO
      IWMAX = NSP1
      IF (.NOT.(NSP1.LE.N)) GO TO 780
      DO 770 J=NSP1,N
        IF (.NOT.(WD(J).GT.WMAX)) GO TO 760
        WMAX = WD(J)
        IWMAX = J
  760   CONTINUE
  770 CONTINUE
  780 IF (.NOT.(WMAX.LE.ZERO)) GO TO 790
      DONE = .TRUE.
      GO TO 960
C
C     SET DUAL COEFF TO ZERO FOR INCOMING COL.
  790 WD(IWMAX) = ZERO
C
C     WMAX .GT. ZERO, SO OKAY TO MOVE COL IWMAX TO SOLN SET.
C     PERFORM TRANSFORMATION TO RETRIANGULARIZE, AND TEST
C     FOR NEAR LINEAR DEPENDENCE.
C     SWAP COL IWMAX INTO NSOLN-TH POSITION TO MAINTAIN UPPER
C     HESSENBERG FORM OF ADJACENT COLS, AND ADD NEW COL TO
C     TRIANGULAR DECOMPOSITION.
      NSOLN = NSP1
      NSP1 = NSOLN + 1
      NIV = NIV1
      NIV1 = NIV + 1
      IF (.NOT.(NSOLN.NE.IWMAX)) GO TO 800
      CALL SSWAP(M, W(1,NSOLN), 1, W(1,IWMAX), 1)
      WD(IWMAX) = WD(NSOLN)
      WD(NSOLN) = ZERO
      ITEMP = IPIVOT(NSOLN)
      IPIVOT(NSOLN) = IPIVOT(IWMAX)
      IPIVOT(IWMAX) = ITEMP
C
C     REDUCE COL NSOLN SO THAT THE MATRIX OF NONACTIVE
C     CONSTRAINTS VARIABLES IS TRIANGULAR.
  800 J = M
  810 IF (.NOT.(J.GT.NIV)) GO TO 870
      JM1 = J - 1
      JP = JM1
C
C     WHEN OPERATING NEAR THE ME LINE, TEST TO SEE IF THE PIVOT ELT.
C     IS NEAR ZERO.  IF SO, USE THE LARGEST ELT. ABOVE IT AS THE PIVOT.
C     THIS IS TO MAINTAIN THE SHARP INTERFACE BETWEEN WEIGHTED AND
C     NON-WEIGHTED ROWS IN ALL CASES.
      IF (.NOT.(J.EQ.MEP1)) GO TO 850
      IMAX = ME
      AMAX = SCALE(ME)*W(ME,NSOLN)**2
  820 IF (.NOT.(JP.GE.NIV)) GO TO 840
      T = SCALE(JP)*W(JP,NSOLN)**2
      IF (.NOT.(T.GT.AMAX)) GO TO 830
      IMAX = JP
      AMAX = T
  830 JP = JP - 1
      GO TO 820
  840 JP = IMAX
  850 IF (.NOT.(W(J,NSOLN).NE.ZERO)) GO TO 860
      CALL SROTMG(SCALE(JP), SCALE(J), W(JP,NSOLN), W(J,NSOLN), SPARAM)
      W(J,NSOLN) = ZERO
      CALL SROTM(NP1-NSOLN, W(JP,NSP1), MDW, W(J,NSP1), MDW, SPARAM)
  860 J = JM1
      GO TO 810
C
C     SOLVE FOR Z(NSOLN)=PROPOSED NEW VALUE FOR X(NSOLN).
C     TEST IF THIS IS NONPOSITIVE OR TOO LARGE.
C     IF THIS WAS TRUE OR IF THE PIVOT TERM WAS ZERO REJECT
C     THE COL AS DEPENDENT.
  870 IF (.NOT.(W(NIV,NSOLN).NE.ZERO)) GO TO 890
      ISOL = NIV
      ASSIGN 880 TO IGO897
      GO TO 980
C
C     TEST-PROPOSED-NEW-COMPONENT
  880 GO TO 940
  890 IF (.NOT.(NIV.LE.ME .AND. W(MEP1,NSOLN).NE.ZERO)) GO TO 920
C
C     TRY TO ADD ROW MEP1 AS AN ADDITIONAL EQUALITY CONSTRAINT.
C     CHECK SIZE OF PROPOSED NEW SOLN COMPONENT.
C     REJECT IT IF IT IS TOO LARGE.
      ISOL = MEP1
      ASSIGN 900 TO IGO897
      GO TO 980
C
C     TEST-PROPOSED-NEW-COMPONENT
  900 IF (.NOT.(POS)) GO TO 910
C
C     SWAP ROWS MEP1 AND NIV, AND SCALE FACTORS FOR THESE ROWS.
      CALL SSWAP(NP1, W(MEP1,1), MDW, W(NIV,1), MDW)
      CALL SSWAP(1, SCALE(MEP1), 1, SCALE(NIV), 1)
      ITEMP = ITYPE(MEP1)
      ITYPE(MEP1) = ITYPE(NIV)
      ITYPE(NIV) = ITEMP
      ME = MEP1
      MEP1 = ME + 1
  910 GO TO 930
  920 POS = .FALSE.
  930 CONTINUE
  940 IF (POS) GO TO 950
      NSP1 = NSOLN
      NSOLN = NSOLN - 1
      NIV1 = NIV
      NIV = NIV - 1
  950 CONTINUE
  960 GO TO 740
  970 GO TO 20
  980 CONTINUE
C
C     TO TEST-PROPOSED-NEW-COMPONENT
      Z2 = W(ISOL,NP1)/W(ISOL,NSOLN)
      Z(NSOLN) = Z2
      POS = Z2.GT.ZERO
      IF (.NOT.(Z2*EANORM.GE.BNORM .AND. POS)) GO TO 990
      POS = .NOT.(BLOWUP*Z2*EANORM.GE.BNORM)
  990 GO TO 1280
 1000 CONTINUE
C     TO COMPUTE-FINAL-SOLUTION
C
C     SOLVE SYSTEM, STORE RESULTS IN X(*).
C
      ASSIGN 1010 TO IGO958
      GO TO 1110
C     SOLVE-SYSTEM
 1010 CALL SCOPY(NSOLN, Z, 1, X, 1)
C
C     APPLY HOUSEHOLDER TRANSFORMATIONS TO X(*) IF KRANK.LT.L
      IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.L)) GO TO 1030
      DO 1020 I=1,KRANK
        CALL H12(2, I, KRP1, L, W(I,1), MDW, H(I), X, 1, 1, 1)
 1020 CONTINUE
C
C     FILL IN TRAILING ZEROES FOR CONSTRAINED VARIABLES NOT IN SOLN.
 1030 IF (.NOT.(NSOLN.LT.N)) GO TO 1040
      X(NSP1) = ZERO
      CALL SCOPY(N-NSOLN, X(NSP1), 0, X(NSP1), 1)
C
C     REPERMUTE SOLN VECTOR TO NATURAL ORDER.
 1040 DO 1070 I=1,N
        J = I
 1050   IF (IPIVOT(J).EQ.I) GO TO 1060
        J = J + 1
        GO TO 1050
 1060   IPIVOT(J) = IPIVOT(I)
        IPIVOT(I) = J
        CALL SSWAP(1, X(J), 1, X(I), 1)
 1070 CONTINUE
C
C     RESCALE THE SOLN USING THE COL SCALING.
      DO 1080 J=1,N
        X(J) = X(J)*D(J)
 1080 CONTINUE
      IF (.NOT.(NIV.LT.M)) GO TO 1100
      DO 1090 I=NIV1,M
        T = W(I,NP1)
        IF (I.LE.ME) T = T/ALAMDA
        T = (SCALE(I)*T)*T
        RNORM = RNORM + T
 1090 CONTINUE
 1100 RNORM = SQRT(RNORM)
      RETURN
C
C     TO SOLVE-SYSTEM
C
 1110 CONTINUE
      IF (.NOT.(DONE)) GO TO 1120
      ISOL = 1
      GO TO 1130
 1120 ISOL = LP1
 1130 IF (.NOT.(NSOLN.GE.ISOL)) GO TO 1270
C
C     COPY RT. HAND SIDE INTO TEMP VECTOR TO USE OVERWRITING METHOD.
      CALL SCOPY(NIV, W(1,NP1), 1, TEMP, 1)
      DO 1180 JJ=ISOL,NSOLN
        J = NSOLN - JJ + ISOL
        IF (.NOT.(J.GT.KRANK)) GO TO 1140
        I = NIV - JJ + ISOL
        GO TO 1150
 1140   I = J
 1150   IF (.NOT.(J.GT.KRANK .AND. J.LE.L)) GO TO 1160
        Z(J) = ZERO
        GO TO 1170
 1160   Z(J) = TEMP(I)/W(I,J)
        CALL SAXPY(I-1, -Z(J), W(1,J), 1, TEMP, 1)
 1170   CONTINUE
 1180 CONTINUE
C
 1270 GO TO IGO958, (310, 1010)
 1280 GO TO IGO897, (880, 900)
 1290 GO TO IGO938, (460, 480, 500, 520)
      END
      SUBROUTINE WNLIT(W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM,
     * IDOPE, DOPE, DONE)
C
C     THIS IS A COMPANION SUBPROGRAM TO WNNLS( ).
C     THE DOCUMENTATION FOR WNNLS( ) HAS MORE COMPLETE
C     USAGE INSTRUCTIONS.
C
C     NOTE  THE M BY (N+1) MATRIX W( , ) CONTAINS THE RT. HAND SIDE
C           B AS THE (N+1)ST COL.
C
C
C     TRIANGULARIZE L1 BY L1 SUBSYSTEM, WHERE L1=MIN(M,L), WITH
C     COL INTERCHANGES.
C     REVISED OCT. 1, 1989
C
      REAL W(MDW,*), H(*), SCALE(*), DOPE(*), SPARAM(5)
      INTEGER ITYPE(*), IPIVOT(*), IDOPE(*)
      INTEGER ISAMAX
      LOGICAL INDEP, DONE, RECALC
      DATA TENM3 /1.E-3/, ZERO /0.E0/, ONE /1.E0/
C
      ME = IDOPE(1)
      MEP1 = IDOPE(2)
      KRANK = IDOPE(3)
      KRP1 = IDOPE(4)
      NSOLN = IDOPE(5)
      NIV = IDOPE(6)
      NIV1 = IDOPE(7)
      L1 = IDOPE(8)
C
      ALSQ = DOPE(1)
      EANORM = DOPE(2)
      FAC = DOPE(3)
      TAU = DOPE(4)
      NP1 = N + 1
      LB = MIN0(M-1,L)
      RECALC = .TRUE.
      RNORM = ZERO
      KRANK = 0
C     WE SET FACTOR=1.E0 SO THAT THE HEAVY WEIGHT ALAMDA WILL BE
C     INCLUDED IN THE TEST FOR COL INDEPENDENCE.
      FACTOR = 1.E0
      I = 1
      IP1 = 2
      LEND = L
   10 IF (.NOT.(I.LE.LB)) GO TO 150
      IF (.NOT.(I.LE.ME)) GO TO 130
C
C     SET IR TO POINT TO THE I-TH ROW.
      IR = I
      MEND = M
      ASSIGN 20 TO IGO996
      GO TO 460
C
C     UPDATE-COL-SS-AND-FIND-PIVOT-COL
   20 ASSIGN 30 TO IGO993
      GO TO 560
C
C     PERFORM-COL-INTERCHANGE
C
C     SET IC TO POINT TO I-TH COL.
   30 IC = I
      ASSIGN 40 TO IGO990
      GO TO 520
C
C     TEST-INDEP-OF-INCOMING-COL
   40 IF (.NOT.(INDEP)) GO TO 110
C
C     ELIMINATE I-TH COL BELOW DIAG. USING MOD. GIVENS TRANSFORMATIONS
C     APPLIED TO (A B).
      J = M
      DO 100 JJ=IP1,M
        JM1 = J - 1
        JP = JM1
        IF (.NOT.(JJ.EQ.M)) GO TO 70
        IF (.NOT.(I.LT.MEP1)) GO TO 80
        J = MEP1
        JP = I
        T = SCALE(JP)*W(JP,I)**2*TAU**2
        IF (.NOT.(T.GT.SCALE(J)*W(J,I)**2)) GO TO 130
        GO TO 80
   70   IF (.NOT.(J.EQ.MEP1)) GO TO 80
        J = JM1
        JM1 = J - 1
        JP = JM1
   80   IF (.NOT.(W(J,I).NE.ZERO)) GO TO 90
        CALL SROTMG(SCALE(JP), SCALE(J), W(JP,I), W(J,I), SPARAM)
        W(J,I) = ZERO
        CALL SROTM(NP1-I, W(JP,IP1), MDW, W(J,IP1), MDW, SPARAM)
   90   J = JM1
  100 CONTINUE
      GO TO 140
  110 CONTINUE
      IF (.NOT.(LEND.GT.I)) GO TO 130
C
C     COL I IS DEPENDENT. SWAP WITH COL LEND.
      MAX = LEND
C
C     PERFORM-COL-INTERCHANGE
      ASSIGN 120 TO IGO993
      GO TO 560
  120 CONTINUE
      LEND = LEND - 1
C
C     FIND COL IN REMAINING SET WITH LARGEST SS.
      MAX = ISAMAX(LEND-I+1,H(I),1) + I - 1
      HBAR = H(MAX)
      GO TO 30
  130 CONTINUE
      KRANK = I - 1
      GO TO 160
  140 I = IP1
      IP1 = IP1 + 1
      GO TO 10
  150 KRANK = L1
  160 CONTINUE
      KRP1 = KRANK + 1
      IF (.NOT.(KRANK.LT.ME)) GO TO 290
      FACTOR = ALSQ
      DO 170 I=KRP1,ME
        IF (L.GT.0) W(I,1) = ZERO
        CALL SCOPY(L, W(I,1), 0, W(I,1), MDW)
  170 CONTINUE
C
C     DETERMINE THE RANK OF THE REMAINING EQUALITY CONSTRAINT
C     EQUATIONS BY ELIMINATING WITHIN THE BLOCK OF CONSTRAINED
C     VARIABLES.  REMOVE ANY REDUNDANT CONSTRAINTS.
C
      IR = KRP1
      IF (.NOT.(L.LT.N)) GO TO 245
      LP1 = L + 1
      RECALC = .TRUE.
      LB = MIN0(L+ME-KRANK,N)
      I = LP1
      IP1 = I + 1
  180 IF (.NOT.(I.LE.LB)) GO TO 280
      IR = KRANK + I - L
      LEND = N
      MEND = ME
      ASSIGN 190 TO IGO996
      GO TO 460
C
C     UPDATE-COL-SS-AND-FIND-PIVOT-COL
  190 ASSIGN 200 TO IGO993
      GO TO 560
C
C     PERFORM-COL-INTERCHANGE
C
C     ELIMINATE ELEMENTS IN THE I-TH COL.
  200 J = ME
  210 IF (.NOT.(J.GT.IR)) GO TO 230
      JM1 = J - 1
      IF (.NOT.(W(J,I).NE.ZERO)) GO TO 220
      CALL SROTMG(SCALE(JM1), SCALE(J), W(JM1,I), W(J,I), SPARAM)
      W(J,I) = ZERO
      CALL SROTM(NP1-I, W(JM1,IP1), MDW, W(J,IP1), MDW, SPARAM)
  220 J = JM1
      GO TO 210
C
C     SET IC=I=COL BEING ELIMINATED
  230 IC = I
      ASSIGN 240 TO IGO990
      GO TO 520
C
C     TEST-INDEP-OF-INCOMING-COL
  240 IF (INDEP) GO TO 270
C
C     REMOVE ANY REDUNDANT OR DEPENDENT EQUALITY CONSTRAINTS.
  245 CONTINUE
      JJ = IR
  250 IF (.NOT.(IR.LE.ME)) GO TO 260
      W(IR,1) = ZERO
      CALL SCOPY(N, W(IR,1), 0, W(IR,1), MDW)
      RNORM = RNORM + (SCALE(IR)*W(IR,NP1)/ALSQ)*W(IR,NP1)
      W(IR,NP1) = ZERO
      SCALE(IR) = ONE
C     RECLASSIFY THE ZEROED ROW AS A LEAST SQUARES EQUATION.
      ITYPE(IR) = 1
      IR = IR + 1
      GO TO 250
C
C     REDUCE ME TO REFLECT ANY DISCOVERED DEPENDENT EQUALITY
C     CONSTRAINTS.
  260 CONTINUE
      ME = JJ - 1
      MEP1 = ME + 1
      GO TO 300
  270 I = IP1
      IP1 = IP1 + 1
      GO TO 180
  280 CONTINUE
  290 CONTINUE
  300 CONTINUE
      IF (.NOT.(KRANK.LT.L1)) GO TO 420
C
C     TRY TO DETERMINE THE VARIABLES KRANK+1 THROUGH L1 FROM THE
C     LEAST SQUARES EQUATIONS.  CONTINUE THE TRIANGULARIZATION WITH
C     PIVOT ELEMENT W(MEP1,I).
C
      RECALC = .TRUE.
C
C     SET FACTOR=ALSQ TO REMOVE EFFECT OF HEAVY WEIGHT FROM
C     TEST FOR COL INDEPENDENCE.
      FACTOR = ALSQ
      KK = KRP1
      I = KK
      IP1 = I + 1
  310 IF (.NOT.(I.LE.L1)) GO TO 410
C
C     SET IR TO POINT TO THE MEP1-ST ROW.
      IR = MEP1
      LEND = L
      MEND = M
      ASSIGN 320 TO IGO996
      GO TO 460
C
C     UPDATE-COL-SS-AND-FIND-PIVOT-COL
  320 ASSIGN 330 TO IGO993
      GO TO 560
C
C     PERFORM-COL-INTERCHANGE
C
C     ELIMINATE I-TH COL BELOW THE IR-TH ELEMENT.
  330 IRP1 = IR + 1
      IF (.NOT.(IRP1.LE.M)) GO TO 355
      J = M
      DO 350 JJ=IRP1,M
        JM1 = J - 1
        IF (.NOT.(W(J,I).NE.ZERO)) GO TO 340
        CALL SROTMG(SCALE(JM1), SCALE(J), W(JM1,I), W(J,I), SPARAM)
        W(J,I) = ZERO
        CALL SROTM(NP1-I, W(JM1,IP1), MDW, W(J,IP1), MDW, SPARAM)
  340   J = JM1
  350 CONTINUE
  355 CONTINUE
C
C     TEST IF NEW PIVOT ELEMENT IS NEAR ZERO. IF SO, THE COL IS
C     DEPENDENT.
      T = SCALE(IR)*W(IR,I)**2
      INDEP = T.GT.TAU**2*EANORM**2
      IF (.NOT.INDEP) GO TO 380
C
C     COL TEST PASSED. NOW MUST PASS ROW NORM TEST TO BE CLASSIFIED
C     AS INDEPENDENT.
      RN = ZERO
      DO 370 I1=IR,M
        DO 360 J1=IP1,N
          RN = AMAX1(RN,SCALE(I1)*W(I1,J1)**2)
  360   CONTINUE
  370 CONTINUE
      INDEP = T.GT.TAU**2*RN
C
C     IF INDEPENDENT, SWAP THE IR-TH AND KRP1-ST ROWS TO MAINTAIN THE
C     TRIANGULAR FORM.  UPDATE THE RANK INDICATOR KRANK AND THE
C     EQUALITY CONSTRAINT POINTER ME.
  380 IF (.NOT.(INDEP)) GO TO 390
      CALL SSWAP(NP1, W(KRP1,1), MDW, W(IR,1), MDW)
      CALL SSWAP(1, SCALE(KRP1), 1, SCALE(IR), 1)
C     RECLASSIFY THE LEAST SQ. EQUATION AS AN EQUALITY CONSTRAINT AND
C     RESCALE IT.
      ITYPE(IR) = 0
      T = SQRT(SCALE(KRP1))
      CALL SSCAL(NP1, T, W(KRP1,1), MDW)
      SCALE(KRP1) = ALSQ
      ME = MEP1
      MEP1 = ME + 1
      KRANK = KRP1
      KRP1 = KRANK + 1
      GO TO 400
  390 GO TO 430
  400 I = IP1
      IP1 = IP1 + 1
      GO TO 310
  410 CONTINUE
  420 CONTINUE
  430 CONTINUE
C
C     IF PSEUDORANK IS LESS THAN L, APPLY HOUSEHOLDER TRANS.
C     FROM RIGHT.
      IF (.NOT.(KRANK.LT.L)) GO TO 450
      DO 440 I=1,KRANK
        J = KRP1 - I
        CALL H12(1, J, KRP1, L, W(J,1), MDW, H(J), W, MDW, 1, J-1)
  440 CONTINUE
  450 NIV = KRANK + NSOLN - L
      NIV1 = NIV + 1
      IF (L.EQ.N) DONE = .TRUE.
C
C  END OF INITIAL TRIANGULARIZATION.
      IDOPE(1) = ME
      IDOPE(2) = MEP1
      IDOPE(3) = KRANK
      IDOPE(4) = KRP1
      IDOPE(5) = NSOLN
      IDOPE(6) = NIV
      IDOPE(7) = NIV1
      IDOPE(8) = L1
      RETURN
  460 CONTINUE
C
C     TO UPDATE-COL-SS-AND-FIND-PIVOT-COL
C
C     THE COL SS VECTOR WILL BE UPDATED AT EACH STEP. WHEN
C     NUMERICALLY NECESSARY, THESE VALUES WILL BE RECOMPUTED.
C
      IF (.NOT.(IR.NE.1 .AND. (.NOT.RECALC))) GO TO 480
C     UPDATE COL SS =SUM OF SQUARES.
      DO 470 J=I,LEND
        H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2
  470 CONTINUE
C
C     TEST FOR NUMERICAL ACCURACY.
      MAX = ISAMAX(LEND-I+1,H(I),1) + I - 1
      RECALC = HBAR + TENM3*H(MAX).EQ.HBAR
C
C     IF REQUIRED, RECALCULATE COL SS, USING ROWS IR THROUGH MEND.
  480 IF (.NOT.(RECALC)) GO TO 510
      DO 500 J=I,LEND
        H(J) = ZERO
        DO 490 K=IR,MEND
          H(J) = H(J) + SCALE(K)*W(K,J)**2
  490   CONTINUE
  500 CONTINUE
C
C     FIND COL WITH LARGEST SS.
      MAX = ISAMAX(LEND-I+1,H(I),1) + I - 1
      HBAR = H(MAX)
  510 GO TO 600
  520 CONTINUE
C
C     TO TEST-INDEP-OF-INCOMING-COL
C
C     TEST THE COL IC TO DETERMINE IF IT IS LINEARLY INDEPENDENT
C     OF THE COLS ALREADY IN THE BASIS.  IN THE INIT TRI
C     STEP, WE USUALLY WANT THE HEAVY WEIGHT ALAMDA TO
C     BE INCLUDED IN THE TEST FOR INDEPENDENCE.  IN THIS CASE THE
C     VALUE OF FACTOR WILL HAVE BEEN SET TO 1.E0 BEFORE THIS
C     PROCEDURE IS INVOKED.  IN THE POTENTIALLY RANK DEFICIENT
C     PROBLEM, THE VALUE OF FACTOR WILL HAVE BEEN
C     SET TO ALSQ=ALAMDA**2 TO REMOVE THE EFFECT OF THE HEAVY WEIGHT
C     FROM THE TEST FOR INDEPENDENCE.
C
C     WRITE NEW COL AS PARTITIONED VECTOR
C             (A1)  NUMBER OF COMPONENTS IN SOLN SO FAR = NIV
C             (A2)  M-NIV COMPONENTS
C     AND COMPUTE  SN = INVERSE WEIGHTED LENGTH OF A1
C                  RN = INVERSE WEIGHTED LENGTH OF A2
C     CALL THE COL INDEPENDENT WHEN RN .GT. TAU*SN
      SN = ZERO
      RN = ZERO
      DO 550 J=1,MEND
        T = SCALE(J)
        IF (J.LE.ME) T = T/FACTOR
        T = T*W(J,IC)**2
        IF (.NOT.(J.LT.IR)) GO TO 530
        SN = SN + T
        GO TO 540
  530   RN = RN + T
  540   CONTINUE
  550 CONTINUE
      INDEP = RN.GT.TAU**2*SN
      GO TO 590
  560 CONTINUE
C
C     TO PERFORM-COL-INTERCHANGE
C
      IF (.NOT.(MAX.NE.I)) GO TO 570
C     EXCHANGE ELEMENTS OF PERMUTED INDEX VECTOR AND PERFORM COL
C     INTERCHANGES.
      ITEMP = IPIVOT(I)
      IPIVOT(I) = IPIVOT(MAX)
      IPIVOT(MAX) = ITEMP
      CALL SSWAP(M, W(1,MAX), 1, W(1,I), 1)
      T = H(MAX)
      H(MAX) = H(I)
      H(I) = T
  570 GO TO IGO993, (30, 200, 330, 120)
  590 GO TO IGO990, (40, 240)
  600 GO TO IGO996, (20, 190, 320)
      END
      SUBROUTINE L2SLV(M, N, M1, L, A, MM, B, MB, W, TOL, N1, IPIVOT,
     *                 X, NN, RES, MR, QR, MMPNN, C, IFAULT)
C ** PURPOSE **
C SUBROUTINE L2SLV COMPUTES LEAST SQUARES SOLUTIONS TO OVERDETERMINED
C AND UNDERDETERMINED SYSTEMS OF LINEAR EQUATIONS.  THE METHOD USED IS
C A MODIFIED GRAM-SCHMIDT ORTHOGONAL DECOMPOSITION WITH ITERATIVE
C REFINEMENT OF THE SOLUTION.  THE SOLUTION MAY BE SUBJECT TO LINEAR
C EQUALITY CONSTRAINTS.  OUTPUT INCLUDES THE LEAST SQUARES
C COEFFICIENTS, RESIDUALS, UNSCALED COVARIANCE MATRIX, AND INFORMATION
C ON THE BEHAVIOR OF THE ITERATIVE REFINEMENT PROCEDURE.
C MATRIX A IS THE GIVEN MATRIX OF A SYSTEM OF M LINEAR EQUATIONS IN N
C UNKNOWNS, AND MATRIX W IS A GIVEN DIAGONAL MATRIX OF WEIGHTS WITH ALL
C DIAGONAL ELEMENTS NONNEGATIVE.  LET H = W*A.
C IN THE EVENT THAT N1 (THE COMPUTED RANK OF MATRIX H) IS LESS THAN N
C (THE NUMBER OF UNKNOWN COEFFICIENTS), A UNIQUE SOLUTION VECTOR HAVING
C N ELEMENTS CAN BE OBTAINED BY IMPOSING THE CONDITION THAT THE
C SOLUTION BE OF MINIMAL EUCLIDEAN NORM.  SUCH A SOLUTION IS SOUGHT IN
C THE CASE OF UNDERDETERMINED OR RANK-DEFICIENT PROBLEMS.
C
C ** INPUT VARIABLES **
C M      TOTAL NUMBER OF EQUATIONS.
C N      NUMBER OF UNKNOWN COEFFICIENTS.
C M1     NUMBER OF LINEAR CONSTRAINTS (0.LE.M1.LE.M AND M1.LE.N).
C L      NUMBER OF RIGHT-HAND SIDES (VECTORS OF OBSERVATIONS).
C A      TWO-DIMENSIONAL ARRAY OF SIZE (MM,N).  ON ENTRY, THE ARRAY A
C        CONTAINS THE GIVEN MATRIX OF A SYSTEM OF M LINEAR EQUATIONS
C        IN N UNKNOWNS, WHERE THE FIRST M1 EQUATIONS ARE TO BE
C        SATISFIED EXACTLY.  A IS LEFT INTACT ON EXIT.
C B      TWO-DIMENSIONAL ARRAY OF SIZE (MB,L).  ON ENTRY, B CONTAINS
C        THE L GIVEN RIGHT-HAND SIDES (VECTORS OF OBSERVATIONS).  B IS
C        LEFT INTACT ON EXIT.
C W      VECTOR OF SIZE M.  ON ENTRY, W CONTAINS THE DIAGONAL ELEMENTS
C        OF A GIVEN DIAGONAL MATRIX OF WEIGHTS, ALL NONNEGATIVE.
C        (THE FIRST M1 ELEMENTS OF W ARE SET EQUAL TO 1.0 BY THE
C        PROGRAM WHEN M1 IS GREATER THAN ZERO.)
C TOL    PARAMETER USED IN DETERMINING THE RANK OF MATRIX H.
C        NOTE --
C        (1) IF TOL EQUALS ZERO, THE TOLERANCE USED IN SUBROUTINE
C            DECOM2 WILL BE BASED ON MACHINE PRECISION.
C        (2) IF TOL IS GREATER THAN ZERO, THIS VALUE OF TOL WILL BE
C            USED IN SETTING AN ABSOLUTE TOLERANCE FOR COMPARISON WITH
C            DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX OBTAINED IN
C            SUBROUTINE DECOM2.  THE VALUE OF TOL CAN BE BASED ON
C            KNOWLEDGE CONCERNING THE ACCURACY OF THE DATA.
C MM     DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN
C        THE ARRAY A.  MM MUST SATISFY MM.GE.M.
C MB     DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN
C        THE ARRAY B.  MB MUST SATISFY MB.GE.M.
C MR     DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN
C        THE ARRAY RES.  MR MUST SATISFY MR.GE.M.
C NN     DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN
C        THE ARRAY X.  NN MUST SATISFY NN.GE.N.
C MMPNN  DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN
C        THE ARRAY QR.  MMPNN MUST SATISFY MMPNN.GE.M+N.
C
C ** OUTPUT VARIABLES AND INTERNAL VARIABLES **
C N1     COMPUTED RANK OF MATRIX H, WHERE H = W*A.
C IPIVOT VECTOR OF SIZE N.  ON EXIT, THIS ARRAY RECORDS THE ORDER
C        IN WHICH THE COLUMNS OF H WERE SELECTED BY THE PIVOTING
C        SCHEME IN THE COURSE OF THE ORTHOGONAL DECOMPOSITION.
C        WHENEVER N1.LT.N, THE FIRST N1 ELEMENTS OF IPIVOT INDICATE
C        WHICH COLUMNS OF H WERE FOUND TO BE LINEARLY INDEPENDENT.
C X      TWO-DIMENSIONAL ARRAY OF SIZE (NN,L).  ON EXIT, X CONTAINS
C        THE SOLUTION VECTORS.
C RES    TWO-DIMENSIONAL ARRAY OF SIZE (MR,L).  ON EXIT, RES CONTAINS
C        THE RESIDUAL VECTORS.
C QR     TWO-DIMENSIONAL ARRAY OF SIZE (MMPNN,N).  ON EXIT, IF N1 = N
C        THEN QR CONTAINS THE UNSCALED COVARIANCE MATRIX. (QR IS USED
C        INTERNALLY TO STORE THE RESULTS FROM THE SUBROUTINE DECOM2.
C        THE RESULTS FROM DECOM2 ARE DESTROYED WHEN THE COVARIANCE
C        MATRIX IS COMPUTED.)
C C      VECTOR HAVING AT LEAST 6*(M+N)+2*L ELEMENTS USED (1) FOR
C        INTERNAL WORK SPACE AND (2) FOR RETURNING INFORMATION ON THE
C        BEHAVIOR OF THE ITERATIVE REFINEMENT PROCEDURE.
C        (A) NUMIT IS THE NUMBER OF ITERATIONS CARRIED OUT DURING THE
C            ITERATIVE REFINEMENT IN ATTEMPTING TO OBTAIN A SOLUTION
C            FOR THE K-TH RIGHT-HAND SIDE.
C            ON EXIT, C(K) = +NUMIT IF THE SOLUTION CONVERGED, AND
C                     C(K) = -NUMIT IF THE SOLUTION FAILED TO CONVERGE.
C        (B) DIGITX GIVES AN ESTIMATE OF THE NUMBER OF CORRECT DIGITS
C            IN THE INITIAL SOLUTION OF THE COEFFICIENTS FOR THE K-TH
C            RIGHT-HAND SIDE.  ON EXIT, C(K+L) = DIGITX.
C IFAULT FAULT INDICATOR WHICH IS ZERO IF NO ERRORS WERE ENCOUNTERED
C        AND POSITIVE IF ERRORS WERE DETECTED OR IF EVIDENCE OF SEVERE
C        ILL-CONDITIONING WAS FOUND.  IF IFAULT IS SET TO 1, 2, 3, 4,
C        5, 6 OR 7, EXECUTION IS TERMINATED.  EXECUTION CONTINUES WHEN
C        IFAULT IS SET EQUAL TO 8, 9 OR 10 PROVIDED THAT A SOLUTION
C        WAS OBTAINED FOR AT LEAST ONE RIGHT-HAND SIDE.  THE VALUE OF
C        IFAULT IS USED TO INDICATE THE FOLLOWING --
C        0 = NO ERRORS ENCOUNTERED.
C        1 = BAD INPUT PARAMETER (M, N OR L).
C        2 = BAD INPUT PARAMETER (M1).
C        3 = BAD DIMENSION.  EITHER M.GT.MM, M.GT.MB, M.GT.MR,
C            N.GT.NN, OR M+N.GT.MMPNN.
C        4 = AT LEAST ONE WEIGHT IS NEGATIVE.
C        5 = EITHER MATRIX H OR MATRIX OF CONSTRAINTS EQUALS ZERO.
C        6 = CONSTRAINTS ARE LINEARLY DEPENDENT.
C        7 = ALL SOLUTIONS FAILED TO CONVERGE.
C        8 = SOLUTION FAILED TO CONVERGE FOR AT LEAST ONE RIGHT-HAND
C            SIDE.
C        9 = LARGE NUMBER OF ITERATIONS REQUIRED FOR CONVERGENCE.
C       10 = ESTIMATED NUMBER OF DIGITS IN INITIAL SOLUTION OF
C            COEFFICIENTS IS SMALL.
C       11 = DIAGONAL ELEMENT OF COVARIANCE MATRIX WAS COMPUTED TO BE
C            NEGATIVE OWING TO ROUNDING ERROR. NO SEVERE CONDITIONING
C            PROBLEMS WERE DETECTED.
C       12 = DIAGONAL ELEMENT OF COVARIANCE MATRIX WAS COMPUTED TO BE
C            NEGATIVE OWING TO ROUNDING ERROR. THE PROBLEM APPEARS TO
C            BE EXTREMELY ILL-CONDITIONED.
C
C ** SUBROUTINES REQUIRED **
C SUBROUTINE DECOM2
C        USES MODIFIED GRAM-SCHMIDT ALGORITHM WITH PIVOTING TO
C        OBTAIN AN ORTHOGONAL DECOMPOSITION OF THE INPUT MATRIX.
C SUBROUTINE SOLVE2
C        COMPUTES COEFFICIENTS AND RESIDUALS.  ITERATIVE REFINEMENT IS
C        USED TO IMPROVE THE ACCURACY OF THE INITIAL SOLUTION.
C SUBROUTINE SOLVE3
C        CALLED ONLY BY SUBROUTINE SOLVE2.
C SUBROUTINE COVAR
C        COMPUTES UNSCALED COVARIANCE MATRIX OF THE COEFFICIENTS.
C
C ** STORAGE REQUIREMENTS **
C THE STORAGE REQUIRED FOR THE DIMENSIONED ARRAYS IN L2SLV IS
C   M*(2*N + 2*L + 7) + N*(N + L + 7) + 2*L
C LOCATIONS.  ALL ARRAYS REQUIRED IN SUBROUTINES CALLED BY L2SLV ARE
C DECLARED HEREIN AND ARE TRANSMITTED ONLY THROUGH PARAMETER LISTS OF
C CALL-SEQUENCES.
C
C ** PRECISION OF ARITHMETIC CALCULATIONS **
C SINGLE PRECISION ARITHMETIC IS USED FOR ALL CALCULATIONS EXCEPT THE
C DOUBLE PRECISION ACCUMULATION OF INNER PRODUCTS.  (THE VARIABLE SUM
C IS DECLARED TO BE DOUBLE PRECISION IN SUBROUTINES DECOM2, SOLVE2,
C SOLVE3 AND COVAR.)  IT IS ESSENTIAL FOR THE SUCCESS OF THE ITERATIVE
C REFINEMENT PROCEDURE THAT INNER PRODUCTS BE ACCUMULATED IN DOUBLE
C PRECISION.
C
C ** CONVERSION OF THE PROGRAM TO DOUBLE PRECISION **
C *********************************************************************
C * ON COMPUTERS HAVING SHORT WORD LENGTH (AS THE IBM 360/370) IT MAY *
C * BE DESIRABLE TO PERFORM ALL CALCULATIONS IN DOUBLE PRECISION.  IN *
C * THIS CASE, THE ITERATIVE REFINEMENT PRESENTLY INCLUDED IN SOLVE2  *
C * SHOULD BE OMITTED.                                                *
C * TO CONVERT THE PROGRAM TO DOUBLE PRECISION, THE FOLLOWING         *
C * APPROACH IS SUGGESTED.                                            *
C *                                                                   *
C * 1. VARIABLES PRESENTLY DECLARED TO BE REAL SHOULD BE DECLARED     *
C *    DOUBLE PRECISION.  THOSE TYPED INTEGER, DOUBLE PRECISION AND   *
C *    LOGICAL SHOULD NOT BE CHANGED.                                 *
C * 2. THE USE OF FAIL, NUMIT AND DIGITX SHOULD BE OMITTED.           *
C * 3. DESCRIPTION OF VARIABLE C (AT L2B 690-790) SHOULD READ --      *
C *    C  VECTOR HAVING AT LEAST 6*(M+N) ELEMENTS USED ONLY FOR       *
C *       INTERNAL WORK SPACE.                                        *
C * 4. THE VALUE OF ETA (AT L2B 1960) SHOULD BE SET SO THAT IT IS THE *
C *    SMALLEST POSITIVE DOUBLE PRECISION NUMBER SUCH THAT 1.0 + ETA  *
C *    IS GREATER THAN 1.0 IN DOUBLE PRECISION ARITHMETIC.            *
C *    FOR IBM COMPUTER TYPE, ETA = 16.**(-13)                        *
C *    FOR UNIVAC COMPUTER TYPE, ETA = 2.**(-59)                      *
C * 5. THE FOLLOWING FORTRAN FUNCTIONS SHOULD BE CHANGED --           *
C *      SINGLE PRECISION NAME     DOUBLE PRECISION NAME              *
C *             DBLE(X)                X                              *
C *             FLOAT(N)               DBLE(FLOAT(N))                 *
C *             SQRT(X)                DSQRT(X)                       *
C *    DBLE(X) IS USED IN SUBROUTINES DECOM2, SOLVE2, SOLVE3 AND      *
C *       COVAR.                                                      *
C *    FLOAT(N) IS USED IN SUBROUTINE DECOM2.                         *
C *    SQRT(X) IS USED IN SUBROUTINE L2SLV.                           *
C * 6. REPLACE STATEMENT L2B 2500 BY A STATEMENT READING              *
C *          K3 = 1                                                   *
C * 7. FURTHER DETAILS ARE GIVEN IN SUBROUTINE SOLVE2 IN CONNECTION   *
C *    WITH THE OMISSION OF ITERATIVE REFINEMENT.                     *
C * 8. IN SUBROUTINE L2SLV, STATEMENTS L2B 950-1000, 1820-1830, 2020, *
C *    2350-2360, 2480-2490, 3070, 3280-3570 AND 3590-3620 SHOULD BE  *
C *    OMITTED.                                                       *
C *    STATEMENT NUMBERS GIVEN HERE REFER TO THOSE IN THE RIGHT-HAND  *
C *    MARGIN.  CERTAIN COMMENTS IN SUBROUTINE L2SLV DO NOT APPLY TO  *
C *    THE DOUBLE PRECISION VERSION.                                  *
C *                                                                   *
C *********************************************************************
C
      INTEGER IPIVOT(N)
      REAL A(MM,N), B(MB,L), C(*), ETA, QR(MMPNN,N),
     * RES(MR,L), TOL, W(M), X(NN,L)
      REAL DIGITX
      LOGICAL FAIL
      LOGICAL SING
C
C SET VALUE OF ETA, A MACHINE-DEPENDENT PARAMETER.
C ETA, THE RELATIVE MACHINE PRECISION, IS THE SMALLEST POSITIVE REAL
C NUMBER SUCH THAT 1.0 + ETA IS GREATER THAN 1.0 IN FLOATING-POINT
C ARITHMETIC.
C
      ETA = SPMPAR(1)
C
C DEFAULT VALUE FOR TOL IS ZERO.
C
      IF (TOL.LT.0.0) TOL = 0.0
      IFAULT = 0
      KSUM = 0
C
C PERFORM INITIAL CHECKING OF INPUT PARAMETERS, DIMENSIONS AND
C WEIGHTS FOR POSSIBLE ERRORS.
C
      IF (M.GT.0 .AND. N.GT.0 .AND. L.GT.0) GO TO 10
      IFAULT = 1
      RETURN
   10 IF (M1.LE.M .AND. M1.LE.N .AND. M1.GE.0) GO TO 20
      IFAULT = 2
      RETURN
   20 IF (M.LE.MM .AND. M.LE.MB .AND. M.LE.MR .AND. N.LE.NN
     *            .AND. M+N.LE.MMPNN) GO TO 30
      IFAULT = 3
      RETURN
   30 DO 40 I=1,M
        IF (M1.GT.0 .AND. I.LE.M1) W(I) = 1.0
        IF (W(I).GE.0.0) GO TO 40
        IFAULT = 4
        RETURN
   40 CONTINUE
C
C SET PARAMETERS WHICH ALLOCATE VECTOR C TO CONTAIN CERTAIN FINAL
C RESULTS AND ALSO TO BE USED AS WORK SPACE.
C
C K1 IS STARTING POINT FOR NUMIT AND FAIL, OF LENGTH L.
C K2 IS STARTING POINT FOR DIGITX, OF LENGTH L.
C K3 IS STARTING POINT FOR D, OF LENGTH N.
C K4 IS STARTING POINT FOR K-TH COLUMN OF B, OF LENGTH M.
C K5 IS STARTING POINT FOR K-TH COLUMN OF X, OF LENGTH N.
C K6 IS STARTING POINT FOR K-TH COLUMN OF RES, OF LENGTH M.
C K7 IS STARTING POINT FOR WORK SPACE OF LENGTH M.
C K8 IS STARTING POINT FOR WORK SPACE OF LENGTH M.
C K9 IS STARTING POINT FOR WORK SPACE OF LENGTH N.
C K10 IS STARTING POINT FOR WORK SPACE OF LENGTH N.
C K11 IS STARTING POINT FOR WORK SPACE OF LENGTH M + N.
C K12 IS STARTING POINT FOR WORK SPACE OF LENGTH M + N.
C
      K1 = 1
      K2 = K1 + L
      K3 = K2 + L
      K4 = K3 + N
      K5 = K4 + M
      K6 = K5 + N
      K7 = K6 + M
      K8 = K7 + M
      K9 = K8 + M
      K10 = K9 + N
      K11 = K10 + N
      K12 = K11 + M + N
      K = K12 + M + N - 1
C
C MULTIPLY EACH ROW OF MATRIX A (M BY N) BY ITS APPROPRIATE WEIGHT AND
C STORE THE RESULT IN THE FIRST M ROWS OF ARRAY QR.  SET ARRAY C AND
C THE LAST N ROWS OF ARRAY QR EQUAL TO ZERO.
C
      DO 60 I=1,K
        C(I) = 0.0
   60 CONTINUE
      MP1 = M + 1
      MPN = M + N
      DO 90 J=1,N
        DO 70 I=1,M
          QR(I,J) = A(I,J)*W(I)
   70   CONTINUE
        DO 80 I=MP1,MPN
          QR(I,J) = 0.0
   80   CONTINUE
   90 CONTINUE
C
C OBTAIN AN ORTHOGONAL DECOMPOSITION OF THE MATRIX STORED IN THE FIRST
C M ROWS OF ARRAY QR AND COMPUTE ITS RANK.
C
      CALL DECOM2(M, N, M1, ETA, TOL, QR, C(K3), N1, IPIVOT, SING,
     * MMPNN)
C
      IF (.NOT.SING) GO TO 110
      IF (N1.GT.0) GO TO 100
      IFAULT = 5
      RETURN
  100 IFAULT = 6
      RETURN
C
C SEEK A SOLUTION (COEFFICIENTS AND RESIDUALS) FOR EACH OF THE L LEAST
C SQUARES PROBLEMS WHOSE RIGHT-HAND SIDES ARE GIVEN IN THE ARRAY B.
C
  110 ITER = -ALOG10(ETA)
      DO 200 K=1,L
C K-TH RIGHT-HAND SIDE.
        K0 = K4 - 1
        DO 120 I=1,M
          K0 = K0 + 1
          C(K0) = B(I,K)
  120   CONTINUE
C
        CALL SOLVE2(M, N, M1, A, C(K4), W, N1, IPIVOT, QR, C(K3),
     *   ETA, FAIL, NUMIT, DIGITX,
     *   C(K5), C(K6), C(K7), C(K8), C(K9), C(K10), C(K11), C(K12),
     *   MM, MMPNN)
C
        K0 = K5 - 1
        DO 130 J=1,N
          K0 = K0 + 1
          X(J,K) = C(K0)
  130   CONTINUE
        IF (M1.EQ.0) GO TO 150
        DO 140 I=1,M1
          RES(I,K) = 0.0
  140   CONTINUE
  150   M1P1 = M1 + 1
        IF (M1P1.GT.M) GO TO 170
        K0 = K6 + M1 - 1
        DO 160 I=M1P1,M
          K0 = K0 + 1
          RES(I,K) = C(K0)
  160   CONTINUE
  170   CONTINUE
C
C FOR RIGHT-HAND SIDES WHERE CONVERGENCE OF A SOLUTION IS REPORTED,
C A CHECK IS MADE FOR EVIDENCE OF SEVERE ILL-CONDITIONING.  SUCH
C EVIDENCE IS FURNISHED BY LARGE VALUES OF NUMIT (NUMBER OF ITERATIONS
C BEFORE CONVERGENCE WAS OBTAINED) AND SMALL VALUES OF DIGITX
C (ESTIMATE OF THE NUMBER OF CORRECT DIGITS IN THE INITIAL SOLUTION
C OF THE COEFFICIENTS).  IF NUMIT EXCEEDS -ALOG10(ETA) THEN IFAULT
C IS SET TO 9.  IF DIGITX IS LESS THAN 0.5 (HALF A DECIMAL DIGIT)
C THEN IFAULT IS SET TO 10.
C
        C(K) = FLOAT(NUMIT)
        IF (FAIL) C(K) = -C(K)
        K0 = K2 + K - 1
        C(K0) = DIGITX
        IF (.NOT.FAIL) GO TO 180
C KSUM IS A TALLY OF SOLUTIONS WHICH FAILED TO CONVERGE.
        KSUM = KSUM + 1
        IFAULT = 8
        GO TO 200
  180   IF (NUMIT.LE.ITER) GO TO 190
        IFAULT = 9
  190   IF (DIGITX.GE.0.5) GO TO 200
        IFAULT = 10
  200 CONTINUE
      IF (KSUM.LT.L) GO TO 210
      IFAULT = 7
      RETURN
  210 IF (N1.LT.N) RETURN
      DO 230 I=1,N
        MPI = M + I
        DO 220 J=1,N
          QR(I,J) = QR(MPI,J)
  220   CONTINUE
        QR(I,I) = 0.0
  230 CONTINUE
C
C COMPUTE THE UNSCALED COVARIANCE MATRIX OF THE COEFFICIENTS.
C
      CALL COVAR(N, M1, N1, IPIVOT, QR, C(K3), C(K9), MMPNN)
      IF (N.EQ.1) GO TO 260
      DO 250 J=2,N
      JM1 = J - 1
        DO 240 I=1,JM1
  240   QR(I,J) = QR(J,I)
  250 CONTINUE
C
C IN CERTAIN PROBLEMS, SOME DIAGONAL TERMS OF THE UNSCALED COVARIANCE
C MATRIX ARE EQUAL TO ZERO OR TO SMALL POSITIVE NUMBERS.  BECAUSE OF
C ROUNDING ERRORS, COMPUTED VALUES FOR THESE TERMS MAY BE SMALL
C NEGATIVE NUMBERS.  IFAULT IS SET TO 11 IF THIS OCCURS.
C
  260 DO 270 J=1,N
        IF (QR(J,J).LT.0.0) GO TO 280
  270 CONTINUE
      RETURN
  280 IF (IFAULT.NE.0) GO TO 290
      IFAULT = 11
      RETURN
  290 IFAULT = 12
      RETURN
      END
C     SUBROUTINE DECOM2(...)
C SUBROUTINE DECOM2 USES A MODIFIED GRAM-SCHMIDT ALGORITHM WITH
C PIVOTING TO OBTAIN AN ORTHOGONAL DECOMPOSITION OF THE INPUT MATRIX
C GIVEN IN QR.
C THE INPUT PARAMETER TOL (EQUAL EITHER TO ZERO OR TO A POSITIVE
C NUMBER) IS USED IN DETERMINING THE RANK OF MATRIX QR.
C NOTE --
C     (1) IF TOL EQUALS ZERO, THE TOLERANCE USED AT STATEMENT DC2 1180
C         WILL BE BASED ON MACHINE PRECISION.
C         UNDER THIS APPROACH, THE TOLERANCE (TOL2) IS SET EQUAL TO
C         (FLOAT(N)*ETA)**2*D(M1+1) AT STATEMENT DC2 1170.
C         IF DESIRED, THE USER CAN OBTAIN A MORE CONSERVATIVE
C         TOLERANCE BY REPLACING N IN THIS STATEMENT BY A LARGER
C         QUANTITY.
C     (2) IF TOL IS GREATER THAN ZERO, TOL2 (WHICH IS SET EQUAL TO
C         TOL) WILL BE USED AT STATEMENT DC2 1180 AS AN ABSOLUTE
C         TOLERANCE FOR COMPARISON WITH DIAGONAL ELEMENTS OF THE
C         TRIANGULAR MATRIX OBTAINED IN THE DECOMPOSITION.  UNDER THIS
C         APPROACH, THE VALUE OF TOL CAN BE BASED ON KNOWLEDGE
C         CONCERNING THE ACCURACY OF THE DATA.
C ON EXIT, THE ARRAYS QR, D AND IPIVOT CONTAIN THE RESULTS OF THE
C DECOMPOSITION WHICH ARE NEEDED FOR OBTAINING AN INITIAL SOLUTION
C AND FOR ITERATIVE REFINEMENT.
C ON EXIT, N1 IS THE COMPUTED RANK OF THE INPUT MATRIX QR.
C ON EXIT, SING IS SET EQUAL TO .TRUE. WHENEVER
C     (1) N1 = 0 (I.E., INPUT MATRIX QR EQUALS ZERO OR MATRIX OF
C         CONSTRAINTS EQUALS ZERO), OR
C     (2) N1 IS LESS THAN M1 (I.E., THE M1 BY N MATRIX OF LINEAR
C         CONSTRAINTS IS SINGULAR).
C OTHERWISE, ON EXIT FROM DECOM2, SING = .FALSE.
C ON EXIT, THE VECTOR IPIVOT RECORDS THE ORDER IN WHICH THE COLUMNS
C OF QR WERE SELECTED BY THE PIVOTING SCHEME IN THE COURSE OF THE
C ORTHOGONAL DECOMPOSITION.
      SUBROUTINE DECOM2(M, N, M1, ETA, TOL, QR, D, N1, IPIVOT, SING,
     * MMPNN)
      INTEGER IPIVOT(N)
      REAL C, D(*), DM, DS, ETA, QR(MMPNN,N), RSJ, TOL, TOL2
      DOUBLE PRECISION SUM
      LOGICAL FINIS, FSUM, SING
      N1 = 0
      SING = .TRUE.
      FSUM = .TRUE.
      MV = 1
      MH = M1
      MS = M
      MP1 = M + 1
      FINIS = .FALSE.
      IF (TOL.GT.0.0) TOL2 = TOL
      DO 10 J=1,N
        D(J) = 0.0
        IPIVOT(J) = J
   10 CONTINUE
C STEP NUMBER NS OF THE DECOMPOSITION.
      DO 350 NS=1,N
        K = M + NS
        IF (NS.EQ.M1+1) GO TO 20
        GO TO 30
   20   IF (M1.EQ.M) GO TO 200
        MV = M1 + 1
        MH = M
        FSUM = .TRUE.
   30   IF (.NOT.FINIS) GO TO 40
        GO TO 150
C PIVOT SEARCH.
   40   DS = 0.0
        NP = NS
        DO 90 J=NS,N
          IF (FSUM) GO TO 50
          GO TO 70
   50     SUM = 0.0
          DO 60 L=MV,MH
            SUM = SUM + DBLE(QR(L,J))*DBLE(QR(L,J))
   60     CONTINUE
          D(J) = SUM
   70     IF (DS.LT.D(J)) GO TO 80
          GO TO 90
   80     DS = D(J)
          NP = J
   90   CONTINUE
        IF (FSUM) DM = DS
        IF (DS.LT.ETA*DM) GO TO 100
        FSUM = .FALSE.
        GO TO 110
  100   FSUM = .TRUE.
  110   IF (FSUM) GO TO 40
        IF (NP.NE.NS) GO TO 120
        GO TO 140
C COLUMN INTERCHANGE.
  120   IK = IPIVOT(NP)
        IPIVOT(NP) = IPIVOT(NS)
        IPIVOT(NS) = IK
        D(NP) = D(NS)
        KM1 = K - 1
        DO 130 L=1,KM1
          C = QR(L,NP)
          QR(L,NP) = QR(L,NS)
          QR(L,NS) = C
  130   CONTINUE
C END COLUMN INTERCHANGE.
C END PIVOT SEARCH.
C RETURN HERE IF N1 = 0.  EITHER INPUT MATRIX QR EQUALS ZERO OR
C MATRIX OF CONSTRAINTS EQUALS ZERO.
  140   IF (NS.EQ.1 .AND. DS.EQ.0.0) RETURN
        GO TO 160
  150   MS = K - 1
        MH = K - 1
  160   IF (FINIS) GO TO 170
        C = 0.0
        GO TO 180
  170   C = 1.0
  180   SUM = DBLE(C)
        DO 190 L=MV,MH
          SUM = SUM + DBLE(QR(L,NS))*DBLE(QR(L,NS))
  190   CONTINUE
        D(NS) = SUM
        DS = D(NS)
        IF (TOL.EQ.0.0) TOL2 = (FLOAT(N)*ETA)**2*D(M1+1)
        IF (.NOT.FINIS .AND. NS.GT.M1 .AND. DS.LE.TOL2) GO TO 200
        GO TO 290
  200   FINIS = .TRUE.
        MV = M + 1
        DO 280 NP=NS,N
          IF (1.GT.M1) GO TO 250
          DO 210 L=1,M1
            QR(L,NP) = 0.0
  210     CONTINUE
          DO 240 J=1,M1
            SUM = 0.0
            DO 220 L=1,M
              SUM = SUM + DBLE(QR(L,J))*DBLE(QR(L,NP))
  220       CONTINUE
            C = SUM
            C = C/D(J)
            DO 230 L=1,M1
              QR(L,NP) = QR(L,NP) - C*QR(L,J)
  230       CONTINUE
  240     CONTINUE
  250     MPN1 = M + N1
          DO 270 JJ=MP1,MPN1
            J = (M + 1) + (M + N1) - JJ
            SUM = 0.0
            DO 260 L=J,MPN1
              LMM = L - M
              SUM = SUM + DBLE(QR(J,LMM))*DBLE(QR(L,NP))
  260       CONTINUE
            QR(J,NP) = -SUM
  270     CONTINUE
  280   CONTINUE
        GO TO 150
C RETURN HERE IF MATRIX OF CONSTRAINTS IS FOUND TO BE SINGULAR.
  290   IF (DS.EQ.0.0) RETURN
        QR(K,NS) = -1.0
        NSP1 = NS + 1
        IF (NSP1.GT.N) GO TO 340
C BEGIN ORTHOGONALIZATION.
        DO 330 J=NSP1,N
          SUM = 0.0
          DO 300 L=MV,MH
            SUM = SUM + DBLE(QR(L,J))*DBLE(QR(L,NS))
  300     CONTINUE
          RSJ = SUM
          RSJ = RSJ/DS
          QR(K,J) = RSJ
          DO 310 L=1,MS
            QR(L,J) = QR(L,J) - RSJ*QR(L,NS)
  310     CONTINUE
          IF (.NOT.FINIS) GO TO 320
          GO TO 330
  320     D(J) = D(J) - DS*RSJ*RSJ
  330   CONTINUE
C END ORTHOGONALIZATION.
  340   IF (.NOT.FINIS) N1 = N1 + 1
  350 CONTINUE
C END STEP NUMBER NS.
      SING = .FALSE.
C NORMAL RETURN.
      RETURN
      END
C     SUBROUTINE SOLVE2(...)
C SUBROUTINE SOLVE2 USES THE ORTHOGONAL DECOMPOSITION STORED IN QR, D
C AND IPIVOT TO COMPUTE THE SOLUTION (COEFFICIENTS AND RESIDUALS)
C TO THE LEAST SQUARES PROBLEM WHOSE RIGHT-HAND SIDE IS GIVEN IN B.
C IN THE EVENT THAT N1 (THE COMPUTED RANK OF MATRIX H) IS LESS THAN N
C (THE NUMBER OF UNKNOWN COEFFICIENTS), A UNIQUE SOLUTION VECTOR HAVING
C N ELEMENTS CAN BE OBTAINED BY IMPOSING THE CONDITION THAT THE
C SOLUTION BE OF MINIMAL EUCLIDEAN NORM.  SUCH A SOLUTION IS SOUGHT IN
C THE CASE OF UNDERDETERMINED OR RANK-DEFICIENT PROBLEMS.
C IN NORMAL EXITS, THE SOLUTION IS CONTAINED IN THE VECTOR X
C (COEFFICIENTS) AND THE VECTOR RES (RESIDUALS).
C ITERATIVE REFINEMENT IS USED TO IMPROVE THE ACCURACY OF THE INITIAL
C SOLUTION.
C ON EXIT, FAIL IS SET EQUAL TO .TRUE. IF THE SOLUTION FAILS TO
C IMPROVE SUFFICIENTLY.  OTHERWISE, FAIL = .FALSE.  INFORMATION ON THE
C BEHAVIOR OF THE ITERATIVE REFINEMENT PROCEDURE IS GIVEN BY NUMIT AND
C DIGITX.  NUMIT IS THE NUMBER OF ITERATIONS CARRIED OUT IN ATTEMPTING
C TO OBTAIN A SOLUTION.  DIGITX IS AN ESTIMATE OF THE NUMBER OF
C CORRECT DIGITS IN THE INITIAL SOLUTION OF THE COEFFICIENTS.
C THIS SUBROUTINE CALLS SUBROUTINE SOLVE3.
C
C ********* CONVERSION OF THIS SUBROUTINE TO DOUBLE PRECISION *********
C * IF THE PROGRAM IS CONVERTED SO THAT ALL CALCULATIONS ARE DONE IN  *
C * DOUBLE PRECISION ARITHMETIC, THE ITERATIVE REFINEMENT PRESENTLY   *
C * INCLUDED IN SOLVE2 SHOULD BE OMITTED, SINCE THE SUCCESS OF THIS   *
C * PROCEDURE DEPENDS ON COMPUTING INNER PRODUCTS IN GREATER          *
C * PRECISION THAN OTHER CALCULATIONS.                                *
C * SEE COMMENTS IN SUBROUTINE L2SLV REGARDING CONVERSION TO DOUBLE   *
C * PRECISION.  IN ADDITION, THE FOLLOWING COMMENTS INDICATE HOW TO   *
C * OMIT THE ITERATIVE REFINEMENT FROM THIS SUBROUTINE.  STATEMENT    *
C * NUMBERS GIVEN HERE REFER TO THOSE IN THE RIGHT-HAND MARGIN.       *
C *                                                                   *
C * 1. IN STATEMENT SV2 470 CHANGE REAL TO DOUBLE PRECISION.          *
C * 2. REPLACE STATEMENT SV2 880 BY A STATEMENT READING               *
C *       30 DO 50 I=1,M                                              *
C * 3. REPLACE STATEMENTS SV2 1310-1400 BY A STATEMENT READING        *
C *          RETURN                                                   *
C * 4. OMIT STATEMENTS SV2 120-190, 440, 490-500, 520-550, 650,       *
C *    750-850, 1650-1830 AND 1850-1910.                              *
C *                                                                   *
C *********************************************************************
C
      SUBROUTINE SOLVE2(M, N, M1, A, B, W, N1, IPIVOT, QR, D,
     * ETA, FAIL, NUMIT, DIGITX,
     * X, RES, WRES, Y1, Y2, Y, F, G, MM, MMPNN)
      INTEGER IPIVOT(N)
      REAL A(MM,N), B(*), C, D(*), F(*), G(*),
     * QR(MMPNN,N), RES(*), W(M), WRES(*), X(*), Y(*), Y1(*), Y2(*)
      REAL DIGITX, DXNORM, ETA, ETA2, RDR1, RDR2, RDX1, RDX2, RNR,
     * RNX, XNORM
      DOUBLE PRECISION SUM
      LOGICAL FAIL
      NUMIT = 0
      KZ = 0
      ETA2 = ETA*ETA
      MP1 = M + 1
      MPN = M + N
      N1P1 = N1 + 1
      DO 10 I=1,M
        F(I) = B(I)*W(I)
        G(I) = 0.0
        WRES(I) = 0.0
        RES(I) = 0.0
        Y1(I) = 0.0
        IF (W(I).EQ.0.0) KZ = KZ + 1
   10 CONTINUE
      DO 20 NS=1,N
        J = M + NS
        F(J) = 0.0
        G(J) = 0.0
        X(NS) = 0.0
        Y2(NS) = 0.0
   20 CONTINUE
      K = 0
      RDX2 = 0.0
      RDR2 = 0.0
C BEGIN K-TH ITERATION STEP.
   30 IF (K.LT.2) GO TO 40
      IF (((64.*RDX2.LT.RDX1) .AND. (RDX2.GT.ETA2*RNX)) .OR.
     * ((64.*RDR2.LT.RDR1) .AND. (RDR2.GT.ETA2*RNR))) GO TO 40
      GO TO 270
   40 RDX1 = RDX2
      RDR1 = RDR2
      RDX2 = 0.0
      RDR2 = 0.0
      IF (K.EQ.0) GO TO 160
C NEW RESIDUALS.
      DO 50 I=1,M
        WRES(I) = WRES(I) + F(I)*W(I)
        IF (W(I).EQ.0.0) GO TO 50
        RES(I) = RES(I) + F(I)/W(I)
        Y1(I) = Y1(I) + G(I)
   50 CONTINUE
      DO 100 NS=1,N
        J = M + NS
        NP = IPIVOT(NS)
        X(NP) = X(NP) + F(J)
        Y2(NP) = Y2(NP) + G(J)
        SUM = -DBLE(X(NP))
        DO 60 L=1,M
          SUM = SUM + DBLE(A(L,NP))*DBLE(Y1(L))
   60   CONTINUE
        G(J) = -SUM
        IF (NS.GT.N1) GO TO 70
        GO TO 80
   70   F(J) = 0.0
        GO TO 100
   80   SUM = 0.0
        DO 90 L=1,M
          SUM = SUM + DBLE(A(L,NP))*DBLE(WRES(L))
   90   CONTINUE
        F(J) = -SUM
  100 CONTINUE
      DO 130 I=1,M
        SUM = 0.0
        IF (I.GT.M1) SUM = DBLE(RES(I))
        DO 110 L=1,N
          SUM = SUM + DBLE(A(I,L))*DBLE(X(L))
  110   CONTINUE
        SUM = SUM - DBLE(B(I))
        F(I) = -SUM
        F(I) = F(I)*W(I)
        IF (W(I).EQ.0.0) RES(I) = DBLE(RES(I)) - SUM
        SUM = 0.0
        IF (I.GT.M1) SUM = DBLE(Y1(I))
        DO 120 L=1,N
          SUM = SUM + DBLE(A(I,L))*DBLE(Y2(L))
  120   CONTINUE
        G(I) = -SUM
  130 CONTINUE
      IF (N1P1.GT.N) GO TO 160
      DO 150 I=N1P1,N
        NS = N + N1P1 - I
        J = M + NS
        SUM = 0.0
        DO 140 L=1,J
          SUM = SUM + DBLE(QR(L,NS))*DBLE(G(L))
  140   CONTINUE
        G(J) = SUM
  150 CONTINUE
C END NEW RESIDUALS.
C
  160 CALL SOLVE3(F, M1, M, N1, QR, D, Y, MMPNN)
C
      IF (N1P1.GT.N) GO TO 200
      DO 190 NS=N1P1,N
        J = M + NS
        SUM = DBLE(G(J))
        DO 170 L=MP1,J
          SUM = SUM + DBLE(QR(L,NS))*DBLE(F(L))
  170   CONTINUE
        C = SUM
        C = C/D(NS)
        DO 180 I=1,J
          F(I) = F(I) - C*QR(I,NS)
  180   CONTINUE
  190 CONTINUE
  200 DO 210 J=MP1,MPN
        G(J) = 0.0
        IF (J.LE.M+N1) G(J) = G(J) + F(J)
  210 CONTINUE
C
      CALL SOLVE3(G, M1, M, N1, QR, D, Y, MMPNN)
C
      DO 220 I=1,M
        RDR2 = RDR2 + F(I)*F(I)
  220 CONTINUE
      DO 230 I=MP1,MPN
        RDX2 = RDX2 + F(I)*F(I)
  230 CONTINUE
      IF (K.NE.0) GO TO 240
      RNR = RDR2
      RNX = RDX2
  240 IF (K.NE.1) GO TO 260
      XNORM = SQRT(RNX)
      DXNORM = SQRT(RDX2)
      IF (XNORM.NE.0.0) GO TO 250
      DIGITX = -ALOG10(ETA)
      GO TO 260
  250 DIGITX = -ALOG10(AMAX1(DXNORM/XNORM,ETA))
C END K-TH ITERATION STEP.
  260 NUMIT = K
      K = K + 1
      GO TO 30
  270 IF ((M1+KZ.EQ.M) .AND. (RDX2.GT.4.*ETA2*RNX)) GO TO 280
      IF ((RDR2.GT.4.*ETA2*RNR) .AND.
     * (RDX2.GT.4.*ETA2*RNX)) GO TO 280
      FAIL = .FALSE.
      RETURN
  280 FAIL = .TRUE.
      RETURN
      END
      SUBROUTINE SOLVE3(F, M1, M, N1, QR, D, Y, MMPNN)
C SUBROUTINE SOLVE3 IS CALLED ONLY BY SUBROUTINE SOLVE2.
C THIS SUBROUTINE CALCULATES NEW VALUES OF F.
      REAL C, D(*), F(*), QR(MMPNN,N1), Y(*)
      DOUBLE PRECISION SUM
      MV = 1
      MH = M1
      DO 100 NS=1,N1
        J = M + NS
        IF (NS.EQ.M1+1) GO TO 10
        GO TO 20
   10   MV = M1 + 1
        MH = M
   20   NSM1 = NS - 1
        SUM = -DBLE(F(J))
        IF (NS.EQ.1) GO TO 40
        DO 30 L=1,NSM1
          MPL = M + L
          SUM = SUM + DBLE(QR(MPL,NS))*DBLE(Y(L))
   30   CONTINUE
   40   Y(NS) = -SUM
        IF (NS.GT.M1) GO TO 50
        GO TO 60
   50   C = -Y(NS)
        GO TO 70
   60   C = 0.0
   70   SUM = DBLE(C)
        DO 80 L=MV,MH
          SUM = SUM + DBLE(QR(L,NS))*DBLE(F(L))
   80   CONTINUE
        C = SUM
        C = C/D(NS)
        F(J) = C
        DO 90 L=MV,M
          F(L) = F(L) - C*QR(L,NS)
   90   CONTINUE
  100 CONTINUE
      IF (1.GT.M1) GO TO 150
      DO 110 L=1,M1
        F(L) = 0.0
  110 CONTINUE
      DO 140 NS=1,M1
        SUM = -DBLE(Y(NS))
        DO 120 L=1,M
          SUM = SUM + DBLE(QR(L,NS))*DBLE(F(L))
  120   CONTINUE
        C = SUM
        C = C/D(NS)
        DO 130 L=1,M1
          F(L) = F(L) - C*QR(L,NS)
  130   CONTINUE
  140 CONTINUE
  150 DO 170 NS=1,N1
        J = M + N1 + 1 - NS
        MPN1 = M + N1
        SUM = 0.0
        DO 160 L=J,MPN1
          LMM = L - M
          SUM = SUM + DBLE(QR(J,LMM))*DBLE(F(L))
  160   CONTINUE
        F(J) = -SUM
  170 CONTINUE
      RETURN
      END
      SUBROUTINE COVAR(N, M1, N1, IPIVOT, C, D, Z, NN)
C SUBROUTINE COVAR USES RESULTS FROM THE ORTHOGONAL DECOMPOSITION
C STORED IN C, D AND IPIVOT TO COMPUTE THE UNSCALED COVARIANCE MATRIX
C OF THE LEAST SQUARES COEFFICIENTS.
C ON ENTRY, THE FIRST N ROWS AND THE FIRST N COLUMNS OF C CONTAIN THE
C UPPER TRIANGULAR MATRIX OBTAINED FROM THE DECOMPOSITION.  THIS INPUT
C MATRIX IS DESTROYED IN SUBSEQUENT CALCULATIONS.
C ON EXIT, THE LOWER TRIANGULAR PORTION OF THE SYMMETRIC UNSCALED
C COVARIANCE MATRIX IS CONTAINED IN
C     C(1,1)
C     C(2,1) C(2,2)
C     . . .
C     C(N,1) C(N,2) ... C(N,N)
C IF N1 IS LESS THAN N, ONE OR MORE COLUMNS OF THE MATRIX
C H = (SQRT(W))*A WERE REJECTED AS BEING LINEARLY DEPENDENT.  WHENEVER
C THE K-TH COLUMN OF H WAS SO REJECTED, C(I,J) IS SET EQUAL TO ZERO,
C FOR I = K OR J = K, I.GE.J.
      INTEGER IPIVOT(N)
      REAL C(NN,N), D(*), Z(*)
      DOUBLE PRECISION SUM
      L = N1
      IF (L.GT.M1) C(L,L) = 1.0/D(L)
      IF (L.EQ.1) GO TO 60
   10 J = L - 1
      IF (J.GT.M1) C(J,J) = 1.0/D(J)
      DO 20 K=L,N1
        Z(K) = C(J,K)
   20 CONTINUE
      I = N1
      DO 40 KA=J,N1
        SUM = 0.0
        IF (I.EQ.J) SUM = DBLE(C(I,J))
        DO 30 K=L,N1
          SUM = SUM - DBLE(Z(K))*DBLE(C(K,I))
   30   CONTINUE
        C(I,J) = SUM
        I = I - 1
   40 CONTINUE
      DO 50 K=L,N1
        C(J,K) = C(K,J)
   50 CONTINUE
      L = L - 1
      IF (L.GT.1) GO TO 10
   60 IF (N1.EQ.N) GO TO 90
      N1P1 = N1 + 1
      DO 80 I=1,N
        DO 70 J=N1P1,N
          C(I,J) = 0.0
   70   CONTINUE
   80 CONTINUE
C PERMUTE THE COLUMNS AND ROWS OF MATRIX C TO ACCOUNT FOR PIVOTING.
   90 DO 120 I=1,N
        DO 100 J=1,N
          K = IPIVOT(J)
          Z(K) = C(I,J)
  100   CONTINUE
        DO 110 J=1,N
          C(I,J) = Z(J)
  110   CONTINUE
  120 CONTINUE
      DO 150 I=1,N
        DO 130 J=1,N
          K = IPIVOT(J)
          Z(K) = C(J,I)
  130   CONTINUE
        DO 140 J=I,N
          C(J,I) = Z(J)
  140   CONTINUE
  150 CONTINUE
      RETURN
      END
      SUBROUTINE SPLSQ(M,N,A,IA,JA,DAMP,U,X,ATOL,BTOL,CONLIM,ITNLIM,
     *                     ISTOP,ITN,ACOND,RNORM,XNORM,W)
C
      INTEGER M,N,ITNLIM,ISTOP
      INTEGER IA(*),JA(*)
      REAL    A(*),DAMP,U(M),X(N),ATOL,BTOL,CONLIM,
     *        ACOND,RNORM,XNORM,W(*)
C     ------------------------------------------------------------------
C
C     SPLSQ FINDS A SOLUTION X TO THE FOLLOWING PROBLEMS ...
C
C     1. UNSYMMETRIC EQUATIONS --    SOLVE  A*X = B
C
C     2. LINEAR LEAST SQUARES  --    SOLVE  A*X = B
C                                    IN THE LEAST-SQUARES SENSE
C
C     3. DAMPED LEAST SQUARES  --    SOLVE  (   A    )*X = ( B )
C                                           ( DAMP*I )     ( 0 )
C                                    IN THE LEAST-SQUARES SENSE
C
C     WHERE A IS A MATRIX WITH M ROWS AND N COLUMNS, B AN M-VECTOR,
C     AND DAMP A SCALAR. (ALL QUANTITIES ARE REAL.) THE MATRIX A IS
C     A SPARSE MATRIX STORED ROWWISE IN THE ARRAYS A,IA,JA.
C
C     THE RHS VECTOR B IS INPUT VIA U, AND IS SUBSEQUENTLY OVERWRITTEN.
C
C
C     NOTE. SPLSQ USES AN ITERATIVE METHOD TO APPROXIMATE THE SOLUTION.
C     THE NUMBER OF ITERATIONS REQUIRED TO REACH A CERTAIN ACCURACY
C     DEPENDS STRONGLY ON THE SCALING OF THE PROBLEM. POOR SCALING OF
C     THE ROWS OR COLUMNS OF A SHOULD THEREFORE BE AVOIDED WHENEVER
C     POSSIBLE.
C
C     FOR EXAMPLE, IN PROBLEM 1 THE SOLUTION IS UNALTERED BY
C     ROW-SCALING.  IF A ROW OF A IS VERY SMALL OR LARGE COMPARED TO
C     THE OTHER ROWS OF A, THE CORRESPONDING ROW OF (A  B) SHOULD BE
C     SCALED UP OR DOWN.
C
C     IN PROBLEMS 1 AND 2, THE SOLUTION X IS EASILY RECOVERED
C     FOLLOWING COLUMN SCALING. IN THE ABSENCE OF BETTER INFORMATION,
C     THE NONZERO COLUMNS OF A SHOULD BE SCALED SO THAT THEY ALL HAVE
C     THE SAME EUCLIDEAN NORM (E.G.  1.0).
C
C     IN PROBLEM 3, THERE IS NO FREEDOM TO RE-SCALE IF DAMP IS
C     NONZERO. HOWEVER, THE VALUE OF DAMP SHOULD BE ASSIGNED ONLY
C     AFTER ATTENTION HAS BEEN PAID TO THE SCALING OF A.
C
C     THE PARAMETER DAMP IS INTENDED TO HELP REGULARIZE
C     ILL-CONDITIONED SYSTEMS, BY PREVENTING THE TRUE SOLUTION FROM
C     BEING VERY LARGE. ANOTHER AID TO REGULARIZATION IS PROVIDED BY
C     THE PARAMETER ACOND, WHICH MAY BE USED TO TERMINATE ITERATIONS
C     BEFORE THE COMPUTED SOLUTION BECOMES VERY LARGE.
C
C
C     NOTATION
C     --------
C
C     THE FOLLOWING QUANTITIES ARE USED IN DISCUSSING THE SUBROUTINE
C     PARAMETERS...
C
C     ABAR   =  (   A    ),          BBAR  =  ( B )
C               ( DAMP*I )                    ( 0 )
C
C     R      =  B  -  A*X,           RBAR  =  BBAR  -  ABAR*X
C
C     RNORM  =  SQRT( NORM(R)**2  +  DAMP**2 * NORM(X)**2 )
C            =  NORM( RBAR )
C
C     RELPR  =  THE SMALLEST FLOATING POINT NUMBER FOR WHICH
C               1 + RELPR .GT. 1.
C
C     SPLSQ  MINIMIZES THE FUNCTION RNORM WITH RESPECT TO X.
C
C
C     PARAMETERS
C     ----------
C
C     M       INPUT      THE NUMBER OF ROWS IN A.
C
C     N       INPUT      THE NUMBER OF COLUMNS IN A.
C
C     A,IA,JA INPUT      THE MATRIX A STORED ROWWISE IN SPARSE FORM.
C
C     DAMP    INPUT      THE DAMPING PARAMETER FOR PROBLEM 3 ABOVE.
C                        (DAMP  SHOULD BE 0.0 FOR PROBLEMS 1 AND 2.)
C                        IF THE SYSTEM  A*X = B  IS INCOMPATIBLE, VALUES
C                        OF DAMP IN THE RANGE 0 TO SQRT(RELPR)*NORM(A)
C                        WILL PROBABLY HAVE A NEGLIGIBLE EFFECT.
C                        LARGER VALUES OF DAMP WILL TEND TO DECREASE
C                        THE NORM OF X AND TO REDUCE THE NUMBER OF
C                        ITERATIONS REQUIRED BY SPLSQ.
C
C                        THE WORK PER ITERATION AND THE STORAGE NEEDED
C                        BY SPLSQ ARE THE SAME FOR ALL VALUES OF DAMP.
C
C     U(M)    INPUT      THE RHS VECTOR B. BE AWARE THAT U IS
C                        OVER-WRITTEN BY SPLSQ.
C
C     X(N)    OUTPUT     RETURNS THE COMPUTED SOLUTION X.
C
C     ATOL    INPUT      AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA
C                        DEFINING THE MATRIX A. FOR EXAMPLE,
C                        IF A IS ACCURATE TO ABOUT 6 DIGITS, SET
C                        ATOL = 1.0E-6 .
C
C     BTOL    INPUT      AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA
C                        DEFINING THE RHS VECTOR B. FOR EXAMPLE,
C                        IF B IS ACCURATE TO ABOUT 6 DIGITS, SET
C                        BTOL = 1.0E-6 .
C
C     CONLIM  INPUT      AN UPPER LIMIT ON COND(ABAR), THE APPARENT
C                        CONDITION NUMBER OF THE MATRIX ABAR.
C                        ITERATIONS WILL BE TERMINATED IF A COMPUTED
C                        ESTIMATE OF COND(ABAR) EXCEEDS CONLIM.
C                        THIS IS INTENDED TO PREVENT CERTAIN SMALL OR
C                        ZERO SINGULAR VALUES OF A OR ABAR FROM
C                        COMING INTO EFFECT AND CAUSING UNWANTED GROWTH
C                        IN THE COMPUTED SOLUTION.
C
C                        CONLIM AND DAMP MAY BE USED SEPARATELY OR
C                        TOGETHER TO REGULARIZE ILL-CONDITIONED SYSTEMS.
C
C                        NORMALLY, CONLIM SHOULD BE IN THE RANGE
C                        1000  TO  1/RELPR.
C                        SUGGESTED VALUE --
C                        CONLIM = 1/(100*RELPR)  FOR COMPATIBLE SYSTEMS,
C                        CONLIM = 1/(10*SQRT(RELPR))  FOR LEAST SQUARES.
C
C             NOTE. IF THE USER IS NOT CONCERNED ABOUT THE PARAMETERS
C             ATOL, BTOL, AND CONLIM, ANY OR ALL OF THEM MAY BE SET
C             TO ZERO. THE EFFECT WILL BE THE SAME AS THE VALUES
C             RELPR, RELPR, AND  1/RELPR  RESPECTIVELY.
C
C     ITNLIM  INPUT      AN UPPER LIMIT ON THE NUMBER OF ITERATIONS.
C                        SUGGESTED VALUE --
C                        ITNLIM = N/2     FOR WELL CONDITIONED SYSTEMS,
C                        ITNLIM = 4*N     OTHERWISE.
C
C     ISTOP   OUTPUT     AN INTEGER GIVING THE REASON FOR TERMINATION...
C
C                0       X = 0  IS THE EXACT SOLUTION.
C                        NO ITERATIONS WERE PERFORMED.
C
C                1       THE EQUATIONS  A*X = B  ARE PROBABLY
C                        COMPATIBLE. NORM(A*X - B) IS SUFFICIENTLY
C                        SMALL, GIVEN THE VALUES OF ATOL AND BTOL.
C
C                2       THE SYSTEM  A*X = B  IS PROBABLY NOT
C                        COMPATIBLE. A LEAST-SQUARES SOLUTION HAS
C                        BEEN OBTAINED WHICH IS SUFFICIENTLY ACCURATE,
C                        GIVEN THE VALUE OF ATOL.
C
C                3       AN ESTIMATE OF COND(ABAR) HAS EXCEEDED
C                        CONLIM. THE SYSTEM  A*X = B  APPEARS TO BE
C                        ILL-CONDITIONED.
C
C                4       THE EQUATIONS  A*X = B  ARE PROBABLY
C                        COMPATIBLE. NORM(A*X - B) IS AS SMALL AS
C                        SEEMS REASONABLE ON THIS MACHINE.
C
C                5       THE SYSTEM  A*X = B  IS PROBABLY NOT
C                        COMPATIBLE. A LEAST-SQUARES SOLUTION HAS
C                        BEEN OBTAINED WHICH IS AS ACCURATE AS SEEMS
C                        REASONABLE ON THIS MACHINE.
C
C                6       COND(ABAR) SEEMS TO BE SO LARGE THAT THERE IS
C                        NOT MUCH POINT IN DOING FURTHER ITERATIONS,
C                        GIVEN THE PRECISION OF THIS MACHINE.
C
C                7       THE ITERATION LIMIT ITNLIM WAS REACHED.
C
C
C     ITN     OUTPUT     THE NUMBER OF ITERATIONS THAT WERE PERFORMED.
C
C     ACOND   OUTPUT     AN ESTIMATE OF COND(ABAR), THE CONDITION
C                        NUMBER OF ABAR.
C
C     RNORM   OUTPUT     AN ESTIMATE OF THE FINAL VALUE OF NORM(RBAR),
C                        THE FUNCTION BEING MINIMIZED (SEE NOTATION
C                        ABOVE). THIS WILL BE SMALL IF  A*X = B  HAS
C                        A SOLUTION.
C
C     XNORM   OUTPUT     AN ESTIMATE OF THE NORM OF THE FINAL
C                        SOLUTION VECTOR X.
C
C     W(2*N)             WORKSPACE
C
C     ANORM   LOCAL      AN ESTIMATE OF THE FROBENIUS NORM OF ABAR.
C                        THIS IS THE SQUARE ROOT OF THE SUM OF SQUARES
C                        OF THE ELEMENTS OF ABAR.
C                        IF DAMP IS SMALL AND IF THE COLUMNS OF A
C                        HAVE ALL BEEN SCALED TO HAVE LENGTH  1.0,
C                        ANORM SHOULD INCREASE TO ROUGHLY SQRT(N).
C
C     ARNORM  LOCAL      AN ESTIMATE OF THE FINAL VALUE OF
C                        NORM( ABAR(TRANSPOSE)*RBAR ), THE NORM OF
C                        THE RESIDUAL FOR THE USUAL NORMAL EQUATIONS.
C                        THIS SHOULD BE SMALL IN ALL CASES. (ARNORM
C                        WILL OFTEN BE SMALLER THAN THE TRUE VALUE
C                        COMPUTED FROM THE OUTPUT VECTOR X.)
C
C
C     SUBROUTINES AND FUNCTIONS USED
C     ------------------------------
C
C                NORMLZ,MVPRD1,MTPRD1
C     BLAS       SCOPY,SNRM2,SSCAL  (SEE LAWSON ET AL. BELOW)
C                (SNRM2 IS USED ONLY IN NORMLZ)
C     FORTRAN    ABS,SQRT
C
C
C     REFERENCES
C     ----------
C
C     PAIGE, C.C. AND SAUNDERS, M.A.  LSQR, AN ALGORITHM FOR SPARSE
C        LINEAR EQUATIONS AND SPARSE LEAST SQUARES.
C        ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 8, 1 (MARCH 1982).
C
C     LAWSON, C.L., HANSON, R.J., KINCAID, D.R. AND KROGH, F.T.
C        BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE.
C        ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 5, 3 (SEPT 1979),
C        308-323 AND 324-325.
C
C     ------------------------------------------------------------------
C
C     LOCAL VARIABLES
C
      INTEGER    I,ITN,NCONV,NSTOP
      REAL       ALFA,ANORM,ARNORM,BBNORM,BETA,BNORM,
     1           CS,CS1,CS2,CTOL,DAMPSQ,DDNORM,DELTA,
     2           GAMMA,GAMBAR,ONE,PHI,PHIBAR,PSI,
     3           RES1,RES2,RHO,RHOBAR,RHBAR1,RHBAR2,RHS,RTOL,
     4           SN,SN1,SN2,T,TAU,TEST1,TEST2,TEST3,
     5           THETA,T1,T2,T3,XXNORM,Z,ZBAR,ZERO
C
C
C     INITIALIZE.
C
      ZERO   = 0.0
      ONE    = 1.0
      CTOL   = ZERO
      IF (CONLIM .GT. ZERO) CTOL = ONE/CONLIM
      DAMPSQ = DAMP**2
      ANORM  = ZERO
      ACOND  = ZERO
      BBNORM = ZERO
      DDNORM = ZERO
      RES2   = ZERO
      XNORM  = ZERO
      XXNORM = ZERO
      CS2    = -ONE
      SN2    = ZERO
      Z      = ZERO
      ITN    = 0
      ISTOP  = 0
      NSTOP  = 0
C
      DO 10 I = 1, N
         W(I) = ZERO
         X(I) = ZERO
   10 CONTINUE
C
C     SET UP THE FIRST VECTORS FOR THE BIDIAGONALIZATION.
C     THESE SATISFY   BETA*U = B,   ALFA*W = A(TRANSPOSE)*U.
C
      CALL NORMLZ(M,U,BETA)
      CALL MTPRD1(M,N,A,IA,JA,U,W)
      CALL NORMLZ(N,W,ALFA)
      CALL SCOPY (N,W,1,W(N+1),1)
C
      RHOBAR = ALFA
      PHIBAR = BETA
      BNORM  = BETA
      RNORM  = BETA
      ARNORM = ALFA*BETA
      IF (ARNORM .LE. ZERO) GO TO 800
C
C     ------------------------------------------------------------------
C     MAIN ITERATION LOOP.
C     ------------------------------------------------------------------
  100 ITN = ITN + 1
C
C     PERFORM THE NEXT STEP OF THE BIDIAGONALIZATION TO OBTAIN THE
C     NEXT  BETA, U, ALFA, W.  THESE SATISFY THE RELATIONS
C                BETA*U  =  A*W  -  ALFA*U,
C                ALFA*W  =  A(TRANSPOSE)*U  -  BETA*W.
C
      CALL SSCAL (M,(-ALFA),U,1)
      CALL MVPRD1(M,N,A,IA,JA,W,U)
      CALL NORMLZ(M,U,BETA)
      BBNORM = BBNORM + ALFA**2 + BETA**2 + DAMPSQ
      CALL SSCAL (N,(-BETA),W,1)
      CALL MTPRD1(M,N,A,IA,JA,U,W)
      CALL NORMLZ(N,W,ALFA)
C
C
C     USE A PLANE ROTATION TO ELIMINATE THE DAMPING PARAMETER.
C     THIS ALTERS THE DIAGONAL (RHOBAR) OF THE LOWER-BIDIAGONAL MATRIX.
C
      RHBAR2 = RHOBAR**2 + DAMPSQ
      RHBAR1 = SQRT(RHBAR2)
      CS1    = RHOBAR/RHBAR1
      SN1    = DAMP/RHBAR1
      PSI    = SN1*PHIBAR
      PHIBAR = CS1*PHIBAR
C
C
C     USE A PLANE ROTATION TO ELIMINATE THE SUBDIAGONAL ELEMENT (BETA)
C     OF THE LOWER-BIDIAGONAL MATRIX, GIVING AN UPPER-BIDIAGONAL MATRIX.
C
      RHO    = SQRT(RHBAR2 + BETA**2)
      CS     = RHBAR1/RHO
      SN     = BETA/RHO
      THETA  =  SN*ALFA
      RHOBAR = -CS*ALFA
      PHI    =  CS*PHIBAR
      PHIBAR =  SN*PHIBAR
      TAU    =  SN*PHI
C
C
C     UPDATE X AND W(N+1),...,W(2*N)
C
      T1 =    PHI/RHO
      T2 = -THETA/RHO
      T3 =    ONE/RHO
C
      DO 200 I = 1, N
         NPI   = N + I
         T     = W(NPI)
         X(I)  = T1*T + X(I)
         W(NPI)= T2*T + W(I)
         T     =(T3*T)**2
         DDNORM= T + DDNORM
  200 CONTINUE
C
C
C     USE A PLANE ROTATION ON THE RIGHT TO ELIMINATE THE
C     SUPER-DIAGONAL ELEMENT (THETA) OF THE UPPER-BIDIAGONAL MATRIX.
C     THEN USE THE RESULT TO ESTIMATE NORM(X).
C
      DELTA  =  SN2*RHO
      GAMBAR = -CS2*RHO
      RHS    = PHI - DELTA*Z
      ZBAR   = RHS/GAMBAR
      XNORM  = SQRT(XXNORM + ZBAR**2)
      GAMMA  = SQRT(GAMBAR**2 + THETA**2)
      CS2    = GAMBAR/GAMMA
      SN2    = THETA/GAMMA
      Z      = RHS/GAMMA
      XXNORM = XXNORM + Z**2
C
C
C     TEST FOR CONVERGENCE.
C     FIRST, ESTIMATE THE NORM AND CONDITION OF THE MATRIX ABAR,
C     AND THE NORMS OF RBAR AND ABAR(TRANSPOSE)*RBAR.
C
      ANORM  = SQRT(BBNORM)
      ACOND  = ANORM*SQRT(DDNORM)
      RES1   = PHIBAR**2
      RES2   = RES2 + PSI**2
      RNORM  = SQRT(RES1 + RES2)
      ARNORM = ALFA*ABS(TAU)
C
C     NOW USE THESE NORMS TO ESTIMATE CERTAIN OTHER QUANTITIES,
C     SOME OF WHICH WILL BE SMALL NEAR A SOLUTION.
C
      TEST1  = RNORM/BNORM
      TEST2  = ARNORM/(ANORM*RNORM)
      TEST3  = ONE/ACOND
      T1     = TEST1/(ONE + ANORM*XNORM/BNORM)
      RTOL   = BTOL +  ATOL*ANORM*XNORM/BNORM
C
C     THE FOLLOWING TESTS GUARD AGAINST EXTREMELY SMALL VALUES OF
C     ATOL, BTOL, OR CTOL.  (THE USER MAY HAVE SET ANY OR ALL OF
C     THE PARAMETERS ATOL, BTOL, CONLIM TO ZERO.)
C     THE EFFECT IS EQUIVALENT TO THE NORMAL TESTS USING
C     ATOL = RELPR,  BTOL = RELPR,  CONLIM = 1/RELPR.
C
      T3 = ONE + TEST3
      T2 = ONE + TEST2
      T1 = ONE + T1
      IF (ITN .GE. ITNLIM) ISTOP = 7
      IF (T3  .LE. ONE   ) ISTOP = 6
      IF (T2  .LE. ONE   ) ISTOP = 5
      IF (T1  .LE. ONE   ) ISTOP = 4
C
C     ALLOW FOR TOLERANCES SET BY THE USER.
C
      IF (TEST3 .LE. CTOL) ISTOP = 3
      IF (TEST2 .LE. ATOL) ISTOP = 2
      IF (TEST1 .LE. RTOL) ISTOP = 1
C
C     STOP IF APPROPRIATE.
C     THE CONVERGENCE CRITERIA ARE REQUIRED TO BE MET ON  NCONV
C     CONSECUTIVE ITERATIONS, WHERE  NCONV  IS SET BELOW.
C     SUGGESTED VALUE --   NCONV = 1, 2  OR  3.
C
      IF (ISTOP .EQ. 0) NSTOP = 0
      IF (ISTOP .EQ. 0) GO TO 100
      NCONV = 1
      NSTOP = NSTOP + 1
      IF (NSTOP .LT. NCONV  .AND.  ITN .LT. ITNLIM) ISTOP = 0
      IF (ISTOP .EQ. 0) GO TO 100
C     ------------------------------------------------------------------
C     END OF ITERATION LOOP.
C     ------------------------------------------------------------------
C
  800 RETURN
      END
      SUBROUTINE NORMLZ(N,X,BETA)
      INTEGER N
      REAL X(N),BETA
C
C     NORMLZ COMPUTES THE EUCLIDEAN NORM OF X AND RETURNS THE
C     VALUE IN BETA. IF X IS NONZERO, THEN X IS RESCALED SO
C     THAT NORM(X) = 1.
C
C     FUNCTIONS AND SUBROUTINES
C
C     BLAS       SNRM2,SSCAL
C
      REAL       ONE,SNRM2,ZERO
C
      DATA ZERO/0.0/, ONE/1.0/
C
C
      BETA = SNRM2(N,X,1)
      IF (BETA .GT. ZERO) CALL SSCAL(N,(ONE/BETA),X,1)
      RETURN
      END
      SUBROUTINE STLSQ(M,N,TA,ITA,JTA,DAMP,U,X,ATOL,BTOL,CONLIM,
     *                 ITNLIM,ISTOP,ITN,ACOND,RNORM,XNORM,W)
C
      INTEGER M,N,ITNLIM,ISTOP
      INTEGER ITA(*),JTA(*)
      REAL    TA(*),DAMP,U(M),X(N),ATOL,BTOL,CONLIM,
     *        ACOND,RNORM,XNORM,W(*)
C     ------------------------------------------------------------------
C
C     STLSQ FINDS A SOLUTION X TO THE FOLLOWING PROBLEMS ...
C
C     1. UNSYMMETRIC EQUATIONS --    SOLVE  A*X = B
C
C     2. LINEAR LEAST SQUARES  --    SOLVE  A*X = B
C                                    IN THE LEAST-SQUARES SENSE
C
C     3. DAMPED LEAST SQUARES  --    SOLVE  (   A    )*X = ( B )
C                                           ( DAMP*I )     ( 0 )
C                                    IN THE LEAST-SQUARES SENSE
C
C     WHERE A IS A MATRIX WITH M ROWS AND N COLUMNS, B AN M-VECTOR,
C     AND DAMP A SCALAR. (ALL QUANTITIES ARE REAL.) THE MATRIX A IS
C     A SPARSE MATRIX WHOSE TRANSPOSE IS STORED ROWWISE IN THE ARRAYS
C     TA,ITA,JTA.
C
C     THE RHS VECTOR B IS INPUT VIA U, AND IS SUBSEQUENTLY OVERWRITTEN.
C
C
C     NOTE. STLSQ USES AN ITERATIVE METHOD TO APPROXIMATE THE SOLUTION.
C     THE NUMBER OF ITERATIONS REQUIRED TO REACH A CERTAIN ACCURACY
C     DEPENDS STRONGLY ON THE SCALING OF THE PROBLEM. POOR SCALING OF
C     THE ROWS OR COLUMNS OF A SHOULD THEREFORE BE AVOIDED WHENEVER
C     POSSIBLE.
C
C     FOR EXAMPLE, IN PROBLEM 1 THE SOLUTION IS UNALTERED BY
C     ROW-SCALING.  IF A ROW OF A IS VERY SMALL OR LARGE COMPARED TO
C     THE OTHER ROWS OF A, THE CORRESPONDING ROW OF (A  B) SHOULD BE
C     SCALED UP OR DOWN.
C
C     IN PROBLEMS 1 AND 2, THE SOLUTION X IS EASILY RECOVERED
C     FOLLOWING COLUMN SCALING. IN THE ABSENCE OF BETTER INFORMATION,
C     THE NONZERO COLUMNS OF A SHOULD BE SCALED SO THAT THEY ALL HAVE
C     THE SAME EUCLIDEAN NORM (E.G.  1.0).
C
C     IN PROBLEM 3, THERE IS NO FREEDOM TO RE-SCALE IF DAMP IS
C     NONZERO. HOWEVER, THE VALUE OF DAMP SHOULD BE ASSIGNED ONLY
C     AFTER ATTENTION HAS BEEN PAID TO THE SCALING OF A.
C
C     THE PARAMETER DAMP IS INTENDED TO HELP REGULARIZE
C     ILL-CONDITIONED SYSTEMS, BY PREVENTING THE TRUE SOLUTION FROM
C     BEING VERY LARGE. ANOTHER AID TO REGULARIZATION IS PROVIDED BY
C     THE PARAMETER ACOND, WHICH MAY BE USED TO TERMINATE ITERATIONS
C     BEFORE THE COMPUTED SOLUTION BECOMES VERY LARGE.
C
C
C     NOTATION
C     --------
C
C     THE FOLLOWING QUANTITIES ARE USED IN DISCUSSING THE SUBROUTINE
C     PARAMETERS...
C
C     ABAR   =  (   A    ),          BBAR  =  ( B )
C               ( DAMP*I )                    ( 0 )
C
C     R      =  B  -  A*X,           RBAR  =  BBAR  -  ABAR*X
C
C     RNORM  =  SQRT( NORM(R)**2  +  DAMP**2 * NORM(X)**2 )
C            =  NORM( RBAR )
C
C     RELPR  =  THE SMALLEST FLOATING POINT NUMBER FOR WHICH
C               1 + RELPR .GT. 1.
C
C     STLSQ  MINIMIZES THE FUNCTION RNORM WITH RESPECT TO X.
C
C
C     PARAMETERS
C     ----------
C
C     M       INPUT      THE NUMBER OF ROWS IN A.
C
C     N       INPUT      THE NUMBER OF COLUMNS IN A.
C
C     TA,ITA  INPUT      THE TRANSPOSE OF THE MATRIX A IS STORED
C      JTA               ROWWISE IN SPARSE FORM.
C
C     DAMP    INPUT      THE DAMPING PARAMETER FOR PROBLEM 3 ABOVE.
C                        (DAMP  SHOULD BE 0.0 FOR PROBLEMS 1 AND 2.)
C                        IF THE SYSTEM  A*X = B  IS INCOMPATIBLE, VALUES
C                        OF DAMP IN THE RANGE 0 TO SQRT(RELPR)*NORM(A)
C                        WILL PROBABLY HAVE A NEGLIGIBLE EFFECT.
C                        LARGER VALUES OF DAMP WILL TEND TO DECREASE
C                        THE NORM OF X AND TO REDUCE THE NUMBER OF
C                        ITERATIONS REQUIRED BY STLSQ.
C
C                        THE WORK PER ITERATION AND THE STORAGE NEEDED
C                        BY STLSQ ARE THE SAME FOR ALL VALUES OF DAMP.
C
C     U(M)    INPUT      THE RHS VECTOR B. BE AWARE THAT U IS
C                        OVER-WRITTEN BY STLSQ.
C
C     X(N)    OUTPUT     RETURNS THE COMPUTED SOLUTION X.
C
C     ATOL    INPUT      AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA
C                        DEFINING THE MATRIX A. FOR EXAMPLE,
C                        IF A IS ACCURATE TO ABOUT 6 DIGITS, SET
C                        ATOL = 1.0E-6 .
C
C     BTOL    INPUT      AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA
C                        DEFINING THE RHS VECTOR B. FOR EXAMPLE,
C                        IF B IS ACCURATE TO ABOUT 6 DIGITS, SET
C                        BTOL = 1.0E-6 .
C
C     CONLIM  INPUT      AN UPPER LIMIT ON COND(ABAR), THE APPARENT
C                        CONDITION NUMBER OF THE MATRIX ABAR.
C                        ITERATIONS WILL BE TERMINATED IF A COMPUTED
C                        ESTIMATE OF COND(ABAR) EXCEEDS CONLIM.
C                        THIS IS INTENDED TO PREVENT CERTAIN SMALL OR
C                        ZERO SINGULAR VALUES OF A OR ABAR FROM
C                        COMING INTO EFFECT AND CAUSING UNWANTED GROWTH
C                        IN THE COMPUTED SOLUTION.
C
C                        CONLIM AND DAMP MAY BE USED SEPARATELY OR
C                        TOGETHER TO REGULARIZE ILL-CONDITIONED SYSTEMS.
C
C                        NORMALLY, CONLIM SHOULD BE IN THE RANGE
C                        1000  TO  1/RELPR.
C                        SUGGESTED VALUE --
C                        CONLIM = 1/(100*RELPR)  FOR COMPATIBLE SYSTEMS,
C                        CONLIM = 1/(10*SQRT(RELPR))  FOR LEAST SQUARES.
C
C             NOTE. IF THE USER IS NOT CONCERNED ABOUT THE PARAMETERS
C             ATOL, BTOL, AND CONLIM, ANY OR ALL OF THEM MAY BE SET
C             TO ZERO. THE EFFECT WILL BE THE SAME AS THE VALUES
C             RELPR, RELPR, AND  1/RELPR  RESPECTIVELY.
C
C     ITNLIM  INPUT      AN UPPER LIMIT ON THE NUMBER OF ITERATIONS.
C                        SUGGESTED VALUE --
C                        ITNLIM = N/2     FOR WELL CONDITIONED SYSTEMS,
C                        ITNLIM = 4*N     OTHERWISE.
C
C     ISTOP   OUTPUT     AN INTEGER GIVING THE REASON FOR TERMINATION...
C
C                0       X = 0  IS THE EXACT SOLUTION.
C                        NO ITERATIONS WERE PERFORMED.
C
C                1       THE EQUATIONS  A*X = B  ARE PROBABLY
C                        COMPATIBLE. NORM(A*X - B) IS SUFFICIENTLY
C                        SMALL, GIVEN THE VALUES OF ATOL AND BTOL.
C
C                2       THE SYSTEM  A*X = B  IS PROBABLY NOT
C                        COMPATIBLE. A LEAST-SQUARES SOLUTION HAS
C                        BEEN OBTAINED WHICH IS SUFFICIENTLY ACCURATE,
C                        GIVEN THE VALUE OF ATOL.
C
C                3       AN ESTIMATE OF COND(ABAR) HAS EXCEEDED
C                        CONLIM. THE SYSTEM  A*X = B  APPEARS TO BE
C                        ILL-CONDITIONED.
C
C                4       THE EQUATIONS  A*X = B  ARE PROBABLY
C                        COMPATIBLE. NORM(A*X - B) IS AS SMALL AS
C                        SEEMS REASONABLE ON THIS MACHINE.
C
C                5       THE SYSTEM  A*X = B  IS PROBABLY NOT
C                        COMPATIBLE. A LEAST-SQUARES SOLUTION HAS
C                        BEEN OBTAINED WHICH IS AS ACCURATE AS SEEMS
C                        REASONABLE ON THIS MACHINE.
C
C                6       COND(ABAR) SEEMS TO BE SO LARGE THAT THERE IS
C                        NOT MUCH POINT IN DOING FURTHER ITERATIONS,
C                        GIVEN THE PRECISION OF THIS MACHINE.
C
C                7       THE ITERATION LIMIT ITNLIM WAS REACHED.
C
C
C     ITN     OUTPUT     THE NUMBER OF ITERATIONS THAT WERE PERFORMED.
C
C     ACOND   OUTPUT     AN ESTIMATE OF COND(ABAR), THE CONDITION
C                        NUMBER OF ABAR.
C
C     RNORM   OUTPUT     AN ESTIMATE OF THE FINAL VALUE OF NORM(RBAR),
C                        THE FUNCTION BEING MINIMIZED (SEE NOTATION
C                        ABOVE). THIS WILL BE SMALL IF  A*X = B  HAS
C                        A SOLUTION.
C
C     XNORM   OUTPUT     AN ESTIMATE OF THE NORM OF THE FINAL
C                        SOLUTION VECTOR X.
C
C     W(2*N)             WORKSPACE
C
C     ANORM   LOCAL      AN ESTIMATE OF THE FROBENIUS NORM OF ABAR.
C                        THIS IS THE SQUARE ROOT OF THE SUM OF SQUARES
C                        OF THE ELEMENTS OF ABAR.
C                        IF DAMP IS SMALL AND IF THE COLUMNS OF A
C                        HAVE ALL BEEN SCALED TO HAVE LENGTH  1.0,
C                        ANORM SHOULD INCREASE TO ROUGHLY SQRT(N).
C
C     ARNORM  LOCAL      AN ESTIMATE OF THE FINAL VALUE OF
C                        NORM( ABAR(TRANSPOSE)*RBAR ), THE NORM OF
C                        THE RESIDUAL FOR THE USUAL NORMAL EQUATIONS.
C                        THIS SHOULD BE SMALL IN ALL CASES. (ARNORM
C                        WILL OFTEN BE SMALLER THAN THE TRUE VALUE
C                        COMPUTED FROM THE OUTPUT VECTOR X.)
C
C
C     SUBROUTINES AND FUNCTIONS USED
C     ------------------------------
C
C                NORMLZ,MVPRD1,MTPRD1
C     BLAS       SCOPY,SNRM2,SSCAL  (SEE LAWSON ET AL. BELOW)
C                (SNRM2 IS USED ONLY IN NORMLZ)
C     FORTRAN    ABS,SQRT
C
C
C     REFERENCES
C     ----------
C
C     PAIGE, C.C. AND SAUNDERS, M.A.  LSQR, AN ALGORITHM FOR SPARSE
C        LINEAR EQUATIONS AND SPARSE LEAST SQUARES.
C        ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 8, 1 (MARCH 1982).
C
C     LAWSON, C.L., HANSON, R.J., KINCAID, D.R. AND KROGH, F.T.
C        BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE.
C        ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 5, 3 (SEPT 1979),
C        308-323 AND 324-325.
C
C     ------------------------------------------------------------------
C
C     LOCAL VARIABLES
C
      INTEGER    I,ITN,NCONV,NSTOP
      REAL       ALFA,ANORM,ARNORM,BBNORM,BETA,BNORM,
     1           CS,CS1,CS2,CTOL,DAMPSQ,DDNORM,DELTA,
     2           GAMMA,GAMBAR,ONE,PHI,PHIBAR,PSI,
     3           RES1,RES2,RHO,RHOBAR,RHBAR1,RHBAR2,RHS,RTOL,
     4           SN,SN1,SN2,T,TAU,TEST1,TEST2,TEST3,
     5           THETA,T1,T2,T3,XXNORM,Z,ZBAR,ZERO
C
C
C     INITIALIZE.
C
      ZERO   = 0.0
      ONE    = 1.0
      CTOL   = ZERO
      IF (CONLIM .GT. ZERO) CTOL = ONE/CONLIM
      DAMPSQ = DAMP**2
      ANORM  = ZERO
      ACOND  = ZERO
      BBNORM = ZERO
      DDNORM = ZERO
      RES2   = ZERO
      XNORM  = ZERO
      XXNORM = ZERO
      CS2    = -ONE
      SN2    = ZERO
      Z      = ZERO
      ITN    = 0
      ISTOP  = 0
      NSTOP  = 0
C
      DO 10 I = 1, N
         W(I) = ZERO
         X(I) = ZERO
   10 CONTINUE
C
C     SET UP THE FIRST VECTORS FOR THE BIDIAGONALIZATION.
C     THESE SATISFY   BETA*U = B,   ALFA*W = A(TRANSPOSE)*U.
C
      CALL NORMLZ(M,U,BETA)
      CALL MVPRD1(N,M,TA,ITA,JTA,U,W)
      CALL NORMLZ(N,W,ALFA)
      CALL SCOPY (N,W,1,W(N+1),1)
C
      RHOBAR = ALFA
      PHIBAR = BETA
      BNORM  = BETA
      RNORM  = BETA
      ARNORM = ALFA*BETA
      IF (ARNORM .LE. ZERO) GO TO 800
C
C     ------------------------------------------------------------------
C     MAIN ITERATION LOOP.
C     ------------------------------------------------------------------
  100 ITN = ITN + 1
C
C     PERFORM THE NEXT STEP OF THE BIDIAGONALIZATION TO OBTAIN THE
C     NEXT  BETA, U, ALFA, W.  THESE SATISFY THE RELATIONS
C                BETA*U  =  A*W  -  ALFA*U,
C                ALFA*W  =  A(TRANSPOSE)*U  -  BETA*W.
C
      CALL SSCAL (M,(-ALFA),U,1)
      CALL MTPRD1(N,M,TA,ITA,JTA,W,U)
      CALL NORMLZ(M,U,BETA)
      BBNORM = BBNORM + ALFA**2 + BETA**2 + DAMPSQ
      CALL SSCAL (N,(-BETA),W,1)
      CALL MVPRD1(N,M,TA,ITA,JTA,U,W)
      CALL NORMLZ(N,W,ALFA)
C
C
C     USE A PLANE ROTATION TO ELIMINATE THE DAMPING PARAMETER.
C     THIS ALTERS THE DIAGONAL (RHOBAR) OF THE LOWER-BIDIAGONAL MATRIX.
C
      RHBAR2 = RHOBAR**2 + DAMPSQ
      RHBAR1 = SQRT(RHBAR2)
      CS1    = RHOBAR/RHBAR1
      SN1    = DAMP/RHBAR1
      PSI    = SN1*PHIBAR
      PHIBAR = CS1*PHIBAR
C
C
C     USE A PLANE ROTATION TO ELIMINATE THE SUBDIAGONAL ELEMENT (BETA)
C     OF THE LOWER-BIDIAGONAL MATRIX, GIVING AN UPPER-BIDIAGONAL MATRIX.
C
      RHO    = SQRT(RHBAR2 + BETA**2)
      CS     = RHBAR1/RHO
      SN     = BETA/RHO
      THETA  =  SN*ALFA
      RHOBAR = -CS*ALFA
      PHI    =  CS*PHIBAR
      PHIBAR =  SN*PHIBAR
      TAU    =  SN*PHI
C
C
C     UPDATE X AND W(N+1),...,W(2*N)
C
      T1 =    PHI/RHO
      T2 = -THETA/RHO
      T3 =    ONE/RHO
C
      DO 200 I = 1, N
         NPI   = N + I
         T     = W(NPI)
         X(I)  = T1*T + X(I)
         W(NPI)= T2*T + W(I)
         T     =(T3*T)**2
         DDNORM= T + DDNORM
  200 CONTINUE
C
C
C     USE A PLANE ROTATION ON THE RIGHT TO ELIMINATE THE
C     SUPER-DIAGONAL ELEMENT (THETA) OF THE UPPER-BIDIAGONAL MATRIX.
C     THEN USE THE RESULT TO ESTIMATE NORM(X).
C
      DELTA  =  SN2*RHO
      GAMBAR = -CS2*RHO
      RHS    = PHI - DELTA*Z
      ZBAR   = RHS/GAMBAR
      XNORM  = SQRT(XXNORM + ZBAR**2)
      GAMMA  = SQRT(GAMBAR**2 + THETA**2)
      CS2    = GAMBAR/GAMMA
      SN2    = THETA/GAMMA
      Z      = RHS/GAMMA
      XXNORM = XXNORM + Z**2
C
C
C     TEST FOR CONVERGENCE.
C     FIRST, ESTIMATE THE NORM AND CONDITION OF THE MATRIX ABAR,
C     AND THE NORMS OF RBAR AND ABAR(TRANSPOSE)*RBAR.
C
      ANORM  = SQRT(BBNORM)
      ACOND  = ANORM*SQRT(DDNORM)
      RES1   = PHIBAR**2
      RES2   = RES2 + PSI**2
      RNORM  = SQRT(RES1 + RES2)
      ARNORM = ALFA*ABS(TAU)
C
C     NOW USE THESE NORMS TO ESTIMATE CERTAIN OTHER QUANTITIES,
C     SOME OF WHICH WILL BE SMALL NEAR A SOLUTION.
C
      TEST1  = RNORM/BNORM
      TEST2  = ARNORM/(ANORM*RNORM)
      TEST3  = ONE/ACOND
      T1     = TEST1/(ONE + ANORM*XNORM/BNORM)
      RTOL   = BTOL +  ATOL*ANORM*XNORM/BNORM
C
C     THE FOLLOWING TESTS GUARD AGAINST EXTREMELY SMALL VALUES OF
C     ATOL, BTOL, OR CTOL.  (THE USER MAY HAVE SET ANY OR ALL OF
C     THE PARAMETERS ATOL, BTOL, CONLIM TO ZERO.)
C     THE EFFECT IS EQUIVALENT TO THE NORMAL TESTS USING
C     ATOL = RELPR,  BTOL = RELPR,  CONLIM = 1/RELPR.
C
      T3 = ONE + TEST3
      T2 = ONE + TEST2
      T1 = ONE + T1
      IF (ITN .GE. ITNLIM) ISTOP = 7
      IF (T3  .LE. ONE   ) ISTOP = 6
      IF (T2  .LE. ONE   ) ISTOP = 5
      IF (T1  .LE. ONE   ) ISTOP = 4
C
C     ALLOW FOR TOLERANCES SET BY THE USER.
C
      IF (TEST3 .LE. CTOL) ISTOP = 3
      IF (TEST2 .LE. ATOL) ISTOP = 2
      IF (TEST1 .LE. RTOL) ISTOP = 1
C
C     STOP IF APPROPRIATE.
C     THE CONVERGENCE CRITERIA ARE REQUIRED TO BE MET ON  NCONV
C     CONSECUTIVE ITERATIONS, WHERE  NCONV  IS SET BELOW.
C     SUGGESTED VALUE --   NCONV = 1, 2  OR  3.
C
      IF (ISTOP .EQ. 0) NSTOP = 0
      IF (ISTOP .EQ. 0) GO TO 100
      NCONV = 1
      NSTOP = NSTOP + 1
      IF (NSTOP .LT. NCONV  .AND.  ITN .LT. ITNLIM) ISTOP = 0
      IF (ISTOP .EQ. 0) GO TO 100
C     ------------------------------------------------------------------
C     END OF ITERATION LOOP.
C     ------------------------------------------------------------------
C
  800 RETURN
      END
      SUBROUTINE BLSQ(M,N,A,KA,ML,MU,DAMP,U,X,ATOL,BTOL,CONLIM,ITNLIM,
     *                     ISTOP,ITN,ACOND,RNORM,XNORM,W)
C
      INTEGER M,N,KA,ML,MU,ITNLIM,ISTOP
      REAL    A(KA,N),DAMP,U(M),X(N),ATOL,BTOL,CONLIM,
     *        ACOND,RNORM,XNORM,W(*)
C     ------------------------------------------------------------------
C
C     BLSQ FINDS A SOLUTION X TO THE FOLLOWING PROBLEMS ...
C
C     1. UNSYMMETRIC EQUATIONS --    SOLVE  A*X = B
C
C     2. LINEAR LEAST SQUARES  --    SOLVE  A*X = B
C                                    IN THE LEAST-SQUARES SENSE
C
C     3. DAMPED LEAST SQUARES  --    SOLVE  (   A    )*X = ( B )
C                                           ( DAMP*I )     ( 0 )
C                                    IN THE LEAST-SQUARES SENSE
C
C     WHERE A IS A MATRIX WITH M ROWS AND N COLUMNS, B AN M-VECTOR,
C     AND DAMP A SCALAR. (ALL QUANTITIES ARE REAL.) THE MATRIX A IS
C     A BANDED MATRIX STORED IN BAND FORM.
C
C     THE RHS VECTOR B IS INPUT VIA U, AND IS SUBSEQUENTLY OVERWRITTEN.
C
C
C     NOTE. BLSQ USES AN ITERATIVE METHOD TO APPROXIMATE THE SOLUTION.
C     THE NUMBER OF ITERATIONS REQUIRED TO REACH A CERTAIN ACCURACY
C     DEPENDS STRONGLY ON THE SCALING OF THE PROBLEM. POOR SCALING OF
C     THE ROWS OR COLUMNS OF A SHOULD THEREFORE BE AVOIDED WHENEVER
C     POSSIBLE.
C
C     FOR EXAMPLE, IN PROBLEM 1 THE SOLUTION IS UNALTERED BY
C     ROW-SCALING.  IF A ROW OF A IS VERY SMALL OR LARGE COMPARED TO
C     THE OTHER ROWS OF A, THE CORRESPONDING ROW OF (A  B) SHOULD BE
C     SCALED UP OR DOWN.
C
C     IN PROBLEMS 1 AND 2, THE SOLUTION X IS EASILY RECOVERED
C     FOLLOWING COLUMN SCALING. IN THE ABSENCE OF BETTER INFORMATION,
C     THE NONZERO COLUMNS OF A SHOULD BE SCALED SO THAT THEY ALL HAVE
C     THE SAME EUCLIDEAN NORM (E.G.  1.0).
C
C     IN PROBLEM 3, THERE IS NO FREEDOM TO RE-SCALE IF DAMP IS
C     NONZERO. HOWEVER, THE VALUE OF DAMP SHOULD BE ASSIGNED ONLY
C     AFTER ATTENTION HAS BEEN PAID TO THE SCALING OF A.
C
C     THE PARAMETER DAMP IS INTENDED TO HELP REGULARIZE
C     ILL-CONDITIONED SYSTEMS, BY PREVENTING THE TRUE SOLUTION FROM
C     BEING VERY LARGE. ANOTHER AID TO REGULARIZATION IS PROVIDED BY
C     THE PARAMETER ACOND, WHICH MAY BE USED TO TERMINATE ITERATIONS
C     BEFORE THE COMPUTED SOLUTION BECOMES VERY LARGE.
C
C
C     NOTATION
C     --------
C
C     THE FOLLOWING QUANTITIES ARE USED IN DISCUSSING THE SUBROUTINE
C     PARAMETERS...
C
C     ABAR   =  (   A    ),          BBAR  =  ( B )
C               ( DAMP*I )                    ( 0 )
C
C     R      =  B  -  A*X,           RBAR  =  BBAR  -  ABAR*X
C
C     RNORM  =  SQRT( NORM(R)**2  +  DAMP**2 * NORM(X)**2 )
C            =  NORM( RBAR )
C
C     RELPR  =  THE SMALLEST FLOATING POINT NUMBER FOR WHICH
C               1 + RELPR .GT. 1.
C
C     BLSQ   MINIMIZES THE FUNCTION RNORM WITH RESPECT TO X.
C
C
C     PARAMETERS
C     ----------
C
C     M       INPUT      THE NUMBER OF ROWS IN A.
C
C     N       INPUT      THE NUMBER OF COLUMNS IN A.
C
C     A       INPUT      THE MATRIX A STORED IN BAND FORM.
C
C     KA      INPUT      THE NUMBER OF ROWS IN THE DIMENSION STATEMENT
C                        FOR A IN THE CALLING PROGRAM.
C
C     ML      INPUT      THE LOWER BAND WIDTH OF A.
C
C     MU      INPUT      THE UPPER BAND WIDTH OF A.
C
C     DAMP    INPUT      THE DAMPING PARAMETER FOR PROBLEM 3 ABOVE.
C                        (DAMP  SHOULD BE 0.0 FOR PROBLEMS 1 AND 2.)
C                        IF THE SYSTEM  A*X = B  IS INCOMPATIBLE, VALUES
C                        OF DAMP IN THE RANGE 0 TO SQRT(RELPR)*NORM(A)
C                        WILL PROBABLY HAVE A NEGLIGIBLE EFFECT.
C                        LARGER VALUES OF DAMP WILL TEND TO DECREASE
C                        THE NORM OF X AND TO REDUCE THE NUMBER OF
C                        ITERATIONS REQUIRED BY BLSQ.
C
C                        THE WORK PER ITERATION AND THE STORAGE NEEDED
C                        BY BLSQ ARE THE SAME FOR ALL VALUES OF DAMP.
C
C     U(M)    INPUT      THE RHS VECTOR B. BE AWARE THAT U IS
C                        OVER-WRITTEN BY BLSQ.
C
C     X(N)    OUTPUT     RETURNS THE COMPUTED SOLUTION X.
C
C     ATOL    INPUT      AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA
C                        DEFINING THE MATRIX A. FOR EXAMPLE,
C                        IF A IS ACCURATE TO ABOUT 6 DIGITS, SET
C                        ATOL = 1.0E-6 .
C
C     BTOL    INPUT      AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA
C                        DEFINING THE RHS VECTOR B. FOR EXAMPLE,
C                        IF B IS ACCURATE TO ABOUT 6 DIGITS, SET
C                        BTOL = 1.0E-6 .
C
C     CONLIM  INPUT      AN UPPER LIMIT ON COND(ABAR), THE APPARENT
C                        CONDITION NUMBER OF THE MATRIX ABAR.
C                        ITERATIONS WILL BE TERMINATED IF A COMPUTED
C                        ESTIMATE OF COND(ABAR) EXCEEDS CONLIM.
C                        THIS IS INTENDED TO PREVENT CERTAIN SMALL OR
C                        ZERO SINGULAR VALUES OF A OR ABAR FROM
C                        COMING INTO EFFECT AND CAUSING UNWANTED GROWTH
C                        IN THE COMPUTED SOLUTION.
C
C                        CONLIM AND DAMP MAY BE USED SEPARATELY OR
C                        TOGETHER TO REGULARIZE ILL-CONDITIONED SYSTEMS.
C
C                        NORMALLY, CONLIM SHOULD BE IN THE RANGE
C                        1000  TO  1/RELPR.
C                        SUGGESTED VALUE --
C                        CONLIM = 1/(100*RELPR)  FOR COMPATIBLE SYSTEMS,
C                        CONLIM = 1/(10*SQRT(RELPR))  FOR LEAST SQUARES.
C
C             NOTE. IF THE USER IS NOT CONCERNED ABOUT THE PARAMETERS
C             ATOL, BTOL, AND CONLIM, ANY OR ALL OF THEM MAY BE SET
C             TO ZERO. THE EFFECT WILL BE THE SAME AS THE VALUES
C             RELPR, RELPR, AND  1/RELPR  RESPECTIVELY.
C
C     ITNLIM  INPUT      AN UPPER LIMIT ON THE NUMBER OF ITERATIONS.
C                        SUGGESTED VALUE --
C                        ITNLIM = N/2     FOR WELL CONDITIONED SYSTEMS,
C                        ITNLIM = 4*N     OTHERWISE.
C
C     ISTOP   OUTPUT     AN INTEGER GIVING THE REASON FOR TERMINATION...
C
C                0       X = 0  IS THE EXACT SOLUTION.
C                        NO ITERATIONS WERE PERFORMED.
C
C                1       THE EQUATIONS  A*X = B  ARE PROBABLY
C                        COMPATIBLE. NORM(A*X - B) IS SUFFICIENTLY
C                        SMALL, GIVEN THE VALUES OF ATOL AND BTOL.
C
C                2       THE SYSTEM  A*X = B  IS PROBABLY NOT
C                        COMPATIBLE. A LEAST-SQUARES SOLUTION HAS
C                        BEEN OBTAINED WHICH IS SUFFICIENTLY ACCURATE,
C                        GIVEN THE VALUE OF ATOL.
C
C                3       AN ESTIMATE OF COND(ABAR) HAS EXCEEDED
C                        CONLIM. THE SYSTEM  A*X = B  APPEARS TO BE
C                        ILL-CONDITIONED.
C
C                4       THE EQUATIONS  A*X = B  ARE PROBABLY
C                        COMPATIBLE. NORM(A*X - B) IS AS SMALL AS
C                        SEEMS REASONABLE ON THIS MACHINE.
C
C                5       THE SYSTEM  A*X = B  IS PROBABLY NOT
C                        COMPATIBLE. A LEAST-SQUARES SOLUTION HAS
C                        BEEN OBTAINED WHICH IS AS ACCURATE AS SEEMS
C                        REASONABLE ON THIS MACHINE.
C
C                6       COND(ABAR) SEEMS TO BE SO LARGE THAT THERE IS
C                        NOT MUCH POINT IN DOING FURTHER ITERATIONS,
C                        GIVEN THE PRECISION OF THIS MACHINE.
C
C                7       THE ITERATION LIMIT ITNLIM WAS REACHED.
C
C
C     ITN     OUTPUT     THE NUMBER OF ITERATIONS THAT WERE PERFORMED.
C
C     ACOND   OUTPUT     AN ESTIMATE OF COND(ABAR), THE CONDITION
C                        NUMBER OF ABAR.
C
C     RNORM   OUTPUT     AN ESTIMATE OF THE FINAL VALUE OF NORM(RBAR),
C                        THE FUNCTION BEING MINIMIZED (SEE NOTATION
C                        ABOVE). THIS WILL BE SMALL IF  A*X = B  HAS
C                        A SOLUTION.
C
C     XNORM   OUTPUT     AN ESTIMATE OF THE NORM OF THE FINAL
C                        SOLUTION VECTOR X.
C
C     W(2*N)             WORKSPACE
C
C     ANORM   LOCAL      AN ESTIMATE OF THE FROBENIUS NORM OF ABAR.
C                        THIS IS THE SQUARE ROOT OF THE SUM OF SQUARES
C                        OF THE ELEMENTS OF ABAR.
C                        IF DAMP IS SMALL AND IF THE COLUMNS OF A
C                        HAVE ALL BEEN SCALED TO HAVE LENGTH  1.0,
C                        ANORM SHOULD INCREASE TO ROUGHLY SQRT(N).
C
C     ARNORM  LOCAL      AN ESTIMATE OF THE FINAL VALUE OF
C                        NORM( ABAR(TRANSPOSE)*RBAR ), THE NORM OF
C                        THE RESIDUAL FOR THE USUAL NORMAL EQUATIONS.
C                        THIS SHOULD BE SMALL IN ALL CASES. (ARNORM
C                        WILL OFTEN BE SMALLER THAN THE TRUE VALUE
C                        COMPUTED FROM THE OUTPUT VECTOR X.)
C
C
C     SUBROUTINES AND FUNCTIONS USED
C     ------------------------------
C
C                NORMLZ,BVPRD1,BTPRD1
C     BLAS       SCOPY,SNRM2,SSCAL  (SEE LAWSON ET AL. BELOW)
C                (SNRM2 IS USED ONLY IN NORMLZ)
C     FORTRAN    ABS,SQRT
C
C
C     REFERENCES
C     ----------
C
C     PAIGE, C.C. AND SAUNDERS, M.A.  LSQR, AN ALGORITHM FOR SPARSE
C        LINEAR EQUATIONS AND SPARSE LEAST SQUARES.
C        ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 8, 1 (MARCH 1982).
C
C     LAWSON, C.L., HANSON, R.J., KINCAID, D.R. AND KROGH, F.T.
C        BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE.
C        ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 5, 3 (SEPT 1979),
C        308-323 AND 324-325.
C
C     ------------------------------------------------------------------
C
C     LOCAL VARIABLES
C
      INTEGER    I,ITN,NCONV,NSTOP
      REAL       ALFA,ANORM,ARNORM,BBNORM,BETA,BNORM,
     1           CS,CS1,CS2,CTOL,DAMPSQ,DDNORM,DELTA,
     2           GAMMA,GAMBAR,ONE,PHI,PHIBAR,PSI,
     3           RES1,RES2,RHO,RHOBAR,RHBAR1,RHBAR2,RHS,RTOL,
     4           SN,SN1,SN2,T,TAU,TEST1,TEST2,TEST3,
     5           THETA,T1,T2,T3,XXNORM,Z,ZBAR,ZERO
C
C
C     INITIALIZE.
C
      ZERO   = 0.0
      ONE    = 1.0
      CTOL   = ZERO
      IF (CONLIM .GT. ZERO) CTOL = ONE/CONLIM
      DAMPSQ = DAMP**2
      ANORM  = ZERO
      ACOND  = ZERO
      BBNORM = ZERO
      DDNORM = ZERO
      RES2   = ZERO
      XNORM  = ZERO
      XXNORM = ZERO
      CS2    = -ONE
      SN2    = ZERO
      Z      = ZERO
      ITN    = 0
      ISTOP  = 0
      NSTOP  = 0
C
      DO 10 I = 1, N
         W(I) = ZERO
         X(I) = ZERO
   10 CONTINUE
C
C     SET UP THE FIRST VECTORS FOR THE BIDIAGONALIZATION.
C     THESE SATISFY   BETA*U = B,   ALFA*W = A(TRANSPOSE)*U.
C
      CALL NORMLZ(M,U,BETA)
      CALL BTPRD1(M,N,A,KA,ML,MU,U,W)
      CALL NORMLZ(N,W,ALFA)
      CALL SCOPY (N,W,1,W(N+1),1)
C
      RHOBAR = ALFA
      PHIBAR = BETA
      BNORM  = BETA
      RNORM  = BETA
      ARNORM = ALFA*BETA
      IF (ARNORM .LE. ZERO) GO TO 800
C
C     ------------------------------------------------------------------
C     MAIN ITERATION LOOP.
C     ------------------------------------------------------------------
  100 ITN = ITN + 1
C
C     PERFORM THE NEXT STEP OF THE BIDIAGONALIZATION TO OBTAIN THE
C     NEXT  BETA, U, ALFA, W.  THESE SATISFY THE RELATIONS
C                BETA*U  =  A*W  -  ALFA*U,
C                ALFA*W  =  A(TRANSPOSE)*U  -  BETA*W.
C
      CALL SSCAL (M,(-ALFA),U,1)
      CALL BVPRD1(M,N,A,KA,ML,MU,W,U)
      CALL NORMLZ(M,U,BETA)
      BBNORM = BBNORM + ALFA**2 + BETA**2 + DAMPSQ
      CALL SSCAL (N,(-BETA),W,1)
      CALL BTPRD1(M,N,A,KA,ML,MU,U,W)
      CALL NORMLZ(N,W,ALFA)
C
C
C     USE A PLANE ROTATION TO ELIMINATE THE DAMPING PARAMETER.
C     THIS ALTERS THE DIAGONAL (RHOBAR) OF THE LOWER-BIDIAGONAL MATRIX.
C
      RHBAR2 = RHOBAR**2 + DAMPSQ
      RHBAR1 = SQRT(RHBAR2)
      CS1    = RHOBAR/RHBAR1
      SN1    = DAMP/RHBAR1
      PSI    = SN1*PHIBAR
      PHIBAR = CS1*PHIBAR
C
C
C     USE A PLANE ROTATION TO ELIMINATE THE SUBDIAGONAL ELEMENT (BETA)
C     OF THE LOWER-BIDIAGONAL MATRIX, GIVING AN UPPER-BIDIAGONAL MATRIX.
C
      RHO    = SQRT(RHBAR2 + BETA**2)
      CS     = RHBAR1/RHO
      SN     = BETA/RHO
      THETA  =  SN*ALFA
      RHOBAR = -CS*ALFA
      PHI    =  CS*PHIBAR
      PHIBAR =  SN*PHIBAR
      TAU    =  SN*PHI
C
C
C     UPDATE X AND W(N+1),...,W(2*N)
C
      T1 =    PHI/RHO
      T2 = -THETA/RHO
      T3 =    ONE/RHO
C
      DO 200 I = 1, N
         NPI   = N + I
         T     = W(NPI)
         X(I)  = T1*T + X(I)
         W(NPI)= T2*T + W(I)
         T     =(T3*T)**2
         DDNORM= T + DDNORM
  200 CONTINUE
C
C
C     USE A PLANE ROTATION ON THE RIGHT TO ELIMINATE THE
C     SUPER-DIAGONAL ELEMENT (THETA) OF THE UPPER-BIDIAGONAL MATRIX.
C     THEN USE THE RESULT TO ESTIMATE NORM(X).
C
      DELTA  =  SN2*RHO
      GAMBAR = -CS2*RHO
      RHS    = PHI - DELTA*Z
      ZBAR   = RHS/GAMBAR
      XNORM  = SQRT(XXNORM + ZBAR**2)
      GAMMA  = SQRT(GAMBAR**2 + THETA**2)
      CS2    = GAMBAR/GAMMA
      SN2    = THETA/GAMMA
      Z      = RHS/GAMMA
      XXNORM = XXNORM + Z**2
C
C
C     TEST FOR CONVERGENCE.
C     FIRST, ESTIMATE THE NORM AND CONDITION OF THE MATRIX ABAR,
C     AND THE NORMS OF RBAR AND ABAR(TRANSPOSE)*RBAR.
C
      ANORM  = SQRT(BBNORM)
      ACOND  = ANORM*SQRT(DDNORM)
      RES1   = PHIBAR**2
      RES2   = RES2 + PSI**2
      RNORM  = SQRT(RES1 + RES2)
      ARNORM = ALFA*ABS(TAU)
C
C     NOW USE THESE NORMS TO ESTIMATE CERTAIN OTHER QUANTITIES,
C     SOME OF WHICH WILL BE SMALL NEAR A SOLUTION.
C
      TEST1  = RNORM/BNORM
      TEST2  = ARNORM/(ANORM*RNORM)
      TEST3  = ONE/ACOND
      T1     = TEST1/(ONE + ANORM*XNORM/BNORM)
      RTOL   = BTOL +  ATOL*ANORM*XNORM/BNORM
C
C     THE FOLLOWING TESTS GUARD AGAINST EXTREMELY SMALL VALUES OF
C     ATOL, BTOL, OR CTOL.  (THE USER MAY HAVE SET ANY OR ALL OF
C     THE PARAMETERS ATOL, BTOL, CONLIM TO ZERO.)
C     THE EFFECT IS EQUIVALENT TO THE NORMAL TESTS USING
C     ATOL = RELPR,  BTOL = RELPR,  CONLIM = 1/RELPR.
C
      T3 = ONE + TEST3
      T2 = ONE + TEST2
      T1 = ONE + T1
      IF (ITN .GE. ITNLIM) ISTOP = 7
      IF (T3  .LE. ONE   ) ISTOP = 6
      IF (T2  .LE. ONE   ) ISTOP = 5
      IF (T1  .LE. ONE   ) ISTOP = 4
C
C     ALLOW FOR TOLERANCES SET BY THE USER.
C
      IF (TEST3 .LE. CTOL) ISTOP = 3
      IF (TEST2 .LE. ATOL) ISTOP = 2
      IF (TEST1 .LE. RTOL) ISTOP = 1
C
C     STOP IF APPROPRIATE.
C     THE CONVERGENCE CRITERIA ARE REQUIRED TO BE MET ON  NCONV
C     CONSECUTIVE ITERATIONS, WHERE  NCONV  IS SET BELOW.
C     SUGGESTED VALUE --   NCONV = 1, 2  OR  3.
C
      IF (ISTOP .EQ. 0) NSTOP = 0
      IF (ISTOP .EQ. 0) GO TO 100
      NCONV = 1
      NSTOP = NSTOP + 1
      IF (NSTOP .LT. NCONV  .AND.  ITN .LT. ITNLIM) ISTOP = 0
      IF (ISTOP .EQ. 0) GO TO 100
C     ------------------------------------------------------------------
C     END OF ITERATION LOOP.
C     ------------------------------------------------------------------
C
  800 RETURN
      END
      SUBROUTINE FMIN(F, A0, B0, X, W, AERR, RERR, ERROR, IND)
C     ******************************************************************
C     GOLDEN SECTION MINIMIZATION OF A FUNCTION F(T)
C     ******************************************************************
      REAL F, A0, B0, X, W, AERR, RERR, ERROR
      REAL EPS, EPS0, ATOL, FTOL, RTOL, TOL
      REAL A, B, C1, C2, E, FU, FV, U, V
      REAL SPMPAR
      EXTERNAL F
C     -------------------
C     C1 = 1 - C2
C     C2 = 0.5*(-1 + SQRT(5))
C     -------------------
      DATA EPS0/5.E-3/
      DATA C1/.3819660112501052/
      DATA C2/.6180339887498948/
C     -------------------
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
                   EPS = SPMPAR(1)
C     -------------------
      A = A0
      B = B0
      IND = 0
      ATOL = AMAX1(AERR,1.E-20)
      FTOL = AMAX1(2.0*EPS,RERR)
      RTOL = AMAX1(7.0*EPS,RERR)
C
      E = B - A
      U = A + C1*E
      V = A + C2*E
      FU = F(U)
      FV = F(V)
C
C        LOCATION OF THE REGION OF A LOCAL MINIMUM
C
   10 IF (E .LE. EPS0*(1.0 + ABS(A))) GO TO 40
      IF (FU - FV) 20,11,30
   11 IF (FU .GT. F(B)) GO TO 30
C
   20 B = V
      E = B - A
      V = U
      U = A + C1*E
      FV = FU
      FU = F(U)
      GO TO 10
C
   30 A = U
      E = B - A
      U = V
      V = A + C2*E
      FU = FV
      FV = F(V)
      GO TO 10
C
   40 IF (A .GT. 0.0 .OR. B .LT. 0.0) GO TO 41
         W = F(0.0)
         IF (W .LE. AMIN1(FU,FV)) GO TO 100
   41 IF (A .NE. A0) GO TO 42
         IF (A .EQ. 0.0) GO TO 201
         W = F(A)
         IF (W .LE. AMIN1(FU,FV)) GO TO 130
         GO TO 201
   42 IF (B .NE. B0) GO TO 201
         IF (B .EQ. 0.0) GO TO 201
         W = F(B)
         IF (W .LE. AMIN1(FU,FV)) GO TO 150
         GO TO 201
C
C              CHECK IF 0 IS A LOCAL MINIMUM
C
  100 IF (B .LE. ATOL) GO TO 110
      X = 0.01*B
      IF (W .GT. F(X)) GO TO 180
      B = X
      GO TO 100
C
  110 IF (ABS(A) .LE. ATOL) GO TO 120
      X = 0.01*A
      IF (W .GT. F(X)) GO TO 180
      A = X
      GO TO 110
C
  120 X = 0.0
      ERROR = AMAX1(ABS(A),B)
      RETURN
C
C             CHECK IF A0 IS A LOCAL MINIMUM
C
  130 TOL = AMAX1(RTOL*ABS(A),ATOL)
  131 X = A + 0.01*E
      IF (W .GT. F(X)) GO TO 180
      B = X
      E = B - A
      IF (E .GT. TOL) GO TO 131
C
      X = A
      ERROR = E
      RETURN
C
C             CHECK IF B0 IS A LOCAL MINIMUM
C
  150 TOL = AMAX1(RTOL*ABS(B),ATOL)
  151 X = B - 0.01*E
      IF (W .GT. F(X)) GO TO 180
      A = X
      E = B - A
      IF (E .GT. TOL) GO TO 151
C
      X = B
      ERROR = E
      RETURN
C
  180 E = B - A
      U = A + C1*E
      V = A + C2*E
      FU = F(U)
      FV = F(V)
C
C             REFINEMENT OF THE LOCAL MINIMUM
C
  200 IND = 0
  201 IF (FU .GT. FV) GO TO 210
C
      B = V
      E = B - A
      V = U
      U = A + C1*E
      FV = FU
      FU = F(U)
      GO TO 220
C
  210 A = U
      E = B - A
      U = V
      V = A + C2*E
      FU = FV
      FV = F(V)
C
C        CHECKING THE ACCURACY OF THE LOCAL MINIMUM
C
  220 IF (E .LE. AMAX1(RTOL*ABS(A),ATOL)) GO TO 240
      IF (ABS(FV - FU) .GT. FTOL*AMAX1(ABS(FU),ABS(FV))) GO TO 200
      IF (IND .EQ. 1) GO TO 241
      IND = 1
      GO TO 201
C
C                    REPORT THE RESULTS
C
  240 IND = 0
  241 IF (FU - FV) 242,243,244
  242 X = U
      W = FU
      ERROR = C1*E
      RETURN
  243 X = V
      W = FV
      ERROR = E
      RETURN
  244 X = V
      W = FV
      ERROR = C1*E
      RETURN
      END
      SUBROUTINE OPTF (FCN,N,RERR,ITER,XPLS,FPLS,IERR,WRK)
C-----------------------------------------------------------------------
C                 INTERFACE TO MINIMIZATION PACKAGE
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       FCN        NAME OF ROUTINE TO EVALUATE MINIMIZATION FUNCTION.
C                  MUST BE DECLARED EXTERNAL IN CALLING ROUTINE.
C       N          DIMENSION OF PROBLEM
C       RERR       RELATIVE ACCURACY OF SUBROUTINE FCN.
C
C     INPUT/OUTPUT ...
C
C       ITER       ON INPUT ITER IS THE MAXIMUM NUMBER OF ITERATIONS
C                  THAT ARE PERMITTED. ON OUTPUT ITER IS THE NUMBER
C                  OF ITERATIONS THAT WERE ACTUALLY PERFORMED.
C       XPLS(N)    LOCAL MINIMUM
C
C     OUTPUT ...
C
C       FPLS       FUNCTION VALUE AT LOCAL MINIMUM XPLS
C       IERR       TERMINATION CODE
C
C     WORKSPACE ...
C
C       WRK(N,N+8)
C
C-----------------------------------------------------------------------
      REAL XPLS(N), WRK(N,*)
      EXTERNAL FCN
C
C     EQUIVALENCE WRK(N,1) = X(N)
C                 WRK(N,2) = TYPSIZ(N)
C                 WRK(N,3) = GPLS(N)
C                 WRK(N,4) = G(N)
C                 WRK(N,5) = P(N)
C                 WRK(N,6) = WRK0(N)
C                 WRK(N,7) = WRK1(N)
C                 WRK(N,8) = WRK2(N)
C                 WRK(N,9) = A(N,N)
C
C
C     SET TOLERANCES
C
      EPS = AMAX1(SPMPAR(1),ABS(RERR))
      GRADTL = EPS**0.4
      STEPMX = 0.0
      STEPTL = EPS
      IF (EPS .LE. 1.E-10) STEPTL = 10.0*EPS
      IF (EPS .LT. 1.E-13) STEPTL = 1.E2*EPS
C
C     INITIALIZATION
C
      MO = 0
      ITNLIM = ITER
      ITER = 0
      DO 10 I = 1,N
         WRK(I,1) = XPLS(I)
         WRK(I,2) = 1.0
   10 CONTINUE
      FSCALE = 1.0
C
C     OPTIMIZE FCN
C
   20 CALL OPTDRV(MO,N,N,WRK(1,1),FCN,WRK(1,2),FSCALE,RERR,
     *     ITNLIM,ITNCNT,GRADTL,STEPMX,STEPTL,XPLS,FPLS,WRK(1,3),
     *     IERR,WRK(1,9),WRK(1,4),WRK(1,5),WRK(1,6),WRK(1,7),
     *     WRK(1,8))
      ITER = ITER + ITNCNT
      IF (IERR .NE. -10) RETURN
      ITNLIM = ITNLIM - ITNCNT
      GO TO 20
      END
      SUBROUTINE OPTDRV (MO,NR,N,X,FCN,TYPSIZ,FSCALE,RERR,
     *        ITNLIM,ITNCNT,GRADTL,STEPMX,STEPTL,XPLS,FPLS,GPLS,
     *        IERR,A,G,P,WRK0,WRK1,WRK2)
C-----------------------------------------------------------------------
C             DRIVER FOR NON-LINEAR OPTIMIZATION PROBLEM
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       NR         ROW DIMENSION OF MATRIX
C       N          DIMENSION OF PROBLEM
C       FCN        SUBROUTINE.  FCN EVALUATES THE FUNCTION TO BE
C                  OPTIMIZED. FCN MUST BE DECLARED EXTERNAL IN THE
C                  CALLING PROGRAM. THE ROUTINE HAS THE FORMAT
C                         CALL FCN (N, X, FVAL)
C                  WHERE X IS A POINT AND FVAL IS THE VALUE OF THE
C                  FUNCTION AT THE POINT.
C       RERR       RELATIVE ACCURACY OF SUBROUTINE FCN. IT IS
C                  ASSUMED THAT RERR IS NONNEGATIVE. IF RERR = 0
C                  THEN FCN IS ACCURATE TO MACHINE PRECISION.
C       ITNLIM     MAXIMUM NUMBER OF ALLOWABLE ITERATIONS
C       GRADTL     TOLERANCE AT WHICH THE GRADIENT IS CONSIDERED
C                  CLOSE ENOUGH TO ZERO TO TERMINATE ALGORITHM.
C                  (USED ONLY IN THE SUBROUTINE OPSTP.)
C       STEPTL     RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C
C     INPUT/OUTPUT ...
C
C       MO         NUMBER OF RESCALINGS OF THE VARIABLES.
C       X(N)       ESTIMATE OF A LOCAL MINIMUM OF FCN
C       TYPSIZ(N)  TYPICAL SIZE FOR EACH COMPONENT OF X
C       FSCALE     ESTIMATE OF SCALE OF MINIMUM VALUE OF FCN.
C                  (USED ONLY IN THE SUBROUTINE OPSTP.)
C       STEPMX     MAXIMUM ALLOWABLE STEP SIZE
C
C     OUTPUT ...
C
C       ITNCNT     NUMBER OF ITERATIONS COMPLETED
C       XPLS(N)    ESTIMATE OF A LOCAL MINIMUM OF FCN
C       FPLS       FUNCTION VALUE AT XPLS
C       GPLS(N)    GRADIENT AT XPLS
C       IERR       TERMINATION CODE
C
C     WORK SPACES ...
C
C       A(N,N)     CHOLESKY DECOMPOSITION OF HESSIAN
C       G(N)       GRADIENT AT THE CURRENT ITERATE
C       P(N)       STEP
C       WRK0(N)    WORKSPACE
C       WRK1(N)    WORKSPACE
C       WRK2(N)    WORKSPACE
C
C-----------------------------------------------------------------------
C     INTERNAL PARAMETERS ...
C
C       RNF        NOISE IN THE SUBROUTINE FCN
C       F          FUNCTION VALUE  FCN(X)
C       FSTACK(NS) STACK OF PREVIOUS FUNCTION VALUES
C       NS         LENGTH OF THE ARRAY FSTACK
C       SPTR       POINTER TO AN ELEMENT IN FSTACK
C-----------------------------------------------------------------------
      DIMENSION X(N),XPLS(N),G(N),GPLS(N),P(N)
      DIMENSION TYPSIZ(N),A(NR,N)
      DIMENSION WRK0(N),WRK1(N),WRK2(N)
      DIMENSION FSTACK(30)
      INTEGER SPTR
      LOGICAL MXTAKE,NOUPDT
      EXTERNAL FCN
C
C     INITIALIZATION
C     --------------
      NS = 30
      STMX = STEPMX
      STEPMX = 0.0
      CALL OPCHK1 (N,X,TYPSIZ,FSCALE,GRADTL,ITNLIM,RERR,STEPMX,IERR)
      IF (IERR .LT. 0) RETURN
      IF (MO .NE. 0) STEPMX = AMAX1(STMX,STEPMX)
C
      RNF = 2.0*AMAX1(RERR,SPMPAR(1))
      SQRNF = SQRT(RNF)
C
      ITNCNT = 0
      IAGFLG = 0
      IRETCD = -1
      ICSCMX = 0
C
C     EVALUATE FCN(X)
C
      CALL FCN(N,X,F)
C
C     EVALUATE FINITE DIFFERENCE GRADIENT
C
      CALL FSTOFD (N, X, FCN, F, G, TYPSIZ, SQRNF)
C
      CALL OPSTP (N,X,F,G,WRK1,ITNCNT,ICSCMX,IERR,GRADTL,STEPTL,
     *            TYPSIZ,FSCALE,ITNLIM,IRETCD,MXTAKE,FSTACK,NS,SPTR)
      IF (IERR .EQ. 0) GO TO 10
      IF (MO .NE. 0) GO TO 210
C
C        APPLY THE FIXED STEP COORDINATE DESCENT PROCEDURE
C        FOR ONE STEP AND CHECK IF THE GRADIENT IS NONZERO
C
         CALL FXDEC (FCN, N, X, F, 10.0)
C
         STEPMX = 0.0
         CALL OPCHK1 (N,X,TYPSIZ,FSCALE,GRADTL,ITNLIM,RERR,STEPMX,IERR)
         CALL FSTOFD (N, X, FCN, F, G, TYPSIZ, SQRNF)
         CALL OPSTP (N,X,F,G,WRK1,ITNCNT,ICSCMX,IERR,GRADTL,STEPTL,
     *               TYPSIZ,FSCALE,ITNLIM,IRETCD,MXTAKE,FSTACK,NS,SPTR)
         IF (IERR .NE. 0) GO TO 210
C
C     THE HESSIAN WILL BE OBTAINED BY SECANT UPDATES.
C     SET A TO THE INITIAL HESSIAN.
C
   10 NM1 = N - 1
      DO 21 J = 1,NM1
         A(J,J) = 1.0/TYPSIZ(J)
         JP1 = J + 1
         DO 20 I = JP1,N
            A(I,J) = 0.0
   20    CONTINUE
   21 CONTINUE
      A(N,N) = 1.0/TYPSIZ(N)
      GO TO 101
C
C
C     ITERATION
C     ---------
  100 IF (MO .GT. 1) GO TO 101
      IF (MOD(ITNCNT,10) .NE. 0) GO TO 101
      IF (ITNCNT + 10 .GE. ITNLIM) GO TO 101
         CALL SCALEX (MO, X, TYPSIZ, N, IERR)
         IF (IERR .EQ. 0) GO TO 101
         MO = MO + 1
         RETURN
  101 ITNCNT = ITNCNT + 1
C
C     SOLVE  A*P = -G  FOR NEWTON STEP
C
  105 DO 110 I = 1,N
        WRK1(I) = -G(I)
  110 CONTINUE
      CALL LLTSLV(NR,N,A,P,WRK1)
C
C     TAKE A STEP, ARRIVING AT THE POINT XPLS
C
      CALL LNSRCH(N,X,F,G,P,XPLS,FPLS,FCN,MXTAKE,IRETCD,
     *            STEPMX,STEPTL,TYPSIZ)
C
C     IF A SATISFACTORY STEP COULD NOT BE FOUND AND FORWARD DIFFERENCE
C     GRADIENT WAS USED, RETRY USING A CENTRAL DIFFERENCE GRADIENT.
C
      IF (IRETCD .NE. 1 .OR. IAGFLG .NE. 0) GO TO 120
C
C        SET IAGFLG FOR CENTRAL DIFFERENCES
C
         IAGFLG = -1
         CBRNF = RNF**(1.0/3.0)
         CALL FSTOCD (N, X, FCN, TYPSIZ, CBRNF, G)
         GO TO 105
C
C     CALCULATE GRADIENT AT XPLS
C
  120 IF (IAGFLG .EQ. 0) GO TO 130
         CALL FSTOCD (N, XPLS, FCN, TYPSIZ, CBRNF, GPLS)
         GO TO 140
  130 CALL FSTOFD (N, XPLS, FCN, FPLS, GPLS, TYPSIZ, SQRNF)
C
C     CHECK WHETHER THE STOPPING CRITERIA SATISFIED
C
  140 CALL OPSTP (N,XPLS,FPLS,GPLS,X,ITNCNT,ICSCMX,IERR,GRADTL,STEPTL,
     *            TYPSIZ,FSCALE,ITNLIM,IRETCD,MXTAKE,FSTACK,NS,SPTR)
      IF (IERR .NE. 0) GO TO 200
C
C     EVALUATE HESSIAN AT XPLS
C
      CALL SECFAC(NR,N,X,G,A,XPLS,GPLS,ITNCNT,SQRNF,
     *               NOUPDT,WRK0,WRK1,WRK2)
C
C     UPDATE F, X, AND G
C
      F = FPLS
      DO 160 I = 1,N
        X(I) = XPLS(I)
        G(I) = GPLS(I)
  160 CONTINUE
      GO TO 100
C
C     TERMINATION
C     -----------
C     RESET XPLS,FPLS,GPLS  IF PREVIOUS ITERATE SOLUTION
C
  200 IF (IERR .NE. 3) RETURN
C
  210 FPLS = F
      DO 220 I = 1,N
         XPLS(I) = X(I)
         GPLS(I) = G(I)
  220 CONTINUE
      RETURN
      END
      SUBROUTINE OPCHK1 (N,X,TYPSIZ,FSCALE,GRADTL,ITNLIM,RERR,
     *                       STEPMX,IERR)
C-----------------------------------------------------------------------
C                  CHECK INPUT FOR REASONABLENESS
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       N          DIMENSION OF PROBLEM
C       X(N)       ESTIMATE OF MINIMUM OF FCN
C       GRADTL     TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE
C                  ENOUGH TO ZERO TO TERMINATE ALGORITHM
C       ITNLIM     MAXIMUM NUMBER OF ALLOWABLE ITERATIONS
C       RERR       RELATIVE ACCURACY OF SUBROUTINE FCN
C
C     INPUT/OUTPUT ...
C
C       TYPSIZ(N)  SCALING VECTOR FOR X
C       FSCALE     ESTIMATE OF SCALE OF OBJECTIVE FUNCTION FCN
C       STEPMX     MAXIMUM STEP SIZE
C
C     OUTPUT ...
C
C       IERR       ERROR INDICATOR
C
C-----------------------------------------------------------------------
      REAL X(N), TYPSIZ(N)
C
C     CHECK THAT PARAMETERS ONLY TAKE ON ACCEPTABLE VALUES.
C     IF NOT, SET THEM TO DEFAULT VALUES.
C
      IERR = 0
C
C     CHECK DIMENSION OF PROBLEM
C
      IF (N .LE. 0) GO TO 805
      IF (N .EQ. 1) GO TO 810
C
C     COMPUTE SCALE MATRIX
C
      DO 10 I = 1,N
        TYPSIZ(I) = ABS(TYPSIZ(I))
        IF (TYPSIZ(I) .EQ. 0.0) TYPSIZ(I) = 1.0
   10 CONTINUE
C
C     CHECK MAXIMUM STEP SIZE
C
      IF (STEPMX .GT. 0.0) GO TO 20
      STPSIZ = 0.0
      DO 15 I = 1, N
         STPSIZ = STPSIZ + (X(I)/TYPSIZ(I))**2
   15 CONTINUE
      STPSIZ = SQRT(STPSIZ)
      STEPMX = AMAX1(1.0E3*STPSIZ, 1.0E3)
   20 CONTINUE
C
C     CHECK FUNCTION SCALE
C
      FSCALE = ABS(FSCALE)
      IF (FSCALE .EQ. 0.0) FSCALE = 1.0
C
C     CHECK GRADIENT TOLERANCE
C
      IF (GRADTL .LT. 0.0) GO TO 815
C
C     CHECK ITERATION LIMIT
C
      IF (ITNLIM .LE. 0) GO TO 820
C
C     CHECK THE ACCURACY OF FCN
C
      IF (RERR .LT. 0.0 .OR. RERR .GT. 1.E-4) GO TO 825
      RETURN
C
C     ERROR EXITS
C
  805 IERR = -1
      GO TO 895
  810 IERR = -2
      GO TO 895
  815 IERR = -3
      GO TO 895
  820 IERR = -4
      GO TO 895
  825 IERR = -5
  895 RETURN
      END
      SUBROUTINE OPSTP(N,XPLS,FPLS,GPLS,X,ITNCNT,ICSCMX,IERR,
     *           GRADTL,STEPTL,TYPSIZ,FSCALE,ITNLIM,IRETCD,MXTAKE,
     *           FSTACK,NS,SPTR)
C-----------------------------------------------------------------------
C            UNCONSTRAINED MINIMIZATION STOPPING CRITERIA
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       N          DIMENSION OF PROBLEM
C       XPLS(N)    NEW ITERATE X(K)
C       FPLS       FUNCTION VALUE AT NEW ITERATE, F(XPLS)
C       GPLS(N)    GRADIENT AT NEW ITERATE, G(XPLS), OR APPROXIMATE
C       X(N)       OLD ITERATE X(K-1)
C       ITNCNT     CURRENT ITERATION K
C       ICSCMX     NUMBER CONSECUTIVE STEPS .GE. STEPMX
C       GRADTL     TOLERANCE AT WHICH RELATIVE GRADIENT CONSIDERED CLOSE
C                  ENOUGH TO ZERO TO TERMINATE ALGORITHM
C       STEPTL     RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                  CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C       TYPSIZ(N)  SCALING VECTOR FOR X
C       ITNLIM     MAXIMUM NUMBER OF ALLOWABLE ITERATIONS
C       IRETCD     CODE WHICH WAS SET WHEN THE POINT XPLS WAS OBTAINED
C       MXTAKE     BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED
C       NS         LENGTH OF THE ARRAY FSTACK
C
C     INPUT/OUTPUT ...
C
C       FSCALE     ESTIMATE OF SCALE OF OBJECTIVE FUNCTION
C       FSTACK(NS) STACK OF PREVIOUS FUNCTION VALUES
C       SPTR       POINTER TO AN ELEMENT IN FSTACK
C
C     OUTPUT ...
C
C       ICSCMX     NUMBER CONSECUTIVE STEPS .GE. STEPMX
C                  (RETAIN VALUE BETWEEN SUCCESSIVE CALLS)
C       IERR       TERMINATION CODE
C
C-----------------------------------------------------------------------
      REAL XPLS(N), GPLS(N), X(N), TYPSIZ(N), FSTACK(NS)
      INTEGER SPTR
      LOGICAL MXTAKE
C
      IERR = 0
C
C     LAST GLOBAL STEP FAILED TO LOCATE A POINT LOWER THAN X
C
      IF (IRETCD .NE. 1) GO TO 10
         IERR = 3
         RETURN
   10 CONTINUE
C
C     FIND DIRECTION IN WHICH RELATIVE GRADIENT MAXIMUM.
C     CHECK WHETHER WITHIN TOLERANCE.
C
      D = AMAX1(ABS(FPLS),FSCALE)
      RGX = 0.0
      DO 20 I = 1,N
         GRD = ABS(GPLS(I))*AMAX1(ABS(XPLS(I)),TYPSIZ(I))
         RGX = AMAX1(RGX, GRD)
   20 CONTINUE
      JERR = 1
      IF (RGX .GT. GRADTL*D) GO TO 30
         IF (ABS(FPLS) .LE. 1.E-9) GO TO 100
         IF (ABS(FPLS) .GT. 0.5*FSCALE) GO TO 100
         FSCALE = ABS(FPLS)
   30 IF (ITNCNT .EQ. 0) RETURN
C
C     FIND DIRECTION IN WHICH RELATIVE STEPSIZE MAXIMUM
C     CHECK WHETHER WITHIN TOLERANCE.
C
      RSX = 0.0
      DO 40 I = 1,N
         RELSTP = ABS(XPLS(I) - X(I))/AMAX1(ABS(XPLS(I)),TYPSIZ(I))
         RSX = AMAX1(RSX,RELSTP)
   40 CONTINUE
      JERR = 2
      IF (RSX .LE. STEPTL) GO TO 100
C
C     CHECK IF FPLS IS SUFFICIENTLY LESS THAN THE NS-TH
C     PREVIOUS VALUE OF FCN.
C
      IF (ITNCNT .GT. NS) GO TO 50
         SPTR = ITNCNT
         FSTACK(SPTR) = FPLS
         GO TO 60
   50 SPTR = SPTR + 1
      IF (SPTR .GT. NS) SPTR = 1
      JERR = 3
      IF (FPLS .GE. (FSTACK(SPTR) - 1.E-3*ABS(FSTACK(SPTR))))
     *        GO TO 100
      FSTACK(SPTR) = FPLS
C
C     CHECK ITERATION LIMIT
C
   60 JERR = 4
      IF (ITNCNT .GE. ITNLIM) GO TO 100
C
C     CHECK NUMBER OF CONSECUTIVE STEPS OF SIZE STEPMX
C
      IF (MXTAKE) GO TO 70
         ICSCMX = 0
         RETURN
   70 ICSCMX = ICSCMX + 1
      IF (ICSCMX .GE. 20) IERR = 5
      RETURN
C
C     TERMINATE
C
  100 IERR = JERR
      RETURN
      END
      SUBROUTINE FXDEC (FCN, N, X, FX, R)
C-----------------------------------------------------------------------
C     FIXED STEP COORDINATE DESCENT PROCEDURE / ONE ITERATION
C-----------------------------------------------------------------------
      REAL X(N)
      EXTERNAL FCN
C
      DO 20 I = 1,N
         H = R * AMAX1(ABS(X(I)), 1.0)
         XI = X(I)
         XPLUS = XI + H
         X(I) = XPLUS
         CALL FCN (N, X, FPLUS)
         XMINUS = XI - 1.1*H
         X(I) = XMINUS
         CALL FCN (N, X, FMINUS)
         X(I) = XI
C
         IF (FX .LE. FPLUS) GO TO 10
            FX = FPLUS
            X(I) = XPLUS
   10    IF (FX .LE. FMINUS) GO TO 20
            FX = FMINUS
            X(I) = XMINUS
   20 CONTINUE
      RETURN
      END
      SUBROUTINE SCALEX (MO, X, TYPSIZ, N, IERR)
      REAL X(N), TYPSIZ(N)
C-----------------------------------------------------------------------
C     RESCALE THE VARIABLES
C-----------------------------------------------------------------------
      XMIN = 1.E-5*SPMPAR(3)
      DO 10 I = 1,N
         T = AMAX1(ABS(X(I)), 1.E-20)
         XMIN = AMIN1(T, XMIN)
   10 CONTINUE
C
      C = 1.E3
      IF (MO .NE. 0) C = 1.E2
      BIG = C*XMIN
      DO 20 I = 1,N
         IF (ABS(X(I)) .GE. BIG) GO TO 30
   20 CONTINUE
      IERR = 0
      RETURN
C
   30 DO 31 I = 1,N
         T = ABS(X(I))/C
         TYPSIZ(I) = AMAX1(T, XMIN)
   31 CONTINUE
      IERR = -10
      RETURN
      END
      SUBROUTINE LLTSLV (NR,N,A,X,B)
C-----------------------------------------------------------------------
C        SOLUTION OF AX = B WHERE A HAS THE FORM L(L-TRANSPOSE)
C           BUT ONLY THE LOWER TRIANGULAR PART L IS STORED.
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       NR       ROW DIMENSION OF MATRIX
C       N        ORDER OF THE MATRIX
C       A(N,N)   MATRIX OF FORM L(L-TRANSPOSE). A IS NOT
C                MODIFIED BY THE ROUTINE.
C       B(N)     RIGHT-HAND SIDE VECTOR
C
C     OUTPUT ...
C
C       X(N)     SOLUTION VECTOR
C
C-----------------------------------------------------------------------
C     NOTE.  B AND X MAY SHARE THE SAME STORAGE AREA.
C-----------------------------------------------------------------------
      REAL A(NR,N), X(N), B(N)
C
C                  FORWARD SOLVE, RESULT IN X
C
      X(1) = B(1)/A(1,1)
      IF (N .EQ. 1) GO TO 30
      DO 20 I = 2,N
         SUM = 0.0
         IM1 = I - 1
         DO 10 J = 1,IM1
            SUM = SUM + A(I,J)*X(J)
   10    CONTINUE
         X(I) = (B(I) - SUM)/A(I,I)
   20 CONTINUE
C
C                   BACK SOLVE, RESULT IN X
C
   30 X(N) = X(N)/A(N,N)
      IF (N .EQ. 1) RETURN
      I = N
      DO 50 II = 2,N
         IP1 = I
         I = I - 1
         SUM = 0.0
         DO 40 J = IP1,N
            SUM = SUM + A(J,I)*X(J)
   40    CONTINUE
         X(I) = (X(I) - SUM)/A(I,I)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE FSTOFD (N, X, FCN, FX, G, TYPSIZ, R)
C-----------------------------------------------------------------------
C     FIND FORWARD DIFFERENCE APPROXIMATION G TO THE FIRST DERIVATIVE
C     (GRADIENT) OF THE FUNCTION DEFINED BY FCN AT THE POINT X.
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       N          DIMENSION OF PROBLEM
C       X(N)       POINT AT WHICH THE GRADIENT IS TO BE APPROXIMATED
C       FCN        NAME OF SUBROUTINE TO EVALUATE FUNCTION
C       FX         VALUE OF FCN AT THE POINT X
C       TYPSIZ(N)  SCALING VECTOR FOR X
C       R          STEPSIZE FACTOR
C
C     OUTPUT ...
C
C       G(N)       FINITE DIFFERENCE APPROXIMATION TO THE GRADIENT
C
C-----------------------------------------------------------------------
      DIMENSION X(N), G(N), TYPSIZ(N)
      EXTERNAL FCN
C
      DO 10 J = 1,N
        STEPSZ = R * AMAX1(ABS(X(J)),TYPSIZ(J))
        XTMPJ = X(J)
        X(J) = XTMPJ + STEPSZ
        CALL FCN (N, X, FPLUS)
        X(J) = XTMPJ
        G(J) = (FPLUS - FX)/STEPSZ
   10 CONTINUE
      RETURN
      END
      SUBROUTINE FSTOCD (N, X, FCN, TYPSIZ, R, G)
C-----------------------------------------------------------------------
C     FIND CENTRAL DIFFERENCE APPROXIMATION G TO THE FIRST DERIVATIVE
C     (GRADIENT) OF THE FUNCTION DEFINED BY FCN AT THE POINT X.
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       N          DIMENSION OF PROBLEM
C       X(N)       POINT AT WHICH GRADIENT IS TO BE APPROXIMATED
C       FCN        NAME OF SUBROUTINE TO EVALUATE FUNCTION
C       TYPSIZ(N)  SCALING VECTOR FOR X
C       R          STEPSIZE FACTOR
C
C     OUTPUT ...
C
C       G(N)       CENTRAL DIFFERENCE APPROXIMATION TO GRADIENT
C
C-----------------------------------------------------------------------
      REAL X(N), TYPSIZ(N), G(N)
      EXTERNAL FCN
C
C     FIND I-TH  STEPSIZE, EVALUATE TWO NEIGHBORS IN DIRECTION OF
C     I-TH UNIT VECTOR, AND EVALUATE I-TH  COMPONENT OF GRADIENT.
C
      DO 10 I = 1, N
         STEPI = R * AMAX1(ABS(X(I)),TYPSIZ(I))
         XTEMPI = X(I)
         X(I) = XTEMPI + STEPI
         CALL FCN (N, X, FPLUS)
         X(I) = XTEMPI - STEPI
         CALL FCN (N, X, FMINUS)
         X(I) = XTEMPI
         G(I) = (FPLUS - FMINUS)/(2.0*STEPI)
   10 CONTINUE
      RETURN
      END
      SUBROUTINE LNSRCH(N,X,F,G,P,XPLS,FPLS,FCN,MXTAKE,IRETCD,
     *                  STEPMX,STEPTL,TYPSIZ)
C-----------------------------------------------------------------------
C             FIND A NEXT NEWTON ITERATE BY LINE SEARCH
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       N         DIMENSION OF PROBLEM
C       X(N)      OLD ITERATE X(K-1)
C       F         FUNCTION VALUE AT OLD ITERATE, F(X)
C       G(N)      GRADIENT AT OLD ITERATE, G(X)
C       P(N)      NON-ZERO NEWTON STEP
C       FCN       NAME OF SUBROUTINE TO EVALUATE FUNCTION
C       STEPMX    MAXIMUM ALLOWABLE STEP SIZE
C       STEPTL    RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES
C                 CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM
C       TYPSIZ(N) SCALING VECTOR FOR X
C
C     OUTPUT ...
C
C       XPLS(N)   NEW ITERATE X(K)
C       FPLS      FUNCTION VALUE AT NEW ITERATE, F(XPLS)
C       IRETCD    RETURN CODE
C       MXTAKE    BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED
C
C-----------------------------------------------------------------------
C     INTERNAL VARIABLES ...
C
C       SLN      NEWTON LENGTH
C       RLN      RELATIVE LENGTH OF NEWTON STEP
C-----------------------------------------------------------------------
      REAL X(N), G(N), P(N), XPLS(N), TYPSIZ(N)
      REAL LAMBDA
      LOGICAL MXTAKE
      EXTERNAL FCN
C
      MXTAKE = .FALSE.
      IRETCD = 2
      TMP = 0.0
      DO 10 I = 1,N
         TMP = TMP + (P(I)/TYPSIZ(I))**2
   10 CONTINUE
      SLN = SQRT(TMP)
C
      IF (SLN .LE. STEPMX) GO TO 30
C
C     NEWTON STEP LONGER THAN MAXIMUM ALLOWED
C
         SCL = STEPMX/SLN
         DO 20 I = 1,N
            P(I) = SCL*P(I)
   20    CONTINUE
         SLN = STEPMX
C
   30 SLP = SDOT(N,G,1,P,1)
      RLN = 0.0
      DO 40 I = 1,N
         RLN = AMAX1(RLN,ABS(P(I))/AMAX1(ABS(X(I)),TYPSIZ(I)))
   40 CONTINUE
      RMNLMB = STEPTL/RLN
      LAMBDA = 1.0
C
C     LOOP.  CHECK IF THE NEW ITERATE IS SATISFACTORY.
C
  100 DO 110 I = 1,N
        XPLS(I) = X(I) + LAMBDA*P(I)
  110 CONTINUE
      CALL FCN(N,XPLS,FPLS)
      IF (FPLS .LE. F + SLP*1.E-4*LAMBDA) GO TO 200
C
C     SOLUTION NOT (YET) FOUND
C
        IF (LAMBDA .LT. RMNLMB) GO TO 210
C
C     CALCULATE NEW LAMBDA
C
        IF (LAMBDA .NE. 1.0) GO TO 120
C
C     FIRST BACKTRACK. QUADRATIC FIT
C
            TLMBDA = AMIN1(-SLP/(2.0*(FPLS - F - SLP)), 0.9)
            GO TO 170
C
C     ALL SUBSEQUENT BACKTRACKS. CUBIC FIT
C
  120       T1 = (FPLS - F - LAMBDA*SLP)/(LAMBDA*LAMBDA)
            T2 = (PFPLS - F - PLMBDA*SLP)/(PLMBDA*PLMBDA)
            T3 = 1.0/(LAMBDA - PLMBDA)
            A = T3*(T1 - T2)
            B = T3*(T2*LAMBDA - T1*PLMBDA)
            W = 10.0*ABS(T1*T3)
            IF ((ABS(A) + W) .NE. W) GO TO 130
C
C     THE CUBIC FIT DEGENERATES TO A QUADRATIC FIT
C
               TLMBDA = -SLP/(2.0*B)
               GO TO 160
C
C     THE CUBIC IS NONDEGENERATE
C
  130       DISC = B*B - 3.0*A*SLP
            IF (DISC .LE. B*B) GO TO 140
C
C     ONLY ONE POSITIVE CRITICAL POINT, MUST BE MINIMUM
C
               TLMBDA = (-B + SIGN(1.0,A)*SQRT(DISC))/(3.0*A)
               GO TO 160
C
C     BOTH CRITICAL POINTS POSITIVE, FIRST IS MINIMUM
C
  140          IF (DISC .GT. 0.0) GO TO 150
                  TLMBDA = -B/(3.0*A)
                  GO TO 160
  150          TLMBDA = (-B - SIGN(1.0,A)*SQRT(DISC))/(3.0*A)
C
  160       IF (TLMBDA .GT. 0.5*LAMBDA) TLMBDA = 0.5*LAMBDA
C
C
  170     PLMBDA = LAMBDA
          PFPLS = FPLS
          IF (TLMBDA .GE. LAMBDA*0.1) GO TO 180
            LAMBDA = LAMBDA*0.1
            GO TO 100
  180     LAMBDA = TLMBDA
          GO TO 100
C
C     A SUITABLE VALUE FOR XPLS HAS BEEN OBTAINED
C
  200 IRETCD = 0
      IF (LAMBDA .EQ. 1.0 .AND. SLN .GT. 0.99*STEPMX) MXTAKE =.TRUE.
      RETURN
C
C     NO SATISFACTORY XPLS FOUND SUFFICIENTLY DISTINCT FROM X
C
  210 IRETCD = 1
      RETURN
      END
      SUBROUTINE SECFAC (NR,N,X,G,A,XPLS,GPLS,ITNCNT,TOL,
     *                      NOUPDT,S,Y,W)
C-----------------------------------------------------------------------
C           UPDATE HESSIAN BY THE BFGS FACTORED METHOD
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       NR        ROW DIMENSION OF MATRIX
C       N         ORDER OF THE MATRIX
C       X(N)      OLD ITERATE X(K-1)
C       G(N)      GRADIENT AT THE OLD ITERATE
C       XPLS(N)   NEW ITERATE X(K)
C       GPLS(N)   GRADIENT AT THE NEW ITERATE
C       ITNCNT    ITERATION COUNT
C       TOL       RELATIVE TOLERANCE TO BE USED FOR NOISE
C
C     INPUT/OUTPUT ...
C
C       A(N,N)    ON ENTRY, CHOLESKY DECOMPOSITION OF HESSIAN IN
C                    THE LOWER PART AND DIAGONAL.
C                 ON EXIT,  UPDATED CHOLESKY DECOMPOSITION OF HESSIAN
C                    IN THE LOWER TRIANGULAR PART AND DIAGONAL.
C       NOUPDT    BOOLEAN. NO UPDATE YET.
C
C     WORK SPACES ...  S(N), Y(N), W(N)
C
C-----------------------------------------------------------------------
      REAL X(N), XPLS(N), G(N), GPLS(N)
      REAL A(NR,N)
      REAL S(N), Y(N), W(N)
      LOGICAL NOUPDT
C
      IF (ITNCNT .EQ. 1) NOUPDT = .TRUE.
      DO 10 I = 1,N
         S(I) = XPLS(I) - X(I)
         Y(I) = GPLS(I) - G(I)
   10 CONTINUE
      DEN1 = SDOT(N,S,1,Y,1)
      SNORM2 = SNRM2(N,S,1)
      YNRM2 = SNRM2(N,Y,1)
      IF (DEN1 .LT. TOL*SNORM2*YNRM2) RETURN
C
C     SET S = TRANSPOSE(L)*S
C
      DO 21 I = 1,N
         SUM = 0.0
         DO 20 J = I,N
            SUM = SUM + A(J,I)*S(J)
   20    CONTINUE
         S(I) = SUM
   21 CONTINUE
      DEN2 = SDOT(N,S,1,S,1)
C
C     SET ALP = SQRT(DEN1/DEN2)
C
      ALP = SQRT(DEN1/DEN2)
      IF (.NOT.NOUPDT) GO TO 40
C
C        ON THE INITIAL UPDATE SET L = ALP*L. THEN S MUST BE
C        RESET TO ALP*S. AFTER THIS IS DONE THEN DEN2 = DEN1
C        AND ALP HAS THE VALUE 1.
C
         DO 31 J = 1,N
            S(J) = ALP*S(J)
            DO 30 I = J,N
               A(I,J) = ALP*A(I,J)
   30       CONTINUE
   31    CONTINUE
         NOUPDT = .FALSE.
         ALP = 1.0
C
C     SET W = L*S
C
   40 DO 51 I = 1,N
         SUM = 0.0
         DO 50 J = 1,I
            SUM = SUM + A(I,J)*S(J)
   50    CONTINUE
         W(I) = SUM
   51 CONTINUE
C
C     IF ABS(Y(I) - W(I)) IS LESS THAN THE ESTIMATED NOISE IN Y(I)
C     FOR EACH I, THEN THE UPDATE IS SKIPPED.
C
      DO 60 I = 1,N
      IF (ABS(Y(I) - W(I)) .GE. TOL*AMAX1(ABS(G(I)),ABS(GPLS(I))))
     *         GO TO 70
   60 CONTINUE
      RETURN
C
C     W = Y - ALP*L*S
C
   70 DO 71 I = 1,N
         W(I) = Y(I) - ALP*W(I)
   71 CONTINUE
C
C     S = S/SQRT(DEN1*DEN2)
C
      ALP = ALP/DEN1
      DO 80 I = 1,N
         S(I) = ALP*S(I)
   80 CONTINUE
C
C     COPY L INTO UPPER TRIANGULAR PART.  ZERO L.
C
      DO 100 I = 2,N
         IM1 = I - 1
         DO 90 J = 1,IM1
            A(J,I) = A(I,J)
            A(I,J) = 0.0
   90    CONTINUE
  100 CONTINUE
C
C     FIND Q AND R SUCH THAT  Q*R = (L+) + S*(W+)
C
      CALL QRUPDT (NR, N, A, S, W)
C
C     UPPER TRIANGULAR PART AND DIAGONAL OF A NOW CONTAIN UPDATED
C     CHOLESKY DECOMPOSITION OF HESSIAN.  COPY BACK TO LOWER
C     TRIANGULAR PART.
C
      DO 120 I = 2,N
         IM1 = I - 1
         DO 110 J = 1,IM1
            A(I,J) = A(J,I)
  110    CONTINUE
  120 CONTINUE
      RETURN
      END
      SUBROUTINE QRUPDT (NR,N,A,U,V)
C-----------------------------------------------------------------------
C     FIND AN ORTHOGONAL MATRIX (Q*) AND AN UPPER TRIANGULAR
C          MATRIX (R*) SUCH THAT (Q*)(R*) = R + U(V+)
C-----------------------------------------------------------------------
C
C     PARAMETERS ...
C
C       NR      ROW DIMENSION OF THE MATRIX
C       N       ORDER OF THE MATRIX
C       A(N,N)  ON INPUT,  CONTAINS R
C               ON OUTPUT, CONTAINS (R*)
C       U(N)    VECTOR
C       V(N)    VECTOR
C
C-----------------------------------------------------------------------
      REAL A(NR,N), U(N), V(N)
C
C                DETERMINE LAST NON-ZERO IN U
C
      K = N
   10 IF (U(K) .NE. 0.0 .OR. K .EQ. 1) GO TO 20
         K = K - 1
         GO TO 10
C
C               K-1 JACOBI ROTATIONS TRANSFORM
C             R + U(V+)  TO  (R*) + (U(1)*E1)(V+)
C                 WHICH IS UPPER HESSENBERG
C
   20 KM1 = K - 1
      IF (K .LE. 1) GO TO 40
      DO 30 II = 1,KM1
         I = K - II
         CALL JROT (NR,N,A,I,U(I),-U(I+1),R)
         U(I) = R
   30 CONTINUE
C
C SET R = R + (U(1)*E1)(V+)
C
   40 DO 50 J = 1,N
         A(1,J) = A(1,J) + U(1)*V(J)
   50 CONTINUE
      IF (K .LE. 1) RETURN
C
C       K-1 JACOBI ROTATIONS TRANSFORM UPPER HESSENBERG R
C                   TO UPPER TRIANGULAR R*
C
      DO 60 I = 1,KM1
         CALL JROT (NR,N,A,I,A(I,I),-A(I+1,I),R)
   60 CONTINUE
      RETURN
      END
      SUBROUTINE JROT (NR,N,H,I,A,B,R)
C-----------------------------------------------------------------------
C         PRE-MULTIPLICATION OF AN UPPER HESSENBERG MATRIX H
C               BY THE JACOBIAN ROTATION J(I,I+1,A,B)
C-----------------------------------------------------------------------
C
C     INPUT ...
C
C       NR      ROW DIMENSION OF THE MATRIX
C       N       ORDER OF THE MATRIX
C       H(N,N)  UPPER HESSENBER MATRIX
C       I       INDEX OF ROW
C       A,B     SCALARS
C
C     OUTPUT ...
C
C       H(N,N)  THE MODIFIED HESSENBERG MATRIX
C       R       R = SQRT(A*A + B*B)
C
C-----------------------------------------------------------------------
      REAL H(NR,N)
C
C                COMPUTE C = A/R  AND S = B/R
C
      IF (ABS(A) .LE. ABS(B)) GO TO 10
         T = B/A
         Z = SQRT(1.0 + T*T)
         C = SIGN(1.0/Z, A)
         S = T*C
         R = Z*ABS(A)
         GO TO 20
   10 IF (A .EQ. 0.0) GO TO 40
      T = A/B
      Z = SQRT(1.0 + T*T)
      S = SIGN(1.0/Z, B)
      C = T*S
      R = Z*ABS(B)
C
C            APPLY THE ROTATION WHEN A IS NONZERO
C
   20 DO 30 J = I,N
         T = H(I,J)
         Z = H(I+1,J)
         H(I,J) = C*T - S*Z
         H(I+1,J) = S*T + C*Z
   30 CONTINUE
      RETURN
C
C                     CASE WHEN A = 0
C
   40 S = SIGN(1.0, B)
      R = ABS(B)
      DO 50 J = I,N
         T = H(I,J)
         H(I,J) = - S*H(I+1,J)
         H(I+1,J) = S*T
   50 CONTINUE
      RETURN
      END
      SUBROUTINE LMDIFF (FCN,M,N,X,FVEC,EPSFCN,TOL,INFO,IWA,WA,LWA)
      INTEGER M,N,INFO,LWA
      INTEGER IWA(N)
      REAL EPSFCN,TOL
      REAL X(N),FVEC(M),WA(LWA)
      EXTERNAL FCN
C     **********
C
C     SUBROUTINE LMDIFF
C
C     THE PURPOSE OF LMDIFF IS TO MINIMIZE THE SUM OF THE SQUARES OF
C     M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE
C     LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE
C     GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A
C     SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS
C     THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE LMDIFF(FCN,M,N,X,FVEC,EPSFCN,TOL,INFO,IWA,WA,LWA)
C
C     WHERE
C
C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
C         CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
C         IN AN EXTERNAL STATEMENT IN THE USER CALLING
C         PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
C
C         SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
C         INTEGER M,N,IFLAG
C         REAL X(N),FVEC(M)
C         ----------
C         CALCULATE THE FUNCTIONS AT X AND
C         RETURN THIS VECTOR IN FVEC.
C         ----------
C         RETURN
C         END
C
C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
C         THE USER WANTS TO TERMINATE EXECUTION OF LMDIFF.
C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
C
C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF FUNCTIONS.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF VARIABLES. N MUST NOT EXCEED M.
C
C       X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
C         AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
C         CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
C
C       FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
C         THE FUNCTIONS EVALUATED AT THE OUTPUT X.
C
C       EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
C         STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
C         APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
C         FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
C         THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
C         ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
C         PRECISION.
C
C       TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS
C         WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE
C         ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT
C         THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT
C         MOST TOL.
C
C       INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
C         TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
C         VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
C         INFO IS SET AS FOLLOWS.
C
C         INFO = 0  IMPROPER INPUT PARAMETERS.
C
C         INFO = 1  ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
C                   IN THE SUM OF SQUARES IS AT MOST TOL.
C
C         INFO = 2  ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
C                   BETWEEN X AND THE SOLUTION IS AT MOST TOL.
C
C         INFO = 3  CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
C
C         INFO = 4  FVEC IS ORTHOGONAL TO THE COLUMNS OF THE
C                   JACOBIAN TO MACHINE PRECISION.
C
C         INFO = 5  NUMBER OF CALLS TO FCN HAS REACHED OR
C                   EXCEEDED 200*(N+1).
C
C         INFO = 6  TOL IS TOO SMALL. NO FURTHER REDUCTION IN
C                   THE SUM OF SQUARES IS POSSIBLE.
C
C         INFO = 7  TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
C                   THE APPROXIMATE SOLUTION X IS POSSIBLE.
C
C       IWA IS AN INTEGER WORK ARRAY OF LENGTH N.
C
C       WA IS A WORK ARRAY OF LENGTH LWA.
C
C       LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
C         M*N+5*N+M.
C
C     SUBPROGRAMS CALLED
C
C       USER-SUPPLIED ...... FCN
C
C       MINPACK-SUPPLIED ... LMDIF
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT
      REAL FACTOR,FTOL,GTOL,XTOL
      DATA FACTOR /1.0E2/
      INFO = 0
C
C     CHECK THE INPUT PARAMETERS FOR ERRORS.
C
      IF (N .LE. 0 .OR. M .LT. N .OR. EPSFCN .LT. 0.0
     *    .OR. TOL .LT. 0.0 .OR. LWA .LT. M*N + 5*N + M) GO TO 10
C
C     CALL LMDIF.
C
      MAXFEV = 200*(N + 1)
      FTOL = TOL
      XTOL = TOL
      GTOL = 0.0
      MODE = 1
      NPRINT = 0
      MP5N = M + 5*N
      CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1),
     *           MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA,
     *           WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1))
      IF (INFO .EQ. 8) INFO = 4
   10 CONTINUE
      RETURN
      END
      SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
     *                 DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,
     *                 IPVT,QTF,WA1,WA2,WA3,WA4)
      INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC
      INTEGER IPVT(N)
      REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR
      REAL X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N),WA1(N),WA2(N),
     *     WA3(N),WA4(M)
      EXTERNAL FCN
C     **********
C
C     SUBROUTINE LMDIF
C
C     THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF
C     M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF
C     THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A
C     SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS
C     THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,
C                        DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,
C                        LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4)
C
C     WHERE
C
C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
C         CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
C         IN AN EXTERNAL STATEMENT IN THE USER CALLING
C         PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
C
C         SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
C         INTEGER M,N,IFLAG
C         REAL X(N),FVEC(M)
C         ----------
C         CALCULATE THE FUNCTIONS AT X AND
C         RETURN THIS VECTOR IN FVEC.
C         ----------
C         RETURN
C         END
C
C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
C         THE USER WANTS TO TERMINATE EXECUTION OF LMDIF.
C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
C
C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF FUNCTIONS.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF VARIABLES. N MUST NOT EXCEED M.
C
C       X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN
C         AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X
C         CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR.
C
C       FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS
C         THE FUNCTIONS EVALUATED AT THE OUTPUT X.
C
C       FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
C         OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE
C         REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL.
C         THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED
C         IN THE SUM OF SQUARES.
C
C       XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
C         OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE
C         ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE
C         RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION.
C
C       GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION
C         OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND
C         ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE
C         VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY
C         DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS
C         OF THE JACOBIAN.
C
C       MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION
C         OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST
C         MAXFEV BY THE END OF AN ITERATION.
C
C       EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
C         STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
C         APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
C         FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
C         THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
C         ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
C         PRECISION.
C
C       DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE
C         BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG
C         MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS
C         MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES.
C
C       MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE
C         VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2,
C         THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER
C         VALUES OF MODE ARE EQUIVALENT TO MODE = 1.
C
C       FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
C         INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
C         FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
C         TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
C         INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
C
C       NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
C         PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
C         FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST
C         ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND
C         IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE
C         FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS
C         OF FCN WITH IFLAG = 0 ARE MADE.
C
C       INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
C         TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
C         VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
C         INFO IS SET AS FOLLOWS.
C
C         INFO = 0  IMPROPER INPUT PARAMETERS.
C
C         INFO = 1  BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS
C                   IN THE SUM OF SQUARES ARE AT MOST FTOL.
C
C         INFO = 2  RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
C                   IS AT MOST XTOL.
C
C         INFO = 3  CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD.
C
C         INFO = 4  THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY
C                   COLUMN OF THE JACOBIAN IS AT MOST GTOL IN
C                   ABSOLUTE VALUE.
C
C         INFO = 5  NUMBER OF CALLS TO FCN HAS REACHED OR
C                   EXCEEDED MAXFEV.
C
C         INFO = 6  FTOL IS TOO SMALL. NO FURTHER REDUCTION IN
C                   THE SUM OF SQUARES IS POSSIBLE.
C
C         INFO = 7  XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
C                   THE APPROXIMATE SOLUTION X IS POSSIBLE.
C
C         INFO = 8  GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE
C                   COLUMNS OF THE JACOBIAN TO MACHINE PRECISION.
C
C       NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF
C         CALLS TO FCN.
C
C       FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX
C         OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH
C         DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT
C
C                T     T           T
C               P *(JAC *JAC)*P = R *R,
C
C         WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL
C         CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J)
C         (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL
C         PART OF FJAC CONTAINS INFORMATION GENERATED DURING
C         THE COMPUTATION OF R.
C
C       LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
C
C       IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT
C         DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R,
C         WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS
C         ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR
C         WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE.
C         COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
C
C       QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
C         THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC.
C
C       WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N.
C
C       WA4 IS A WORK ARRAY OF LENGTH M.
C
C     SUBPROGRAMS CALLED
C
C       USER-SUPPLIED ...... FCN
C
C       MINPACK-SUPPLIED ... SPMPAR,ENORM,FDJAC2,LMPAR,QRFAC
C
C       FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,MOD
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,IFLAG,ITER,J,L
      REAL ACTRED,DELTA,DIRDER,EPS,FNORM,FNORM1,GNORM,PAR,
     *     PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1,
     *     TEMP2,XNORM
      REAL SPMPAR,ENORM
      DATA P1,P5,P25,P75,P0001
     *     /1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4/
C
C     EPS IS THE MACHINE PRECISION.
C
      EPS = SPMPAR(1)
C
      INFO = 0
      IFLAG = 0
      NFEV = 0
C
C     CHECK THE INPUT PARAMETERS FOR ERRORS.
C
      IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M
     *    .OR. FTOL .LT. 0.0 .OR. XTOL .LT. 0.0 .OR. GTOL .LT. 0.0
     *    .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. 0.0) GO TO 300
      IF (MODE .NE. 2) GO TO 20
      DO 10 J = 1, N
         IF (DIAG(J) .LE. 0.0) GO TO 300
   10    CONTINUE
   20 CONTINUE
C
C     EVALUATE THE FUNCTION AT THE STARTING POINT
C     AND CALCULATE ITS NORM.
C
      IFLAG = 1
      CALL FCN(M,N,X,FVEC,IFLAG)
      NFEV = 1
      IF (IFLAG .LT. 0) GO TO 300
      FNORM = ENORM(M,FVEC)
C
C     INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER.
C
      PAR = 0.0
      ITER = 1
C
C     BEGINNING OF THE OUTER LOOP.
C
   30 CONTINUE
C
C        CALCULATE THE JACOBIAN MATRIX.
C
         IFLAG = 2
         CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4)
         NFEV = NFEV + N
         IF (IFLAG .LT. 0) GO TO 300
C
C        IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
C
         IF (NPRINT .LE. 0) GO TO 40
         IFLAG = 0
         IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG)
         IF (IFLAG .LT. 0) GO TO 300
   40    CONTINUE
C
C        COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
C
         CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3)
C
C        ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
C        TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.
C
         IF (ITER .NE. 1) GO TO 80
         IF (MODE .EQ. 2) GO TO 60
         DO 50 J = 1, N
            DIAG(J) = WA2(J)
            IF (WA2(J) .EQ. 0.0) DIAG(J) = 1.0
   50       CONTINUE
   60    CONTINUE
C
C        ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
C        AND INITIALIZE THE STEP BOUND DELTA.
C
         DO 70 J = 1, N
            WA3(J) = DIAG(J)*X(J)
   70       CONTINUE
         XNORM = ENORM(N,WA3)
         DELTA = FACTOR*XNORM
         IF (DELTA .EQ. 0.0) DELTA = FACTOR
   80    CONTINUE
C
C        FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN
C        QTF.
C
         DO 90 I = 1, M
            WA4(I) = FVEC(I)
   90       CONTINUE
         DO 130 J = 1, N
            IF (FJAC(J,J) .EQ. 0.0) GO TO 120
            SUM = 0.0
            DO 100 I = J, M
               SUM = SUM + FJAC(I,J)*WA4(I)
  100          CONTINUE
            TEMP = -SUM/FJAC(J,J)
            DO 110 I = J, M
               WA4(I) = WA4(I) + FJAC(I,J)*TEMP
  110          CONTINUE
  120       CONTINUE
            FJAC(J,J) = WA1(J)
            QTF(J) = WA4(J)
  130       CONTINUE
C
C        COMPUTE THE NORM OF THE SCALED GRADIENT.
C
         GNORM = 0.0
         IF (FNORM .EQ. 0.0) GO TO 170
         DO 160 J = 1, N
            L = IPVT(J)
            IF (WA2(L) .EQ. 0.0) GO TO 150
            SUM = 0.0
            DO 140 I = 1, J
               SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM)
  140          CONTINUE
            GNORM = AMAX1(GNORM,ABS(SUM/WA2(L)))
  150       CONTINUE
  160       CONTINUE
  170    CONTINUE
C
C        TEST FOR CONVERGENCE OF THE GRADIENT NORM.
C
         IF (GNORM .LE. GTOL) INFO = 4
         IF (INFO .NE. 0) GO TO 300
C
C        RESCALE IF NECESSARY.
C
         IF (MODE .EQ. 2) GO TO 190
         DO 180 J = 1, N
            DIAG(J) = AMAX1(DIAG(J),WA2(J))
  180       CONTINUE
  190    CONTINUE
C
C        BEGINNING OF THE INNER LOOP.
C
  200    CONTINUE
C
C           DETERMINE THE LEVENBERG-MARQUARDT PARAMETER.
C
            CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2,
     *                 WA3,WA4)
C
C           STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.
C
            DO 210 J = 1, N
               WA1(J) = -WA1(J)
               WA2(J) = X(J) + WA1(J)
               WA3(J) = DIAG(J)*WA1(J)
  210          CONTINUE
            PNORM = ENORM(N,WA3)
C
C           ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.
C
            IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM)
C
C           EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.
C
            IFLAG = 1
            CALL FCN(M,N,WA2,WA4,IFLAG)
            NFEV = NFEV + 1
            IF (IFLAG .LT. 0) GO TO 300
            FNORM1 = ENORM(M,WA4)
C
C           COMPUTE THE SCALED ACTUAL REDUCTION.
C
            ACTRED = -1.0
            IF (P1*FNORM1 .LT. FNORM) ACTRED = 1.0 - (FNORM1/FNORM)**2
C
C           COMPUTE THE SCALED PREDICTED REDUCTION AND
C           THE SCALED DIRECTIONAL DERIVATIVE.
C
            DO 230 J = 1, N
               WA3(J) = 0.0
               L = IPVT(J)
               TEMP = WA1(L)
               DO 220 I = 1, J
                  WA3(I) = WA3(I) + FJAC(I,J)*TEMP
  220             CONTINUE
  230          CONTINUE
            TEMP1 = ENORM(N,WA3)/FNORM
            TEMP2 = (SQRT(PAR)*PNORM)/FNORM
            PRERED = TEMP1**2 + TEMP2**2/P5
            DIRDER = -(TEMP1**2 + TEMP2**2)
C
C           COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED
C           REDUCTION.
C
            RATIO = 0.0
            IF (PRERED .NE. 0.0) RATIO = ACTRED/PRERED
C
C           UPDATE THE STEP BOUND.
C
            IF (RATIO .GT. P25) GO TO 240
               IF (ACTRED .GE. 0.0) TEMP = P5
               IF (ACTRED .LT. 0.0)
     *            TEMP = P5*DIRDER/(DIRDER + P5*ACTRED)
               IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1
               DELTA = TEMP*AMIN1(DELTA,PNORM/P1)
               PAR = PAR/TEMP
               GO TO 260
  240       CONTINUE
               IF (PAR .NE. 0.0 .AND. RATIO .LT. P75) GO TO 250
               DELTA = PNORM/P5
               PAR = P5*PAR
  250          CONTINUE
  260       CONTINUE
C
C           TEST FOR SUCCESSFUL ITERATION.
C
            IF (RATIO .LT. P0001) GO TO 290
C
C           SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.
C
            DO 270 J = 1, N
               X(J) = WA2(J)
               WA2(J) = DIAG(J)*X(J)
  270          CONTINUE
            DO 280 I = 1, M
               FVEC(I) = WA4(I)
  280          CONTINUE
            XNORM = ENORM(N,WA2)
            FNORM = FNORM1
            ITER = ITER + 1
  290       CONTINUE
C
C           TESTS FOR CONVERGENCE.
C
            IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
     *          .AND. P5*RATIO .LE. 1.0) INFO = 1
            IF (DELTA .LE. XTOL*XNORM) INFO = 2
            IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL
     *          .AND. P5*RATIO .LE. 1.0 .AND. INFO .EQ. 2) INFO = 3
            IF (INFO .NE. 0) GO TO 300
C
C           TESTS FOR TERMINATION AND STRINGENT TOLERANCES.
C
            IF (NFEV .GE. MAXFEV) INFO = 5
            IF (ABS(ACTRED) .LE. EPS .AND. PRERED .LE. EPS
     *          .AND. P5*RATIO .LE. 1.0) INFO = 6
            IF (DELTA .LE. EPS*XNORM) INFO = 7
            IF (GNORM .LE. EPS) INFO = 8
            IF (INFO .NE. 0) GO TO 300
C
C           END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL.
C
            IF (RATIO .LT. P0001) GO TO 200
C
C        END OF THE OUTER LOOP.
C
         GO TO 30
  300 CONTINUE
C
C     TERMINATION, EITHER NORMAL OR USER IMPOSED.
C
      IF (IFLAG .LT. 0) INFO = IFLAG
      IFLAG = 0
      IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG)
      RETURN
      END
      REAL FUNCTION ENORM(N,X)
      INTEGER N
      REAL X(N)
C     **********
C
C     FUNCTION ENORM
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     SUBPROGRAMS CALLED
C
C       FORTRAN-SUPPLIED ... ABS,SQRT
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I
      REAL AGIANT,FLOATN,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX
      DATA RDWARF,RGIANT /3.834E-20,1.304E19/
C
      S1 = 0.0
      S2 = 0.0
      S3 = 0.0
      X1MAX = 0.0
      X3MAX = 0.0
      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 = 1.0 + 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 = 1.0 + S3*(X3MAX/XABS)**2
                  X3MAX = XABS
                  GO TO 50
   40          CONTINUE
                  IF (XABS .NE. 0.0) 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. 0.0) GO TO 100
         ENORM = X1MAX*SQRT(S1 + (S2/X1MAX)/X1MAX)
         GO TO 130
  100 CONTINUE
         IF (S2 .EQ. 0.0) GO TO 110
            IF (S2 .GE. X3MAX)
     *         ENORM = SQRT(S2*(1.0 + (X3MAX/S2)*(X3MAX*S3)))
            IF (S2 .LT. X3MAX)
     *         ENORM = SQRT(X3MAX*((S2/X3MAX) + (X3MAX*S3)))
            GO TO 120
  110    CONTINUE
            ENORM = X3MAX*SQRT(S3)
  120    CONTINUE
  130 CONTINUE
      RETURN
      END
      SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
      INTEGER N,LR
      REAL DELTA
      REAL R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N)
C     **********
C
C     SUBROUTINE DOGLEG
C
C     GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL
C     MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE
C     PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE
C     GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES
C     (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE
C     RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA.
C
C     THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
C     IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
C     QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS
C     ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX,
C     THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND
C     THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
C
C     WHERE
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
C
C       R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER
C         TRIANGULAR MATRIX R STORED BY ROWS.
C
C       LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
C         (N*(N+1))/2.
C
C       DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
C         DIAGONAL ELEMENTS OF THE MATRIX D.
C
C       QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
C         N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
C
C       DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER
C         BOUND ON THE EUCLIDEAN NORM OF D*X.
C
C       X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED
C         CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE
C         SCALED GRADIENT DIRECTION.
C
C       WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.
C
C     SUBPROGRAMS CALLED
C
C       MINPACK-SUPPLIED ... SPMPAR,ENORM
C
C       FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,J,JJ,JP1,K,L
      REAL ALPHA,BNORM,EPSMCH,GNORM,QNORM,SGNORM,SUM,TEMP
      REAL SPMPAR,ENORM
C
C     EPSMCH IS THE MACHINE PRECISION.
C
      EPSMCH = SPMPAR(1)
C
C     FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION.
C
      JJ = (N*(N + 1))/2 + 1
      DO 50 K = 1, N
         J = N - K + 1
         JP1 = J + 1
         JJ = JJ - K
         L = JJ + 1
         SUM = 0.0
         IF (N .LT. JP1) GO TO 20
         DO 10 I = JP1, N
            SUM = SUM + R(L)*X(I)
            L = L + 1
   10       CONTINUE
   20    CONTINUE
         TEMP = R(JJ)
         IF (TEMP .NE. 0.0) GO TO 40
         L = J
         DO 30 I = 1, J
            TEMP = AMAX1(TEMP,ABS(R(L)))
            L = L + N - I
   30       CONTINUE
         TEMP = EPSMCH*TEMP
         IF (TEMP .EQ. 0.0) TEMP = EPSMCH
   40    CONTINUE
         X(J) = (QTB(J) - SUM)/TEMP
   50    CONTINUE
C
C     TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE.
C
      DO 60 J = 1, N
         WA1(J) = 0.0
         WA2(J) = DIAG(J)*X(J)
   60    CONTINUE
      QNORM = ENORM(N,WA2)
      IF (QNORM .LE. DELTA) GO TO 140
C
C     THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE.
C     NEXT, CALCULATE THE SCALED GRADIENT DIRECTION.
C
      L = 1
      DO 80 J = 1, N
         TEMP = QTB(J)
         DO 70 I = J, N
            WA1(I) = WA1(I) + R(L)*TEMP
            L = L + 1
   70       CONTINUE
         WA1(J) = WA1(J)/DIAG(J)
   80    CONTINUE
C
C     CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR
C     THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO.
C
      GNORM = ENORM(N,WA1)
      SGNORM = 0.0
      ALPHA = DELTA/QNORM
      IF (GNORM .EQ. 0.0) GO TO 120
C
C     CALCULATE THE POINT ALONG THE SCALED GRADIENT
C     AT WHICH THE QUADRATIC IS MINIMIZED.
C
      DO 90 J = 1, N
         WA1(J) = (WA1(J)/GNORM)/DIAG(J)
   90    CONTINUE
      L = 1
      DO 110 J = 1, N
         SUM = 0.0
         DO 100 I = J, N
            SUM = SUM + R(L)*WA1(I)
            L = L + 1
  100       CONTINUE
         WA2(J) = SUM
  110    CONTINUE
      TEMP = ENORM(N,WA2)
      SGNORM = (GNORM/TEMP)/TEMP
C
C     TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE.
C
      ALPHA = 0.0
      IF (SGNORM .GE. DELTA) GO TO 120
C
C     THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE.
C     FINALLY, CALCULATE THE POINT ALONG THE DOGLEG
C     AT WHICH THE QUADRATIC IS MINIMIZED.
C
      BNORM = ENORM(N,QTB)
      TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA)
      TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2
     *       + SQRT((TEMP-(DELTA/QNORM))**2
     *              +(1.0-(DELTA/QNORM)**2)*(1.0-(SGNORM/DELTA)**2))
      ALPHA = ((DELTA/QNORM)*(1.0 - (SGNORM/DELTA)**2))/TEMP
  120 CONTINUE
C
C     FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON
C     DIRECTION AND THE SCALED GRADIENT DIRECTION.
C
      TEMP = (1.0 - ALPHA)*AMIN1(SGNORM,DELTA)
      DO 130 J = 1, N
         X(J) = TEMP*WA1(J) + ALPHA*X(J)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END
      SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
     *                  WA1,WA2)
      INTEGER N,LDFJAC,IFLAG,ML,MU
      REAL EPSFCN
      REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N)
      EXTERNAL FCN
C     **********
C
C     SUBROUTINE FDJAC1
C
C     THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION
C     TO THE N BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED
C     PROBLEM OF N FUNCTIONS IN N VARIABLES. IF THE JACOBIAN HAS
C     A BANDED FORM, THEN FUNCTION EVALUATIONS ARE SAVED BY ONLY
C     APPROXIMATING THE NONZERO TERMS.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
C                         WA1,WA2)
C
C     WHERE
C
C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
C         CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
C         IN AN EXTERNAL STATEMENT IN THE USER CALLING
C         PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
C
C         SUBROUTINE FCN(N,X,FVEC,IFLAG)
C         INTEGER N,IFLAG
C         REAL X(N),FVEC(N)
C         ----------
C         CALCULATE THE FUNCTIONS AT X AND
C         RETURN THIS VECTOR IN FVEC.
C         ----------
C         RETURN
C         END
C
C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
C         THE USER WANTS TO TERMINATE EXECUTION OF FDJAC1.
C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF FUNCTIONS AND VARIABLES.
C
C       X IS AN INPUT ARRAY OF LENGTH N.
C
C       FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
C         FUNCTIONS EVALUATED AT X.
C
C       FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
C         APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.
C
C       LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
C
C       IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
C         THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN.
C
C       ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
C         THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE
C         JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
C         ML TO AT LEAST N - 1.
C
C       EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
C         STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
C         APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
C         FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
C         THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
C         ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
C         PRECISION.
C
C       MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
C         THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE
C         JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
C         MU TO AT LEAST N - 1.
C
C       WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT
C         LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS
C         NOT REFERENCED.
C
C     SUBPROGRAMS CALLED
C
C       MINPACK-SUPPLIED ... SPMPAR
C
C       FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,J,K,MSUM
      REAL EPS,EPSMCH,H,TEMP,ZERO
      REAL SPMPAR
      DATA ZERO /0.0E0/
C
C     EPSMCH IS THE MACHINE PRECISION.
C
      EPSMCH = SPMPAR(1)
C
      EPS = SQRT(AMAX1(EPSFCN,EPSMCH))
      MSUM = ML + MU + 1
      IF (MSUM .LT. N) GO TO 40
C
C        COMPUTATION OF DENSE APPROXIMATE JACOBIAN.
C
         DO 20 J = 1, N
            TEMP = X(J)
            H = EPS*ABS(TEMP)
            IF (H .EQ. ZERO) H = EPS
            X(J) = TEMP + H
            CALL FCN(N,X,WA1,IFLAG)
            IF (IFLAG .LT. 0) GO TO 30
            X(J) = TEMP
            DO 10 I = 1, N
               FJAC(I,J) = (WA1(I) - FVEC(I))/H
   10          CONTINUE
   20       CONTINUE
   30    CONTINUE
         GO TO 110
   40 CONTINUE
C
C        COMPUTATION OF BANDED APPROXIMATE JACOBIAN.
C
         DO 90 K = 1, MSUM
            DO 60 J = K, N, MSUM
               WA2(J) = X(J)
               H = EPS*ABS(WA2(J))
               IF (H .EQ. ZERO) H = EPS
               X(J) = WA2(J) + H
   60          CONTINUE
            CALL FCN(N,X,WA1,IFLAG)
            IF (IFLAG .LT. 0) GO TO 100
            DO 80 J = K, N, MSUM
               X(J) = WA2(J)
               H = EPS*ABS(WA2(J))
               IF (H .EQ. ZERO) H = EPS
               DO 70 I = 1, N
                  FJAC(I,J) = ZERO
                  IF (I .GE. J - MU .AND. I .LE. J + ML)
     *               FJAC(I,J) = (WA1(I) - FVEC(I))/H
   70             CONTINUE
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE
  110 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE FDJAC1.
C
      END
      SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA)
      INTEGER M,N,LDFJAC,IFLAG
      REAL EPSFCN
      REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(M)
      EXTERNAL FCN
C     **********
C
C     SUBROUTINE FDJAC2
C
C     THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION
C     TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED
C     PROBLEM OF M FUNCTIONS IN N VARIABLES.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA)
C
C     WHERE
C
C       FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH
C         CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED
C         IN AN EXTERNAL STATEMENT IN THE USER CALLING
C         PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
C
C         SUBROUTINE FCN(M,N,X,FVEC,IFLAG)
C         INTEGER M,N,IFLAG
C         REAL X(N),FVEC(M)
C         ----------
C         CALCULATE THE FUNCTIONS AT X AND
C         RETURN THIS VECTOR IN FVEC.
C         ----------
C         RETURN
C         END
C
C         THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
C         THE USER WANTS TO TERMINATE EXECUTION OF FDJAC2.
C         IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
C
C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF FUNCTIONS.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF VARIABLES. N MUST NOT EXCEED M.
C
C       X IS AN INPUT ARRAY OF LENGTH N.
C
C       FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE
C         FUNCTIONS EVALUATED AT X.
C
C       FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE
C         APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.
C
C       LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
C
C       IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
C         THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN.
C
C       EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
C         STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
C         APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
C         FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
C         THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
C         ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
C         PRECISION.
C
C       WA IS A WORK ARRAY OF LENGTH M.
C
C     SUBPROGRAMS CALLED
C
C       USER-SUPPLIED ...... FCN
C
C       MINPACK-SUPPLIED ... SPMPAR
C
C       FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,J
      REAL EPS,EPSMCH,H,TEMP,ZERO
      REAL SPMPAR
      DATA ZERO /0.0E0/
C
C     EPSMCH IS THE MACHINE PRECISION.
C
      EPSMCH = SPMPAR(1)
C
      EPS = SQRT(AMAX1(EPSFCN,EPSMCH))
      DO 20 J = 1, N
         TEMP = X(J)
         H = EPS*ABS(TEMP)
         IF (H .EQ. ZERO) H = EPS
         X(J) = TEMP + H
         CALL FCN(M,N,X,WA,IFLAG)
         IF (IFLAG .LT. 0) GO TO 30
         X(J) = TEMP
         DO 10 I = 1, M
            FJAC(I,J) = (WA(I) - FVEC(I))/H
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE FDJAC2.
C
      END
      SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1,
     *                 WA2)
      INTEGER N,LDR
      INTEGER IPVT(N)
      REAL DELTA,PAR
      REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N),WA2(N)
C     **********
C
C     SUBROUTINE LMPAR
C
C     GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL
C     MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA,
C     THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER
C     PAR SUCH THAT IF X SOLVES THE SYSTEM
C
C           A*X = B ,     SQRT(PAR)*D*X = 0 ,
C
C     IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN
C     NORM OF D*X, THEN EITHER PAR IS ZERO AND
C
C           (DXNORM-DELTA) .LE. 0.1*DELTA ,
C
C     OR PAR IS POSITIVE AND
C
C           ABS(DXNORM-DELTA) .LE. 0.1*DELTA .
C
C     THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
C     IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
C     QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF
C     A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL
C     COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL
C     ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS
C     THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P,
C     AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT
C     LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT
C
C            T   T                   T
C           P *(A *A + PAR*D*D)*P = S *S .
C
C     S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST.
C
C     ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE
C     OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS
C     IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST
C     VALUE OBTAINED SO FAR.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,
C                        WA1,WA2)
C
C     WHERE
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
C
C       R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE
C         MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R.
C         ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE
C         STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE
C         (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S.
C
C       LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R.
C
C       IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE
C         PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P
C         IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
C
C       DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
C         DIAGONAL ELEMENTS OF THE MATRIX D.
C
C       QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
C         N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
C
C       DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER
C         BOUND ON THE EUCLIDEAN NORM OF D*X.
C
C       PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN
C         INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER.
C         ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE.
C
C       X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST
C         SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0,
C         FOR THE OUTPUT PAR.
C
C       SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
C         DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S.
C
C       WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.
C
C     SUBPROGRAMS CALLED
C
C       MINPACK-SUPPLIED ... SPMPAR,ENORM,QRSOLV
C
C       FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,ITER,J,JM1,JP1,K,L,NSING
      REAL DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,SUM,TEMP,ZERO
      REAL SPMPAR,ENORM
      DATA P1,P001,ZERO /1.0E-1,1.0E-3,0.0E0/
C
C     DWARF IS THE SMALLEST POSITIVE MAGNITUDE.
C
      DWARF = SPMPAR(2)
C
C     COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE
C     JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION.
C
      NSING = N
      DO 10 J = 1, N
         WA1(J) = QTB(J)
         IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1
         IF (NSING .LT. N) WA1(J) = ZERO
   10    CONTINUE
      IF (NSING .LT. 1) GO TO 50
      DO 40 K = 1, NSING
         J = NSING - K + 1
         WA1(J) = WA1(J)/R(J,J)
         TEMP = WA1(J)
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 30
         DO 20 I = 1, JM1
            WA1(I) = WA1(I) - R(I,J)*TEMP
   20       CONTINUE
   30    CONTINUE
   40    CONTINUE
   50 CONTINUE
      DO 60 J = 1, N
         L = IPVT(J)
         X(L) = WA1(J)
   60    CONTINUE
C
C     INITIALIZE THE ITERATION COUNTER.
C     EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST
C     FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION.
C
      ITER = 0
      DO 70 J = 1, N
         WA2(J) = DIAG(J)*X(J)
   70    CONTINUE
      DXNORM = ENORM(N,WA2)
      FP = DXNORM - DELTA
      IF (FP .LE. P1*DELTA) GO TO 220
C
C     IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON
C     STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF
C     THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO.
C
      PARL = ZERO
      IF (NSING .LT. N) GO TO 120
      DO 80 J = 1, N
         L = IPVT(J)
         WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
   80    CONTINUE
      DO 110 J = 1, N
         SUM = ZERO
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 100
         DO 90 I = 1, JM1
            SUM = SUM + R(I,J)*WA1(I)
   90       CONTINUE
  100    CONTINUE
         WA1(J) = (WA1(J) - SUM)/R(J,J)
  110    CONTINUE
      TEMP = ENORM(N,WA1)
      PARL = ((FP/DELTA)/TEMP)/TEMP
  120 CONTINUE
C
C     CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION.
C
      DO 140 J = 1, N
         SUM = ZERO
         DO 130 I = 1, J
            SUM = SUM + R(I,J)*QTB(I)
  130       CONTINUE
         L = IPVT(J)
         WA1(J) = SUM/DIAG(L)
  140    CONTINUE
      GNORM = ENORM(N,WA1)
      PARU = GNORM/DELTA
      IF (PARU .EQ. ZERO) PARU = DWARF/AMIN1(DELTA,P1)
C
C     IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU),
C     SET PAR TO THE CLOSER ENDPOINT.
C
      PAR = AMAX1(PAR,PARL)
      PAR = AMIN1(PAR,PARU)
      IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM
C
C     BEGINNING OF AN ITERATION.
C
  150 CONTINUE
         ITER = ITER + 1
C
C        EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR.
C
         IF (PAR .EQ. ZERO) PAR = AMAX1(DWARF,P001*PARU)
         TEMP = SQRT(PAR)
         DO 160 J = 1, N
            WA1(J) = TEMP*DIAG(J)
  160       CONTINUE
         CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2)
         DO 170 J = 1, N
            WA2(J) = DIAG(J)*X(J)
  170       CONTINUE
         DXNORM = ENORM(N,WA2)
         TEMP = FP
         FP = DXNORM - DELTA
C
C        IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE
C        OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL
C        IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10.
C
         IF (ABS(FP) .LE. P1*DELTA
     *       .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP
     *            .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220
C
C        COMPUTE THE NEWTON CORRECTION.
C
         DO 180 J = 1, N
            L = IPVT(J)
            WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
  180       CONTINUE
         DO 210 J = 1, N
            WA1(J) = WA1(J)/SDIAG(J)
            TEMP = WA1(J)
            JP1 = J + 1
            IF (N .LT. JP1) GO TO 200
            DO 190 I = JP1, N
               WA1(I) = WA1(I) - R(I,J)*TEMP
  190          CONTINUE
  200       CONTINUE
  210       CONTINUE
         TEMP = ENORM(N,WA1)
         PARC = ((FP/DELTA)/TEMP)/TEMP
C
C        DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU.
C
         IF (FP .GT. ZERO) PARL = AMAX1(PARL,PAR)
         IF (FP .LT. ZERO) PARU = AMIN1(PARU,PAR)
C
C        COMPUTE AN IMPROVED ESTIMATE FOR PAR.
C
         PAR = AMAX1(PARL,PAR+PARC)
C
C        END OF AN ITERATION.
C
         GO TO 150
  220 CONTINUE
C
C     TERMINATION.
C
      IF (ITER .EQ. 0) PAR = ZERO
      RETURN
C
C     LAST CARD OF SUBROUTINE LMPAR.
C
      END
      SUBROUTINE QFORM(M,N,Q,LDQ,WA)
      INTEGER M,N,LDQ
      REAL Q(LDQ,M),WA(M)
C     **********
C
C     SUBROUTINE QFORM
C
C     THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF
C     AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX
C     Q FROM ITS FACTORED FORM.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE QFORM(M,N,Q,LDQ,WA)
C
C     WHERE
C
C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF ROWS OF A AND THE ORDER OF Q.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF COLUMNS OF A.
C
C       Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN
C         THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM.
C         ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX.
C
C       LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q.
C
C       WA IS A WORK ARRAY OF LENGTH M.
C
C     SUBPROGRAMS CALLED
C
C       FORTRAN-SUPPLIED ... MIN0
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,J,JM1,K,L,MINMN,NP1
      REAL ONE,SUM,TEMP,ZERO
      DATA ONE,ZERO /1.0E0,0.0E0/
C
C     ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS.
C
      MINMN = MIN0(M,N)
      IF (MINMN .LT. 2) GO TO 30
      DO 20 J = 2, MINMN
         JM1 = J - 1
         DO 10 I = 1, JM1
            Q(I,J) = ZERO
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE
C
C     INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX.
C
      NP1 = N + 1
      IF (M .LT. NP1) GO TO 60
      DO 50 J = NP1, M
         DO 40 I = 1, M
            Q(I,J) = ZERO
   40       CONTINUE
         Q(J,J) = ONE
   50    CONTINUE
   60 CONTINUE
C
C     ACCUMULATE Q FROM ITS FACTORED FORM.
C
      DO 120 L = 1, MINMN
         K = MINMN - L + 1
         DO 70 I = K, M
            WA(I) = Q(I,K)
            Q(I,K) = ZERO
   70       CONTINUE
         Q(K,K) = ONE
         IF (WA(K) .EQ. ZERO) GO TO 110
         DO 100 J = K, M
            SUM = ZERO
            DO 80 I = K, M
               SUM = SUM + Q(I,J)*WA(I)
   80          CONTINUE
            TEMP = SUM/WA(K)
            DO 90 I = K, M
               Q(I,J) = Q(I,J) - TEMP*WA(I)
   90          CONTINUE
  100       CONTINUE
  110    CONTINUE
  120    CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE QFORM.
C
      END
      SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA)
      INTEGER M,N,LDA,LIPVT
      INTEGER IPVT(LIPVT)
      LOGICAL PIVOT
      REAL A(LDA,N),RDIAG(N),ACNORM(N),WA(N)
C     **********
C
C     SUBROUTINE QRFAC
C
C     THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN
C     PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE
C     M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL
C     MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL
C     MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE,
C     SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR
C     COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM
C
C                           T
C           I - (1/U(K))*U*U
C
C     WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF
C     THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST
C     APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA)
C
C     WHERE
C
C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF ROWS OF A.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF COLUMNS OF A.
C
C       A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR
C         WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT
C         THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT
C         UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL
C         PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL
C         ELEMENTS OF THE U VECTORS DESCRIBED ABOVE).
C
C       LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A.
C
C       PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE,
C         THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE,
C         THEN NO COLUMN PIVOTING IS DONE.
C
C       IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT
C         DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R.
C         COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
C         IF PIVOT IS FALSE, IPVT IS NOT REFERENCED.
C
C       LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE,
C         THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN
C         LIPVT MUST BE AT LEAST N.
C
C       RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
C         DIAGONAL ELEMENTS OF R.
C
C       ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
C         NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A.
C         IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE
C         WITH RDIAG.
C
C       WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA
C         CAN COINCIDE WITH RDIAG.
C
C     SUBPROGRAMS CALLED
C
C       MINPACK-SUPPLIED ... SPMPAR,ENORM
C
C       FORTRAN-SUPPLIED ... AMAX1,SQRT,MIN0
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,J,JP1,K,KMAX,MINMN
      REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO
      REAL SPMPAR,ENORM
      DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/
C
C     EPSMCH IS THE MACHINE PRECISION.
C
      EPSMCH = SPMPAR(1)
C
C     COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS.
C
      DO 10 J = 1, N
         ACNORM(J) = ENORM(M,A(1,J))
         RDIAG(J) = ACNORM(J)
         WA(J) = RDIAG(J)
         IF (PIVOT) IPVT(J) = J
   10    CONTINUE
C
C     REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS.
C
      MINMN = MIN0(M,N)
      DO 110 J = 1, MINMN
         IF (.NOT.PIVOT) GO TO 40
C
C        BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION.
C
         KMAX = J
         DO 20 K = J, N
            IF (RDIAG(K) .GT. RDIAG(KMAX)) KMAX = K
   20       CONTINUE
         IF (KMAX .EQ. J) GO TO 40
         DO 30 I = 1, M
            TEMP = A(I,J)
            A(I,J) = A(I,KMAX)
            A(I,KMAX) = TEMP
   30       CONTINUE
         RDIAG(KMAX) = RDIAG(J)
         WA(KMAX) = WA(J)
         K = IPVT(J)
         IPVT(J) = IPVT(KMAX)
         IPVT(KMAX) = K
   40    CONTINUE
C
C        COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE
C        J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR.
C
         AJNORM = ENORM(M-J+1,A(J,J))
         IF (AJNORM .EQ. ZERO) GO TO 100
         IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM
         DO 50 I = J, M
            A(I,J) = A(I,J)/AJNORM
   50       CONTINUE
         A(J,J) = A(J,J) + ONE
C
C        APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS
C        AND UPDATE THE NORMS.
C
         JP1 = J + 1
         IF (N .LT. JP1) GO TO 100
         DO 90 K = JP1, N
            SUM = ZERO
            DO 60 I = J, M
               SUM = SUM + A(I,J)*A(I,K)
   60          CONTINUE
            TEMP = SUM/A(J,J)
            DO 70 I = J, M
               A(I,K) = A(I,K) - TEMP*A(I,J)
   70          CONTINUE
            IF (.NOT.PIVOT .OR. RDIAG(K) .EQ. ZERO) GO TO 80
            TEMP = A(J,K)/RDIAG(K)
            RDIAG(K) = RDIAG(K)*SQRT(AMAX1(ZERO,ONE-TEMP**2))
            IF (P05*(RDIAG(K)/WA(K))**2 .GT. EPSMCH) GO TO 80
            RDIAG(K) = ENORM(M-J,A(JP1,K))
            WA(K) = RDIAG(K)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
         RDIAG(J) = -AJNORM
  110    CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE QRFAC.
C
      END
      SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA)
      INTEGER N,LDR
      INTEGER IPVT(N)
      REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N)
C     **********
C
C     SUBROUTINE QRSOLV
C
C     GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D,
C     AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH
C     SOLVES THE SYSTEM
C
C           A*X = B ,     D*X = 0 ,
C
C     IN THE LEAST SQUARES SENSE.
C
C     THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
C     IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
C     QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF
C     A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL
C     COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL
C     ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS
C     THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P,
C     AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM
C     A*X = B, D*X = 0, IS THEN EQUIVALENT TO
C
C                  T       T
C           R*Z = Q *B ,  P *D*P*Z = 0 ,
C
C     WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK,
C     THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV
C     ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT
C
C            T   T               T
C           P *(A *A + D*D)*P = S *S .
C
C     S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA)
C
C     WHERE
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
C
C       R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE
C         MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R.
C         ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE
C         STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE
C         (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S.
C
C       LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R.
C
C       IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE
C         PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P
C         IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
C
C       DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
C         DIAGONAL ELEMENTS OF THE MATRIX D.
C
C       QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
C         N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
C
C       X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST
C         SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0.
C
C       SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
C         DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S.
C
C       WA IS A WORK ARRAY OF LENGTH N.
C
C     SUBPROGRAMS CALLED
C
C       FORTRAN-SUPPLIED ... ABS,SQRT
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,J,JP1,K,KP1,L,NSING
      REAL COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO
      DATA P5,P25,ZERO /5.0E-1,2.5E-1,0.0E0/
C
C     COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S.
C     IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X.
C
      DO 20 J = 1, N
         DO 10 I = J, N
            R(I,J) = R(J,I)
   10       CONTINUE
         X(J) = R(J,J)
         WA(J) = QTB(J)
   20    CONTINUE
C
C     ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION.
C
      DO 100 J = 1, N
C
C        PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE
C        DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION.
C
         L = IPVT(J)
         IF (DIAG(L) .EQ. ZERO) GO TO 90
         DO 30 K = J, N
            SDIAG(K) = ZERO
   30       CONTINUE
         SDIAG(J) = DIAG(L)
C
C        THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D
C        MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B
C        BEYOND THE FIRST N, WHICH IS INITIALLY ZERO.
C
         QTBPJ = ZERO
         DO 80 K = J, N
C
C           DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
C           APPROPRIATE ELEMENT IN THE CURRENT ROW OF D.
C
            IF (SDIAG(K) .EQ. ZERO) GO TO 70
            IF (ABS(R(K,K)) .GE. ABS(SDIAG(K))) GO TO 40
               COTAN = R(K,K)/SDIAG(K)
               SIN = P5/SQRT(P25+P25*COTAN**2)
               COS = SIN*COTAN
               GO TO 50
   40       CONTINUE
               TAN = SDIAG(K)/R(K,K)
               COS = P5/SQRT(P25+P25*TAN**2)
               SIN = COS*TAN
   50       CONTINUE
C
C           COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND
C           THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0).
C
            R(K,K) = COS*R(K,K) + SIN*SDIAG(K)
            TEMP = COS*WA(K) + SIN*QTBPJ
            QTBPJ = -SIN*WA(K) + COS*QTBPJ
            WA(K) = TEMP
C
C           ACCUMULATE THE TRANFORMATION IN THE ROW OF S.
C
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 70
            DO 60 I = KP1, N
               TEMP = COS*R(I,K) + SIN*SDIAG(I)
               SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I)
               R(I,K) = TEMP
   60          CONTINUE
   70       CONTINUE
   80       CONTINUE
   90    CONTINUE
C
C        STORE THE DIAGONAL ELEMENT OF S AND RESTORE
C        THE CORRESPONDING DIAGONAL ELEMENT OF R.
C
         SDIAG(J) = R(J,J)
         R(J,J) = X(J)
  100    CONTINUE
C
C     SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS
C     SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION.
C
      NSING = N
      DO 110 J = 1, N
         IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1
         IF (NSING .LT. N) WA(J) = ZERO
  110    CONTINUE
      IF (NSING .LT. 1) GO TO 150
      DO 140 K = 1, NSING
         J = NSING - K + 1
         SUM = ZERO
         JP1 = J + 1
         IF (NSING .LT. JP1) GO TO 130
         DO 120 I = JP1, NSING
            SUM = SUM + R(I,J)*WA(I)
  120       CONTINUE
  130    CONTINUE
         WA(J) = (WA(J) - SUM)/SDIAG(J)
  140    CONTINUE
  150 CONTINUE
C
C     PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X.
C
      DO 160 J = 1, N
         L = IPVT(J)
         X(L) = WA(J)
  160    CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE QRSOLV.
C
      END
      SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
      INTEGER M,N,LDA
      REAL A(LDA,N),V(N),W(N)
C     **********
C
C     SUBROUTINE R1MPYQ
C
C     GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE
C     Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS
C
C           GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C     AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH
C     ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY.
C     Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE
C     GV, GW ROTATIONS IS SUPPLIED.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE R1MPYQ(M,N,A,LDA,V,W)
C
C     WHERE
C
C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF ROWS OF A.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF COLUMNS OF A.
C
C       A IS AN M BY N ARRAY. ON INPUT A MUST CONTAIN THE MATRIX
C         TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q
C         DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A.
C
C       LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
C         WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A.
C
C       V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE
C         INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I)
C         DESCRIBED ABOVE.
C
C       W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE
C         INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I)
C         DESCRIBED ABOVE.
C
C     SUBROUTINES CALLED
C
C       FORTRAN-SUPPLIED ... ABS,SQRT
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
C
C     **********
      INTEGER I,J,NMJ,NM1
      REAL COS,ONE,SIN,TEMP
      DATA ONE /1.0E0/
C
C     APPLY THE FIRST SET OF GIVENS ROTATIONS TO A.
C
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 50
      DO 20 NMJ = 1, NM1
         J = N - NMJ
         IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J)
         IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(V(J)) .LE. ONE) SIN = V(J)
         IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 10 I = 1, M
            TEMP = COS*A(I,J) - SIN*A(I,N)
            A(I,N) = SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   10       CONTINUE
   20    CONTINUE
C
C     APPLY THE SECOND SET OF GIVENS ROTATIONS TO A.
C
      DO 40 J = 1, NM1
         IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J)
         IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2)
         IF (ABS(W(J)) .LE. ONE) SIN = W(J)
         IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2)
         DO 30 I = 1, M
            TEMP = COS*A(I,J) + SIN*A(I,N)
            A(I,N) = -SIN*A(I,J) + COS*A(I,N)
            A(I,J) = TEMP
   30       CONTINUE
   40    CONTINUE
   50 CONTINUE
      RETURN
C
C     LAST CARD OF SUBROUTINE R1MPYQ.
C
      END
      SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
      INTEGER M,N,LS
      LOGICAL SING
      REAL S(LS),U(M),V(N),W(M)
C     **********
C
C     SUBROUTINE R1UPDT
C
C     GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U,
C     AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN
C     ORTHOGONAL MATRIX Q SUCH THAT
C
C                   T
C           (S + U*V )*Q
C
C     IS AGAIN LOWER TRAPEZOIDAL.
C
C     THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1)
C     TRANSFORMATIONS
C
C           GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
C
C     WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE
C     WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES,
C     RESPECTIVELY. Q ITSELF IS NOT ACCUMULATED, RATHER THE
C     INFORMATION TO RECOVER THE GV, GW ROTATIONS IS RETURNED.
C
C     THE SUBROUTINE STATEMENT IS
C
C       SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)
C
C     WHERE
C
C       M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF ROWS OF S.
C
C       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
C         OF COLUMNS OF S. N MUST NOT EXCEED M.
C
C       S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER
C         TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS
C         THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE.
C
C       LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
C         (N*(2*M-N+1))/2.
C
C       U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE
C         VECTOR U.
C
C       V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR
C         V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO
C         RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE.
C
C       W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION
C         NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED
C         ABOVE.
C
C       SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY
C         OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE
C         SING IS SET FALSE.
C
C     SUBPROGRAMS CALLED
C
C       MINPACK-SUPPLIED ... SPMPAR
C
C       FORTRAN-SUPPLIED ... ABS,SQRT
C
C     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
C     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE,
C     JOHN L. NAZARETH
C
C     **********
      INTEGER I,J,JJ,L,NMJ,NM1
      REAL COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,ZERO
      REAL SPMPAR
      DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/
C
C     GIANT IS THE LARGEST MAGNITUDE.
C
      GIANT = SPMPAR(3)
C
C     INITIALIZE THE DIAGONAL ELEMENT POINTER.
C
      JJ = (N*(2*M - N + 1))/2 - (M - N)
C
C     MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W.
C
      L = JJ
      DO 10 I = N, M
         W(I) = S(L)
         L = L + 1
   10    CONTINUE
C
C     ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR
C     IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W.
C
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 NMJ = 1, NM1
         J = N - NMJ
         JJ = JJ - (M - J + 1)
         W(J) = ZERO
         IF (V(J) .EQ. ZERO) GO TO 50
C
C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
C        J-TH ELEMENT OF V.
C
         IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20
            COTAN = V(N)/V(J)
            SIN = P5/SQRT(P25+P25*COTAN**2)
            COS = SIN*COTAN
            TAU = ONE
            IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
            GO TO 30
   20    CONTINUE
            TAN = V(J)/V(N)
            COS = P5/SQRT(P25+P25*TAN**2)
            SIN = COS*TAN
            TAU = SIN
   30    CONTINUE
C
C        APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION
C        NECESSARY TO RECOVER THE GIVENS ROTATION.
C
         V(N) = SIN*V(J) + COS*V(N)
         V(J) = TAU
C
C        APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W.
C
         L = JJ
         DO 40 I = J, M
            TEMP = COS*S(L) - SIN*W(I)
            W(I) = SIN*S(L) + COS*W(I)
            S(L) = TEMP
            L = L + 1
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     ADD THE SPIKE FROM THE RANK 1 UPDATE TO W.
C
      DO 80 I = 1, M
         W(I) = W(I) + V(N)*U(I)
   80    CONTINUE
C
C     ELIMINATE THE SPIKE.
C
      SING = .FALSE.
      IF (NM1 .LT. 1) GO TO 140
      DO 130 J = 1, NM1
         IF (W(J) .EQ. ZERO) GO TO 120
C
C        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
C        J-TH ELEMENT OF THE SPIKE.
C
         IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90
            COTAN = S(JJ)/W(J)
            SIN = P5/SQRT(P25+P25*COTAN**2)
            COS = SIN*COTAN
            TAU = ONE
            IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS
            GO TO 100
   90    CONTINUE
            TAN = W(J)/S(JJ)
            COS = P5/SQRT(P25+P25*TAN**2)
            SIN = COS*TAN
            TAU = SIN
  100    CONTINUE
C
C        APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W.
C
         L = JJ
         DO 110 I = J, M
            TEMP = COS*S(L) + SIN*W(I)
            W(I) = -SIN*S(L) + COS*W(I)
            S(L) = TEMP
            L = L + 1
  110       CONTINUE
C
C        STORE THE INFORMATION NECESSARY TO RECOVER THE
C        GIVENS ROTATION.
C
         W(J) = TAU
  120    CONTINUE
C
C        TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S.
C
         IF (S(JJ) .EQ. ZERO) SING = .TRUE.
         JJ = JJ + (M - J + 1)
  130    CONTINUE
  140 CONTINUE
C
C     MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S.
C
      L = JJ
      DO 150 I = N, M
         S(L) = W(I)
         L = L + 1
  150    CONTINUE
      IF (S(JJ) .EQ. ZERO) SING = .TRUE.
      RETURN
C
C     LAST CARD OF SUBROUTINE R1UPDT.
C
      END
      SUBROUTINE SMPLX (A,B0,C,KA,M,N0,IND,IBASIS,X,Z,ITER,MXITER,
     *                       NUMLE,NUMGE,BI,WK,IWK)
C-----------------------------------------------------------------------
C     SIMPLEX PROCEDURE FOR SOLVING LINEAR PROGRAMMING PROBLEMS
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS JR.
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C------------------------
C     INITIAL VERSION  DEC  1977
C     LAST UPDATE      OCT  1990
C------------------------
      DIMENSION A(KA,N0),B0(M),C(N0)
      DIMENSION IBASIS(M),BI(M,M)
      DIMENSION X(*),WK(*),IWK(*)
C------------------------
C     DIMENSION X(N0+NUMLE+NUMGE)
C     DIMENSION WK(2*M),IWK(2*M+N0)
C------------------------
C
C     ********** EPS0 IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS0
C                THE VALUE U WHERE U IS THE SMALLEST POSITIVE FLOATING
C                POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0.
C
                          EPS0 = SPMPAR(1)
C
C------------------------
      RERRMN = 10.0*EPS0
      RERRMX = 1.E-4
      IF (EPS0 .LT. 1.E-13) RERRMX = 1.E-5
C
      IP = M + N0 + 1
      CALL SMPLX1(A,B0,C,KA,M,N0,IND,IBASIS,X,Z,ITER,MXITER,
     1            EPS0,RERRMN,RERRMX,RERR,NUMLE,NUMGE,BI,
     2            WK(1),WK(M+1),IWK(1),IWK(IP))
      RETURN
      END
      SUBROUTINE SMPLX1 (A,B0,C,KA,M,N0,IND,IBASIS,R,Z,ITER,MXITER,
     *     EPS0,RERRMN,RERRMX,RERR,NUMLE,NUMGE,BI,XB,Y,BASIS,INDEX)
C----------------------
C     NSTEP = 1   ELIMINATE THE NEGATIVE VARIABLES
C     NSTEP = 2   PHASE 1 OF THE SIMPLEX ALGORITHM
C     NSTEP = 3   PHASE 2 OF THE SIMPLEX ALGORITHM
C----------------------
C     MXITER = THE MAXIMUM NUMBER OF ITERATIONS PERMITTED
C     ITER = THE NUMBER OF THE CURRENT ITERATION
C     ICOUNT = THE NUMBER OF ITERATIONS SINCE THE LAST INVERSION
C----------------------
C     NUMLE = THE NUMBER OF .LE. CONSTRAINTS
C     NUMGE = THE NUMBER OF .GE. CONSTRAINTS
C----------------------
C     THE ROUTINE ASSUMES THAT THE .LE. CONSTRAINTS PRECEDE THE .GE.
C     CONSTRAINTS AND THAT THE .EQ. CONSTRAINTS COME LAST. THERE ARE
C     M CONSTRAINTS. X(N0+I) IS THE SLACK, SURPLUS, OR ARTIFICIAL
C     VARIABLE FOR THE I-TH CONSTRAINT (I=1,...,M).
C----------------------
C     N0 = THE NUMBER OF ORGINAL VARIABLES
C     NS = THE NUMBER OF ORGINAL AND SLACK VARIABLES
C     N  = THE NUMBER OF ORGINAL, SLACK, AND SURPLUS VARIABLES
C     NUM = THE TOTAL NUMBER OF VARIABLES
C----------------------
C     RERRMN = THE SMALLEST RELATIVE ERROR TOLERANCE USED
C     RERRMX = THE LARGEST RELATIVE ERROR TOLERACE USED
C     RERR   = THE ESTIMATED CURRENT RELATIVE ERROR
C----------------------
C     ASSUME THAT
C         B0 = (B0(1),...,B0(M))
C         C  = (C(1),...,C(N0))
C         Z  = C(1)*X(1)+...+C(N0)*X(N0)
C     THE PROBLEM IS TO MAXIMIZE Z SUBJECT TO
C         AX(LE,EQ,GE)B0
C         X.GE.0
C----------------------
C     ON INPUT IND CAN HAVE THE VALUES
C         IND = 0   NO BEGINNING BASIS IS PROVIDED BY THE USER
C         IND = 1   THE ARRAY IBASIS HAS BEEN SET BY THE USER
C     ON OUTPUT IND IS ASSIGNED ONE OF THE VALUES
C         IND = 0   Z WAS SUCCESSFULLY MAXIMIZED
C         IND = 1   THE PROBLEM HAS NO FEASIBLE SOLUTION
C         IND = 2   MXITER ITERATIONS WERE PERFORMED
C         IND = 3   SUFFICIENT ACCURACY CANNOT BE MAINTAINED
C         IND = 4   THE PROBLEM HAS AN UNBOUNDED SOLUTION
C         IND = 5   THERE IS AN INPUT ERROR
C         IND = 6   Z WAS POSSIBLY MAXIMIZED
C----------------------
C     BASIS IS AN INTEGER ARRAY OF DIMENSION N0+M. FOR J.LE.N
C         BASIS(J) = 1  IF X(J) IS A BASIC VARIABLE
C         BASIS(J) = 0  IF X(J) IS NOT A BASIC VARIABLE
C     IF THE BASIC VARIABLES ARE X(I1),...,X(IM) THEN
C         IBASIS = (I1,...,IM)
C     ALSO XB(1),...,XB(M) ARE THE CORRESPONDING VALUES OF THE
C     BASIC VARIABLES.
C----------------------
C     BI IS AN MXM ARRAY CONTAINING THE INVERSE OF THE BASIS MATRIX.
C----------------------
C     R IS AN ARRAY OF DIMENSION N. ON OUTPUT R CONTAINS THE CURRENT
C     VALUE OF X. DURING COMPUTATION R NORMALLY CONTAINS THE REDUCED
C     COSTS USED FOR THE SELECTION OF THE VARIABLE TO BE MADE BASIC.
C----------------------
      REAL A(KA,N0), B0(M), C(N0)
      REAL BI(M,M), XB(M), Y(M), R(*)
      INTEGER IBASIS(M), BASIS(*)
      INTEGER BFLAG, INDEX(M)
      DOUBLE PRECISION DSUM, DSUMP, DSUMN, DT
C----------------------
C
C     ****** XMAX IS A MACHINE DEPENDENT CONSTANT. XMAX IS THE
C            LARGEST POSITIVE FLOATING POINT NUMBER.
C
                 XMAX = SPMPAR(3)
C
C----------------------
      ITER = 0
      ICOUNT = 0
      MCHECK = MIN0(5,1 + M/15)
      Z = 0.0
C
C                CHECK FOR INPUT ERRORS
C
      MS = NUMLE + NUMGE
      IF (M .LT. 2 .OR. N0 .LT. 2 .OR. MS .GT. M .OR. KA .LT. M)
     *   GO TO 12
      DO 10 I = 1,M
         IF (B0(I) .LT. 0.0) GO TO 12
   10    XB(I) = 0.0
      RTOL = XMAX
      DO 11 I = 1,N0
         IF (C(I) .NE. 0.0) RTOL = AMIN1(ABS(C(I)),RTOL)
   11 CONTINUE
      RTOL = RERRMX*RTOL
      GO TO 20
C
   12 IND = 5
      RETURN
C
C     FORMATION OF THE IBASIS AND BASIS ARRAYS. (IF IND = 1
C     THEN THE IBASIS ARRAY IS DEFINED BY THE USER.)
C
   20 NS = N0 + NUMLE
      N = NS + NUMGE
      IF (IND .EQ. 0) GO TO 30
      NUM = N
      DO 21 I = 1,M
         IF (IBASIS(I) .GT. N) NUM = NUM + 1
   21 CONTINUE
      GO TO 32
   22 IF (IND .EQ. 0) GO TO 590
      IND = 0
C
   30 NUM = N0 + M
      DO 31 I = 1,M
   31    IBASIS(I) = N0 + I
   32 BFLAG = 0
      DO 33 I = 1,N
   33    BASIS(I) = 0
      DO 34 I = 1,M
         KI = IBASIS(I)
   34    BASIS(KI) = 1
      IF (IND .EQ. 1) GO TO 100
C
C          CALCULATION OF XB AND BI WHEN IND = 0
C
      RERR = RERRMN
      DO 41 J = 1,M
         XB(J) = B0(J)
         DO 40 I = 1,M
   40       BI(I,J) = 0.0
         BI(J,J) = 1.0
   41 CONTINUE
      IF (NUMGE .EQ. 0) GO TO 630
      JMIN = NUMLE + 1
      DO 42 J = JMIN,MS
         XB(J) = -XB(J)
         BI(J,J) = -1.0
   42 CONTINUE
      GO TO 601
C
C                  REORDER THE BASIS
C
  100 IBEG = 1
      IEND = M
      DO 102 I = 1,M
         IF (IBASIS(I) .LE. N0) GO TO 101
            INDEX(IBEG) = IBASIS(I)
            IBEG = IBEG + 1
            GO TO 102
  101    INDEX(IEND) = IBASIS(I)
         IEND = IEND - 1
  102 CONTINUE
      IF (IEND .EQ. M) GO TO 22
      DO 103 I = 1,M
  103    IBASIS(I) = INDEX(I)
C
C            REINVERSION OF THE BASIS MATRIX
C
      DO 132 J = 1,M
         KJ = IBASIS(J)
         IF (KJ .LE. N0) GO TO 110
         IF (KJ .LE. NS) GO TO 120
         IF (KJ .LE. N) GO TO 130
         GO TO 120
C
  110    DO 111 I = 1,M
  111       BI(I,J) = A(I,KJ)
         GO TO 132
C
  120    L = KJ - N0
         DO 121 I = 1,M
  121       BI(I,J) = 0.0
         BI(L,J) = 1.0
         GO TO 132
C
  130    L = KJ - N0
         DO 131 I = 1,M
  131       BI(I,J) = 0.0
         BI(L,J) = -1.0
  132 CONTINUE
C
      ICOUNT = 0
      CALL CROUT1 (BI, M, M, IEND, INDEX, Y, JCOL, IERR)
      IF (IERR .NE. 0) GO TO 580
C
C         CHECK THE ACCURACY OF BI AND RESET RERR
C
      BNORM = 0.0
      DO 142 J = 1,M
         KJ = IBASIS(J)
         IF (KJ .LE. N0) GO TO 140
            SUM = 1.0
            GO TO 142
  140    SUM = 0.0
         DO 141 I = 1,M
  141       SUM = SUM + ABS(A(I,KJ))
  142    BNORM = AMAX1(BNORM,SUM)
C
      BINORM = 0.0
      DO 151 J = 1,M
         SUM = 0.0
         DO 150 I = 1,M
  150       SUM = SUM + ABS(BI(I,J))
         BINORM = AMAX1(BINORM,SUM)
  151 CONTINUE
      RERR = AMAX1(RERRMN,EPS0*BNORM*BINORM)
      IF (RERR .GT. 1.E-2) GO TO 580
      BFLAG = 0
C
C                 RECALCULATION OF XB
C
  180 DO 183 I = 1,M
         DSUMP = 0.D0
         DSUMN = 0.D0
         DO 182 L = 1,M
            DT = BI(I,L)*B0(L)
            IF (DT .GT. 0.D0) GO TO 181
               DSUMN = DSUMN + DT
               GO TO 182
  181       DSUMP = DSUMP + DT
  182    CONTINUE
         XB(I) = DSUMP + DSUMN
         S = DSUMP
         T = DSUMN
         TOL = RERRMX*AMAX1(S,-T)
         IF (ABS(XB(I)) .LT. TOL) XB(I) = 0.0
  183 CONTINUE
      GO TO 601
C
C     FIND THE NEXT VECTOR A(--,JP) TO BE INSERTED INTO
C                       THE BASIS
C
  200 JP = 0
      RMIN = 0.0
      IF (NSTEP .EQ. 3) RMIN = -RTOL
      DO 201 J = 1,N0
         IF (BASIS(J) .NE. 0) GO TO 201
         IF (R(J) .GE. RMIN) GO TO 201
         JP = J
         RMIN = R(J)
  201 CONTINUE
      IF (N0 .EQ. N) GO TO 203
      JMIN = N0 + 1
      RMIN = RMIN*1.1
      DO 202 J = JMIN,N
         IF (BASIS(J) .NE. 0) GO TO 202
         IF (R(J) .GE. RMIN) GO TO 202
         JP = J
         RMIN = R(J)
  202 CONTINUE
  203 IF (JP .NE. 0) GO TO 300
      IF (NSTEP - 2) 800,230,250
C
C     INSERT THE VALUES OF THE ORGINAL, SLACK, AND SURPLUS
C             VARIABLES INTO R. THEN TERMINATE.
C
  220 DO 221 J = 1,N
  221    R(J) = 0.0
      DO 222 I = 1,M
         KI = IBASIS(I)
         IF (KI .LE. N) R(KI) = XB(I)
  222 CONTINUE
      RETURN
C
C             COMPLETION OF THE NSTEP = 2 CASE
C
  230 DO 231 I = 1,M
         IF (IBASIS(I) .LE. N) GO TO 231
         IF (XB(I) .GT. 0.0) GO TO 800
  231 CONTINUE
      GO TO 680
C
  240 IF (ICOUNT .GE. 5) GO TO 100
      IND = 1
      GO TO 220
C
C             COMPLETION OF THE NSTEP = 3 CASE
C
  250 IF (RERR .GT. 1.E-2) GO TO 251
         IND = 0
         GO TO 800
  251 IF (ICOUNT .GE. 5) GO TO 100
      IND = 6
      GO TO 800
C
C     IF MXITER ITERATIONS HAVE NOT BEEN PERFORMED THEN
C     BEGIN THE NEXT ITERATION. COMPUTE THE JP-TH COLUMN
C               OF BI*A AND STORE IT IN Y.
C
  300 IF (ITER .LT. MXITER) GO TO 301
         IND = 2
         GO TO 220
  301 ITER = ITER + 1
      ICOUNT = ICOUNT + 1
      IF (JP .GT. NS) GO TO 330
      IF (JP .GT. N0) GO TO 320
C
      NROW = 0
      AMAX = 0.0
      DO 305 I = 1,M
         IF (A(I,JP) .EQ. 0.0) GO TO 305
         NROW = NROW + 1
         INDEX(NROW) = I
         AMAX = AMAX1(ABS(A(I,JP)),AMAX)
  305 CONTINUE
      IF (NROW .NE. 0) GO TO 310
      IND = 4
      GO TO 220
C
  310 RERR1 = RERRMX*AMAX
      DO 313 I = 1,M
         DSUM = 0.D0
         DO 311 LL = 1,NROW
            L = INDEX(LL)
            DSUM = DSUM + DBLE(BI(I,L)*A(L,JP))
  311    CONTINUE
         Y(I) = DSUM
         IF (ABS(Y(I)) .GE. 5.E-3) GO TO 313
         BMAX = 0.0
         DO 312 L = 1,M
            BMAX = AMAX1(ABS(BI(I,L)),BMAX)
  312    CONTINUE
         TOL = RERR1*BMAX
         IF (ABS(Y(I)) .LT. TOL) Y(I) = 0.0
  313 CONTINUE
      GO TO 350
C
  320 L = JP - N0
      DO 321 I = 1,M
         Y(I) = BI(I,L)
  321 CONTINUE
      GO TO 350
C
  330 L = JP - N0
      DO 331 I = 1,M
         Y(I) = -BI(I,L)
  331 CONTINUE
C
  350 DO 351 I = 1,M
         IF (Y(I) .NE. 0.0) GO TO 360
  351 CONTINUE
      R(JP) = 0.0
      ITER = ITER - 1
      ICOUNT = ICOUNT - 1
      GO TO 200
C
  360 IF (NSTEP - 2) 400,430,440
C
C     FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC
C               FOR THE NSTEP = 1 CASE
C
  400 NPOS = 0
      IP = 0
      EPS = 0.0
      EPSI = XMAX
      DO 403 I = 1,M
         IF (XB(I) .LT. 0.0 .OR. Y(I) .LE. 0.0) GO TO 403
         RATIO = XB(I)/Y(I)
         IF (RATIO - EPSI) 401,402,403
  401    EPSI = RATIO
         NPOS = 1
         INDEX(1) = I
         GO TO 403
  402    NPOS = NPOS + 1
         INDEX(NPOS) = I
  403 CONTINUE
      IF (NPOS .EQ. 0) GO TO 420
      IF (EPSI .EQ. 0.0) GO TO 460
C
      DO 410 I = 1,M
         IF (XB(I) .GE. 0.0 .OR. Y(I) .GE. 0.0) GO TO 410
         RATIO = XB(I)/Y(I)
         IF (RATIO .GT. EPSI) GO TO 410
         IF (RATIO .LT. EPS) GO TO 410
         EPS = RATIO
         IP = I
  410 CONTINUE
      IF (IP .NE. 0) GO TO 500
      GO TO 460
C
  420 DO 421 I = 1,M
         IF (XB(I) .GE. 0.0 .OR. Y(I) .GE. 0.0) GO TO 421
         RATIO = XB(I)/Y(I)
         IF (RATIO .LT. EPS) GO TO 421
         EPS = RATIO
         IP = I
  421 CONTINUE
      GO TO 500
C
C     FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC
C               FOR THE NSTEP = 2 CASE
C
  430 NPOS = 0
      EPSI = XMAX
      DO 433 I = 1,M
         IF (Y(I) .LE. 0.0) GO TO 433
         RATIO = XB(I)/Y(I)
         IF (RATIO - EPSI) 431,432,433
  431    EPSI = RATIO
         NPOS = 1
         INDEX(1) = I
         GO TO 433
  432    NPOS = NPOS + 1
         INDEX(NPOS) = I
  433 CONTINUE
      GO TO 450
C
C     FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC
C               FOR THE NSTEP = 3 CASE
C
  440 NPOS = 0
      EPSI = XMAX
      DO 445 I = 1,M
         IF (Y(I)) 441,445,442
  441    IF (IBASIS(I) .LE. N) GO TO 445
         IP = I
         GO TO 500
  442    RATIO = XB(I)/Y(I)
         IF (RATIO - EPSI) 443,444,445
  443       EPSI = RATIO
            NPOS = 1
            INDEX(1) = I
            GO TO 445
  444       NPOS = NPOS + 1
            INDEX(NPOS) = I
  445 CONTINUE
C
  450 IF (NPOS .NE. 0) GO TO 460
      IF (ICOUNT .GE. 5) GO TO 100
      IND = 4
      GO TO 220
C
C              TIE BREAKING PROCEDURE
C
  460 IP = INDEX(1)
      IF (NPOS .EQ. 1) GO TO 500
      IP = 0
      BMIN = XMAX
      CMIN = XMAX
      DO 464 II = 1,NPOS
         I = INDEX(II)
         L = IBASIS(I)
         IF (L .GT. N0) GO TO 461
            IF (C(L) .LE. 0.0) CMIN = AMIN1(0.0,CMIN)
            IF (C(L) .GT. CMIN) GO TO 464
            IMIN = I
            CMIN = C(L)
            GO TO 464
  461    IF (L .LE. N) GO TO 462
            IP = I
            GO TO 500
  462    LROW = L - N0
         S = B0(LROW)
         IF (LROW .GT. NUMLE) GO TO 463
            IF (S .GT. BMIN) GO TO 464
            IP = I
            BMIN = S
            GO TO 464
  463    S = -S
         BMIN = AMIN1(0.0,BMIN)
         IF (S .GT. BMIN) GO TO 464
         IP = I
         BMIN = S
  464 CONTINUE
      IF (CMIN .LE. 0.0 .OR. IP .EQ. 0) IP = IMIN
C
C               TRANSFORMATION OF XB
C
  500 IF (XB(IP) .EQ. 0.0) GO TO 510
      CONST = XB(IP)/Y(IP)
      DO 501 I = 1,M
         S = XB(I)
         XB(I) = XB(I) - CONST*Y(I)
         IF (XB(I) .GE. 0.0) GO TO 501
         IF (S .GE. 0.0 .OR. XB(I) .GE. RERRMX*S) XB(I) = 0.0
  501 CONTINUE
      XB(IP) = CONST
C
C               TRANSFORMATION OF BI
C
  510 DO 512 J = 1,M
         IF (BI(IP,J) .EQ. 0.0) GO TO 512
         CONST = BI(IP,J)/Y(IP)
         DO 511 I = 1,M
  511       BI(I,J) = BI(I,J) - CONST*Y(I)
         BI(IP,J) = CONST
  512 CONTINUE
C
C             UPDATING IBASIS AND BASIS
C
      IOUT = IBASIS(IP)
      IBASIS(IP) = JP
      BASIS(IOUT) = 0
      BASIS(JP) = 1
      IF (IOUT .GT. N) NUM = NUM - 1
C
C        CHECK THE ACCURACY OF BI AND RESET RERR
C
      IF (RERR .GT. 1.E-2) GO TO 530
      K = 0
      DO 521 J = 1,M
         KJ = IBASIS(J)
         IF (KJ .GT. N0) GO TO 521
         SUM = 0.0
         DO 520 L = 1,M
            IF (A(L,KJ) .NE. 0.0) SUM = SUM + BI(J,L)*A(L,KJ)
  520    CONTINUE
         RERR = AMAX1(RERR,ABS(1.0 - SUM))
         K = K + 1
         IF (K .GE. MCHECK) GO TO 522
  521 CONTINUE
  522 IF (RERR .LE. 1.E-2) GO TO 600
C
C        THE ACCURACY CRITERIA ARE NOT SATISFIED
C
  530 IF (ICOUNT .LT. 5) GO TO 600
      BFLAG = 1
      GO TO 100
C
  580 IF (ITER .EQ. 0) GO TO 12
      IF (BFLAG .EQ. 0) GO TO 590
      BFLAG = 0
      DO 581 IP = 1,M
         IF (JP .EQ. IBASIS(IP)) GO TO 582
  581 CONTINUE
  582 IBASIS(IP) = IOUT
      BASIS(JP) = 0
      BASIS(IOUT) = 1
      IF (IOUT .GT. N) NUM = NUM + 1
      GO TO 100
C
  590 IND = 3
      GO TO 220
C
C       SET UP THE R ARRAY FOR THE NSTEP = 1 CASE
C
  600 IF (NSTEP - 2) 601,630,700
  601 DO 602 J = 1,M
         IF (XB(J) .LT. 0.0) GO TO 610
  602 CONTINUE
      GO TO 630
C
  610 NSTEP = 1
      M0 = 0
      DO 611 L = 1,M
         IF (XB(L) .GE. 0.0) GO TO 611
         M0 = M0 + 1
         INDEX(M0) = L
  611 CONTINUE
C
      DO 623 J = 1,M
         DSUMP = 0.D0
         DSUMN = 0.D0
         DO 622 LL = 1,M0
            L = INDEX(LL)
            IF (BI(L,J)) 620,622,621
  620       DSUMN = DSUMN + DBLE(BI(L,J))
            GO TO 622
  621       DSUMP = DSUMP + DBLE(BI(L,J))
  622    CONTINUE
         Y(J) = DSUMP + DSUMN
         S = DSUMP
         T = DSUMN
         TOL = RERRMX*AMAX1(S,-T)
         IF (ABS(Y(J)) .LT. TOL) Y(J) = 0.0
  623 CONTINUE
      GO TO 650
C
C       SET UP THE R ARRAY FOR THE NSTEP = 2 CASE
C
  630 IF (N .EQ. NUM) GO TO 680
      NSTEP = 2
      M0 = 0
      DO 631 L = 1,M
         IF (IBASIS(L) .LE. N) GO TO 631
         M0 = M0 + 1
         INDEX(M0) = L
  631 CONTINUE
C
      DO 643 J = 1,M
         DSUMP = 0.D0
         DSUMN = 0.D0
         DO 642 LL = 1,M0
            L = INDEX(LL)
            IF (BI(L,J)) 640,642,641
  640       DSUMN = DSUMN + DBLE(BI(L,J))
            GO TO 642
  641       DSUMP = DSUMP + DBLE(BI(L,J))
  642    CONTINUE
         Y(J) = -(DSUMP + DSUMN)
         S = DSUMP
         T = DSUMN
         TOL = RERRMX*AMAX1(S,-T)
         IF (ABS(Y(J)) .LT. TOL) Y(J) = 0.0
  643 CONTINUE
C
  650 DO 652 J = 1,N0
         SUM = 0.0
         IF (BASIS(J) .NE. 0) GO TO 652
         DO 651 L = 1,M
            IF (A(L,J) .NE. 0.0) SUM = SUM + Y(L)*A(L,J)
  651    CONTINUE
  652    R(J) = SUM
C
  660 IF (N0 .EQ. NS) GO TO 670
      JMIN = N0 + 1
      DO 661 J = JMIN,NS
         R(J) = 0.0
         IF (BASIS(J) .NE. 0) GO TO 661
         JJ = J - N0
         R(J) = Y(JJ)
  661 CONTINUE
C
  670 IF (NS .EQ. N) GO TO 200
      JMIN = NS + 1
      DO 671 J = JMIN,N
         R(J) = 0.0
         IF (BASIS(J) .NE. 0) GO TO 671
         JJ = J - N0
         R(J) = -Y(JJ)
  671 CONTINUE
      GO TO 200
C
C      SET UP A NEW R ARRAY FOR THE NSTEP = 3 CASE
C
  680 NSTEP = 3
      DO 682 J = 1,M
         DSUM = 0.D0
         DO 681 L = 1,M
            IL = IBASIS(L)
            IF (IL .LE. N0) DSUM = DSUM + DBLE(C(IL)*BI(L,J))
  681    CONTINUE
  682    Y(J) = DSUM
C
      DO 691 J = 1,N0
         R(J) = 0.0
         IF (BASIS(J) .NE. 0) GO TO 691
         DSUM = -C(J)
         DO 690 L = 1,M
            IF (A(L,J) .NE. 0.0) DSUM = DSUM + DBLE(Y(L)*A(L,J))
  690    CONTINUE
         R(J) = DSUM
         IF (R(J) .GE. 0.0) GO TO 691
         TOL = RERRMX*ABS(C(J))
         IF (ABS(R(J)) .LT. TOL) R(J) = 0.0
  691 CONTINUE
      GO TO 660
C
C       UPDATE THE R ARRAY FOR THE NSTEP = 3 CASE
C
  700 CONST = R(JP)
      DO 703 J = 1,N0
         IF (BASIS(J) .EQ. 0) GO TO 701
            R(J) = 0.0
            GO TO 703
  701    SUM = 0.0
         DO 702 L = 1,M
            IF (A(L,J) .NE. 0.0) SUM = SUM + BI(IP,L)*A(L,J)
  702    CONTINUE
         R(J) = R(J) - CONST*SUM
         IF (R(J) .GE. 0.0) GO TO 703
         TOL = RERRMX*ABS(C(J))
         IF (ABS(R(J)) .LT. TOL) R(J) = 0.0
  703 CONTINUE
C
  710 IF (N0 .EQ. NS) GO TO 720
      JMIN = N0 + 1
      DO 712 J = JMIN,NS
         IF (BASIS(J) .EQ. 0) GO TO 711
            R(J) = 0.0
            GO TO 712
  711    JJ = J - N0
         R(J) = R(J) - CONST*BI(IP,JJ)
  712 CONTINUE
C
  720 IF (NS .EQ. N) GO TO 200
      JMIN = NS + 1
      DO 722 J = JMIN,N
         IF (BASIS(J) .EQ. 0) GO TO 721
            R(J) = 0.0
            GO TO 722
  721    JJ = J - N0
         R(J) = R(J) + CONST*BI(IP,JJ)
  722 CONTINUE
      GO TO 200
C-----------------------------------------------------------------------
C               REFINE XB AND STORE THE RESULT IN Y
C-----------------------------------------------------------------------
  800 DO 801 I = 1,M
         Y(I) = 0.0
  801 CONTINUE
C
      M0 = 0
      DO 831 J = 1,M
         KJ = IBASIS(J)
         IF (KJ .LE. N0) GO TO 810
         IF (KJ .LE. NS) GO TO 820
         IF (KJ .LE. N) GO TO 830
         GO TO 820
C
  810    M0 = M0 + 1
         INDEX(M0) = J
         GO TO 831
C
  820    L = KJ - N0
         Y(L) = XB(J)
         GO TO 831
C
  830    L = KJ - N0
         Y(L) = -XB(J)
  831 CONTINUE
C
      IF (M0 .NE. 0) GO TO 841
         DO 840 I = 1,M
  840       R(I) = B0(I) - Y(I)
         GO TO 850
  841 DO 843 I = 1,M
         DSUM = Y(I)
         DO 842 JJ = 1,M0
            J = INDEX(JJ)
            KJ = IBASIS(J)
            DSUM = DSUM + DBLE(A(I,KJ)*XB(J))
  842    CONTINUE
         R(I) = B0(I) - DSUM
  843 CONTINUE
C
  850 RERR1 = AMIN1(RERRMX,RERR)
      DO 856 I = 1,M
         Y(I) = 0.0
         IF (XB(I)) 851,856,852
  851    SGN = -1.0
         DSUMP = 0.D0
         DSUMN = XB(I)
         GO TO 853
  852    SGN = 1.0
         DSUMP = XB(I)
         DSUMN = 0.D0
  853    DO 855 L = 1,M
            DT = BI(I,L)*R(L)
            IF (DT .GT. 0.D0) GO TO 854
               DSUMN = DSUMN + DT
               GO TO 855
  854       DSUMP = DSUMP + DT
  855    CONTINUE
         W = DSUMP + DSUMN
         IF (W .EQ. 0.0) GO TO 856
         IF (SGN .NE. SIGN(1.0,W)) GO TO 856
         S = DSUMP
         T = DSUMN
         TOL = RERR1*AMAX1(S,-T)
         IF (ABS(W) .GT. TOL) Y(I) = W
  856 CONTINUE
      IF (NSTEP - 2) 860,870,880
C
C         CHECK THE REFINEMENT (NSTEP = 1)
C
  860 DO 861 I = 1,M
         IF (Y(I) .GE. 0.0) GO TO 861
         IF (Y(I) .LT. -RERRMX) GO TO 240
         Y(I) = 0.0
  861    XB(I) = Y(I)
      GO TO 630
C
C         CHECK THE REFINEMENT (NSTEP = 2)
C
  870 DO 871 I = 1,M
         IF (IBASIS(I) .LE. N) GO TO 871
         IF (Y(I) .GT. RERRMX) GO TO 240
         Y(I) = 0.0
  871    XB(I) = Y(I)
      GO TO 680
C
C              COMPUTE Z  (NSTEP = 3)
C
  880 DSUM = 0.D0
      DO 881 I = 1,M
         KI = IBASIS(I)
         IF (KI .GT. N0) GO TO 881
         DSUM = DSUM + DBLE(C(KI)*Y(I))
  881    XB(I) = Y(I)
      Z = DSUM
      GO TO 220
      END
      SUBROUTINE SSPLX (TA,ITA,JTA,B0,C,M,N0,IND,IBASIS,X,Z,ITER,MXITER,
     *                       NUMLE,NUMGE,BI,WK,IWK)
C-----------------------------------------------------------------------
C     SIMPLEX PROCEDURE FOR SOLVING LINEAR PROGRAMMING PROBLEMS
C-----------------------------------------------------------------------
C     WRITTEN BY ALFRED H. MORRIS JR.
C        NAVAL SURFACE WEAPONS CENTER
C        DAHLGREN, VIRGINIA
C------------------------
C     INITIAL VERSION  DEC  1977
C     LAST UPDATE      OCT  1990
C------------------------
      DIMENSION TA(*),ITA(*),JTA(*)
      DIMENSION B0(M),C(N0)
      DIMENSION IBASIS(M),BI(M,M)
      DIMENSION X(*),WK(*),IWK(*)
C------------------------
C     DIMENSION X(N0+NUMLE+NUMGE)
C     DIMENSION WK(2*M),IWK(2*M+N0)
C------------------------
C
C     ********** EPS0 IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS0
C                THE VALUE U WHERE U IS THE SMALLEST POSITIVE FLOATING
C                POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0.
C
                          EPS0 = SPMPAR(1)
C
C------------------------
      RERRMN = 10.0*EPS0
      RERRMX = 1.E-4
      IF (EPS0 .LT. 1.E-13) RERRMX = 1.E-5
C
      IP = M + N0 + 1
      CALL SSPLX1(TA,ITA,JTA,B0,C,M,N0,IND,IBASIS,X,Z,ITER,MXITER,
     1            EPS0,RERRMN,RERRMX,RERR,NUMLE,NUMGE,BI,
     2            WK(1),WK(M+1),IWK(1),IWK(IP))
      RETURN
      END
      SUBROUTINE SSPLX1 (TA,ITA,JTA,B0,C,M,N0,IND,IBASIS,R,Z,
     1       ITER,MXITER,EPS0,RERRMN,RERRMX,RERR,NUMLE,NUMGE,
     2       BI,XB,Y,BASIS,INDEX)
C----------------------
C     NSTEP = 1   ELIMINATE THE NEGATIVE VARIABLES
C     NSTEP = 2   PHASE 1 OF THE SIMPLEX ALGORITHM
C     NSTEP = 3   PHASE 2 OF THE SIMPLEX ALGORITHM
C----------------------
C     MXITER = THE MAXIMUM NUMBER OF ITERATIONS PERMITTED
C     ITER = THE NUMBER OF THE CURRENT ITERATION
C     ICOUNT = THE NUMBER OF ITERATIONS SINCE THE LAST INVERSION
C----------------------
C     NUMLE = THE NUMBER OF .LE. CONSTRAINTS
C     NUMGE = THE NUMBER OF .GE. CONSTRAINTS
C----------------------
C     THE ROUTINE ASSUMES THAT THE .LE. CONSTRAINTS PRECEDE THE .GE.
C     CONSTRAINTS AND THAT THE .EQ. CONSTRAINTS COME LAST. THERE ARE
C     M CONSTRAINTS. X(N0+I) IS THE SLACK, SURPLUS, OR ARTIFICIAL
C     VARIABLE FOR THE I-TH CONSTRAINT (I=1,...,M).
C----------------------
C     N0 = THE NUMBER OF ORGINAL VARIABLES
C     NS = THE NUMBER OF ORGINAL AND SLACK VARIABLES
C     N  = THE NUMBER OF ORGINAL, SLACK, AND SURPLUS VARIABLES
C     NUM = THE TOTAL NUMBER OF VARIABLES
C----------------------
C     RERRMN = THE SMALLEST RELATIVE ERROR TOLERANCE USED
C     RERRMX = THE LARGEST RELATIVE ERROR TOLERANCE USED
C     RERR   = THE ESTIMATED CURRENT RELATIVE ERROR
C----------------------
C     LET A DENOTE AN MXN0 MATRIX. THE TRANSPOSE OF A IS STORED IN
C     SPARSE FORM IN TA,ITA,JTA. ASSUME THAT
C         B0 = (B0(1),...,B0(M))
C         C  = (C(1),...,C(N0))
C         Z  = C(1)*X(1)+...+C(N0)*X(N0)
C     THE PROBLEM IS TO MAXIMIZE Z SUBJECT TO
C         AX(LE,EQ,GE)B0
C         X.GE.0
C----------------------
C     ON INPUT IND CAN HAVE THE VALUES
C         IND = 0   NO BEGINNING BASIS IS PROVIDED BY THE USER
C         IND = 1   THE ARRAY IBASIS HAS BEEN SET BY THE USER
C     ON OUTPUT IND IS ASSIGNED ONE OF THE VALUES
C         IND = 0   Z WAS SUCCESSFULLY MAXIMIZED
C         IND = 1   THE PROBLEM HAS NO FEASIBLE SOLUTION
C         IND = 2   MXITER ITERATIONS WERE PERFORMED
C         IND = 3   SUFFICIENT ACCURACY CANNOT BE MAINTAINED
C         IND = 4   THE PROBLEM HAS AN UNBOUNDED SOLUTION
C         IND = 5   THERE IS AN INPUT ERROR
C         IND = 6   Z WAS POSSIBLY MAXIMIZED
C----------------------
C     BASIS IS AN INTEGER ARRAY OF DIMENSION N0+M. FOR J.LE.N
C         BASIS(J) = 1  IF X(J) IS A BASIC VARIABLE
C         BASIS(J) = 0  IF X(J) IS NOT A BASIC VARIABLE
C     IF THE BASIC VARIABLES ARE X(I1),...,X(IM) THEN
C         IBASIS = (I1,...,IM)
C     ALSO XB(1),...,XB(M) ARE THE CORRESPONDING VALUES OF THE
C     BASIC VARIABLES.
C----------------------
C     BI IS AN MXM ARRAY CONTAINING THE INVERSE OF THE BASIS MATRIX.
C----------------------
C     R IS AN ARRAY OF DIMENSION N. ON OUTPUT R CONTAINS THE CURRENT
C     VALUE OF X. DURING COMPUTATION R NORMALLY CONTAINS THE REDUCED
C     COSTS USED FOR THE SELECTION OF THE VARIABLE TO BE MADE BASIC.
C----------------------
      REAL TA(*), B0(M), C(N0)
      REAL BI(M,M), XB(M), Y(M), R(*)
      INTEGER ITA(*), JTA(*)
      INTEGER IBASIS(M), BASIS(*)
      INTEGER BFLAG, INDEX(M)
      DOUBLE PRECISION DSUM, DSUMP, DSUMN, DT
C----------------------
C
C     ****** XMAX IS A MACHINE DEPENDENT CONSTANT. XMAX IS THE
C            LARGEST POSITIVE FLOATING POINT NUMBER.
C
                 XMAX = SPMPAR(3)
C
C----------------------
      ITER = 0
      ICOUNT = 0
      MCHECK = MIN0(5,1 + M/15)
      Z = 0.0
C
C                CHECK FOR INPUT ERRORS
C
      MS = NUMLE + NUMGE
      IF (M .LT. 2 .OR. N0 .LT. 2 .OR. MS .GT. M) GO TO 12
      DO 10 I = 1,M
         IF (B0(I) .LT. 0.0) GO TO 12
   10    XB(I) = 0.0
      RTOL = XMAX
      DO 11 I = 1,N0
         IF (C(I) .NE. 0.0) RTOL = AMIN1(ABS(C(I)),RTOL)
   11 CONTINUE
      RTOL = RERRMX*RTOL
      GO TO 20
C
   12 IND = 5
      RETURN
C
C     FORMATION OF THE IBASIS AND BASIS ARRAYS. (IF IND = 1
C     THEN THE IBASIS ARRAY IS DEFINED BY THE USER.)
C
   20 NS = N0 + NUMLE
      N = NS + NUMGE
      IF (IND .EQ. 0) GO TO 30
      NUM = N
      DO 21 I = 1,M
         IF (IBASIS(I) .GT. N) NUM = NUM + 1
   21 CONTINUE
      GO TO 32
   22 IF (IND .EQ. 0) GO TO 590
      IND = 0
C
   30 NUM = N0 + M
      DO 31 I = 1,M
   31    IBASIS(I) = N0 + I
   32 BFLAG = 0
      DO 33 I = 1,N
   33    BASIS(I) = 0
      DO 34 I = 1,M
         KI = IBASIS(I)
   34    BASIS(KI) = 1
      IF (IND .EQ. 1) GO TO 100
C
C          CALCULATION OF XB AND BI WHEN IND = 0
C
      RERR = RERRMN
      DO 41 J = 1,M
         XB(J) = B0(J)
         DO 40 I = 1,M
   40       BI(I,J) = 0.0
         BI(J,J) = 1.0
   41 CONTINUE
      IF (NUMGE .EQ. 0) GO TO 630
      JMIN = NUMLE + 1
      DO 42 J = JMIN,MS
         XB(J) = -XB(J)
         BI(J,J) = -1.0
   42 CONTINUE
      GO TO 601
C
C                  REORDER THE BASIS
C
  100 IBEG = 1
      IEND = M
      DO 102 I = 1,M
         IF (IBASIS(I) .LE. N0) GO TO 101
            INDEX(IBEG) = IBASIS(I)
            IBEG = IBEG + 1
            GO TO 102
  101    INDEX(IEND) = IBASIS(I)
         IEND = IEND - 1
  102 CONTINUE
      IF (IEND .EQ. M) GO TO 22
      DO 103 I = 1,M
  103    IBASIS(I) = INDEX(I)
C
C            REINVERSION OF THE BASIS MATRIX
C
      DO 132 J = 1,M
         KJ = IBASIS(J)
         IF (KJ .LE. N0) GO TO 110
         IF (KJ .LE. NS) GO TO 120
         IF (KJ .LE. N) GO TO 130
         GO TO 120
C
  110    DO 111 I = 1,M
  111       BI(I,J) = 0.0
         LMIN = ITA(KJ)
         LMAX = ITA(KJ + 1) - 1
         IF (LMIN .GT. LMAX) GO TO 132
         DO 112 LL = LMIN,LMAX
            L = JTA(LL)
  112       BI(L,J) = TA(LL)
         GO TO 132
C
  120    L = KJ - N0
         DO 121 I = 1,M
  121       BI(I,J) = 0.0
         BI(L,J) = 1.0
         GO TO 132
C
  130    L = KJ - N0
         DO 131 I = 1,M
  131       BI(I,J) = 0.0
         BI(L,J) = -1.0
  132 CONTINUE
C
      ICOUNT = 0
      CALL CROUT1 (BI, M, M, IEND, INDEX, Y, JCOL, IERR)
      IF (IERR .NE. 0) GO TO 580
C
C         CHECK THE ACCURACY OF BI AND RESET RERR
C
      BNORM = 0.0
      DO 142 J = 1,M
         KJ = IBASIS(J)
         IF (KJ .LE. N0) GO TO 140
            SUM = 1.0
            GO TO 142
  140    SUM = 0.0
         LMIN = ITA(KJ)
         LMAX = ITA(KJ + 1) - 1
         DO 141 LL = LMIN,LMAX
  141       SUM = SUM + ABS(TA(LL))
  142    BNORM = AMAX1(BNORM,SUM)
C
      BINORM = 0.0
      DO 151 J = 1,M
         SUM = 0.0
         DO 150 I = 1,M
  150       SUM = SUM + ABS(BI(I,J))
         BINORM = AMAX1(BINORM,SUM)
  151 CONTINUE
      RERR = AMAX1(RERRMN,EPS0*BNORM*BINORM)
      IF (RERR .GT. 1.E-2) GO TO 580
      BFLAG = 0
C
C                 RECALCULATION OF XB
C
  180 DO 183 I = 1,M
         DSUMP = 0.D0
         DSUMN = 0.D0
         DO 182 L = 1,M
            DT = BI(I,L)*B0(L)
            IF (DT .GT. 0.D0) GO TO 181
               DSUMN = DSUMN + DT
               GO TO 182
  181       DSUMP = DSUMP + DT
  182    CONTINUE
         XB(I) = DSUMP + DSUMN
         S = DSUMP
         T = DSUMN
         TOL = RERRMX*AMAX1(S,-T)
         IF (ABS(XB(I)) .LT. TOL) XB(I) = 0.0
  183 CONTINUE
      GO TO 601
C
C     FIND THE NEXT VECTOR A(--,JP) TO BE INSERTED INTO
C                       THE BASIS
C
  200 JP = 0
      RMIN = 0.0
      IF (NSTEP .EQ. 3) RMIN = -RTOL
      DO 201 J = 1,N0
         IF (BASIS(J) .NE. 0) GO TO 201
         IF (R(J) .GE. RMIN) GO TO 201
         JP = J
         RMIN = R(J)
  201 CONTINUE
      IF (N0 .EQ. N) GO TO 203
      JMIN = N0 + 1
      RMIN = RMIN*1.1
      DO 202 J = JMIN,N
         IF (BASIS(J) .NE. 0) GO TO 202
         IF (R(J) .GE. RMIN) GO TO 202
         JP = J
         RMIN = R(J)
  202 CONTINUE
  203 IF (JP .NE. 0) GO TO 300
      IF (NSTEP - 2) 800,230,250
C
C     INSERT THE VALUES OF THE ORGINAL, SLACK, AND SURPLUS
C             VARIABLES INTO R. THEN TERMINATE.
C
  220 DO 221 J = 1,N
  221    R(J) = 0.0
      DO 222 I = 1,M
         KI = IBASIS(I)
         IF (KI .LE. N) R(KI) = XB(I)
  222 CONTINUE
      RETURN
C
C             COMPLETION OF THE NSTEP = 2 CASE
C
  230 DO 231 I = 1,M
         IF (IBASIS(I) .LE. N) GO TO 231
         IF (XB(I) .GT. 0.0) GO TO 800
  231 CONTINUE
      GO TO 680
C
  240 IF (ICOUNT .GE. 5) GO TO 100
      IND = 1
      GO TO 220
C
C             COMPLETION OF THE NSTEP = 3 CASE
C
  250 IF (RERR .GT. 1.E-2) GO TO 251
         IND = 0
         GO TO 800
  251 IF (ICOUNT .GE. 5) GO TO 100
      IND = 6
      GO TO 800
C
C     IF MXITER ITERATIONS HAVE NOT BEEN PERFORMED THEN
C     BEGIN THE NEXT ITERATION. COMPUTE THE JP-TH COLUMN
C               OF BI*A AND STORE IT IN Y.
C
  300 IF (ITER .LT. MXITER) GO TO 301
         IND = 2
         GO TO 220
  301 ITER = ITER + 1
      ICOUNT = ICOUNT + 1
      IF (JP .GT. NS) GO TO 330
      IF (JP .GT. N0) GO TO 320
C
      LMIN = ITA(JP)
      LMAX = ITA(JP + 1) - 1
      IF (LMIN .LE. LMAX) GO TO 305
         IND = 4
         GO TO 220
  305 AMAX = 0.0
      DO 306 LL = LMIN,LMAX
         AMAX = AMAX1(ABS(TA(LL)),AMAX)
  306 CONTINUE
C
  310 RERR1 = RERRMX*AMAX
      DO 313 I = 1,M
         DSUM = 0.D0
         DO 311 LL = LMIN,LMAX
            L = JTA(LL)
            DSUM = DSUM + DBLE(BI(I,L)*TA(LL))
  311    CONTINUE
         Y(I) = DSUM
         IF (ABS(Y(I)) .GE. 5.E-3) GO TO 313
         BMAX = 0.0
         DO 312 L = 1,M
            BMAX = AMAX1(ABS(BI(I,L)),BMAX)
  312    CONTINUE
         TOL = RERR1*BMAX
         IF (ABS(Y(I)) .LT. TOL) Y(I) = 0.0
  313 CONTINUE
      GO TO 350
C
  320 L = JP - N0
      DO 321 I = 1,M
         Y(I) = BI(I,L)
  321 CONTINUE
      GO TO 350
C
  330 L = JP - N0
      DO 331 I = 1,M
         Y(I) = -BI(I,L)
  331 CONTINUE
C
  350 DO 351 I = 1,M
         IF (Y(I) .NE. 0.0) GO TO 360
  351 CONTINUE
      R(JP) = 0.0
      ITER = ITER - 1
      ICOUNT = ICOUNT - 1
      GO TO 200
C
  360 IF (NSTEP - 2) 400,430,440
C
C     FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC
C               FOR THE NSTEP = 1 CASE
C
  400 NPOS = 0
      IP = 0
      EPS = 0.0
      EPSI = XMAX
      DO 403 I = 1,M
         IF (XB(I) .LT. 0.0 .OR. Y(I) .LE. 0.0) GO TO 403
         RATIO = XB(I)/Y(I)
         IF (RATIO - EPSI) 401,402,403
  401    EPSI = RATIO
         NPOS = 1
         INDEX(1) = I
         GO TO 403
  402    NPOS = NPOS + 1
         INDEX(NPOS) = I
  403 CONTINUE
      IF (NPOS .EQ. 0) GO TO 420
      IF (EPSI .EQ. 0.0) GO TO 460
C
      DO 410 I = 1,M
         IF (XB(I) .GE. 0.0 .OR. Y(I) .GE. 0.0) GO TO 410
         RATIO = XB(I)/Y(I)
         IF (RATIO .GT. EPSI) GO TO 410
         IF (RATIO .LT. EPS) GO TO 410
         EPS = RATIO
         IP = I
  410 CONTINUE
      IF (IP .NE. 0) GO TO 500
      GO TO 460
C
  420 DO 421 I = 1,M
         IF (XB(I) .GE. 0.0 .OR. Y(I) .GE. 0.0) GO TO 421
         RATIO = XB(I)/Y(I)
         IF (RATIO .LT. EPS) GO TO 421
         EPS = RATIO
         IP = I
  421 CONTINUE
      GO TO 500
C
C     FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC
C               FOR THE NSTEP = 2 CASE
C
  430 NPOS = 0
      EPSI = XMAX
      DO 433 I = 1,M
         IF (Y(I) .LE. 0.0) GO TO 433
         RATIO = XB(I)/Y(I)
         IF (RATIO - EPSI) 431,432,433
  431    EPSI = RATIO
         NPOS = 1
         INDEX(1) = I
         GO TO 433
  432    NPOS = NPOS + 1
         INDEX(NPOS) = I
  433 CONTINUE
      GO TO 450
C
C     FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC
C               FOR THE NSTEP = 3 CASE
C
  440 NPOS = 0
      EPSI = XMAX
      DO 445 I = 1,M
         IF (Y(I)) 441,445,442
  441    IF (IBASIS(I) .LE. N) GO TO 445
         IP = I
         GO TO 500
  442    RATIO = XB(I)/Y(I)
         IF (RATIO - EPSI) 443,444,445
  443       EPSI = RATIO
            NPOS = 1
            INDEX(1) = I
            GO TO 445
  444       NPOS = NPOS + 1
            INDEX(NPOS) = I
  445 CONTINUE
C
  450 IF (NPOS .NE. 0) GO TO 460
      IF (ICOUNT .GE. 5) GO TO 100
      IND = 4
      GO TO 220
C
C              TIE BREAKING PROCEDURE
C
  460 IP = INDEX(1)
      IF (NPOS .EQ. 1) GO TO 500
      IP = 0
      BMIN = XMAX
      CMIN = XMAX
      DO 464 II = 1,NPOS
         I = INDEX(II)
         L = IBASIS(I)
         IF (L .GT. N0) GO TO 461
            IF (C(L) .LE. 0.0) CMIN = AMIN1(0.0,CMIN)
            IF (C(L) .GT. CMIN) GO TO 464
            IMIN = I
            CMIN = C(L)
            GO TO 464
  461    IF (L .LE. N) GO TO 462
            IP = I
            GO TO 500
  462    LROW = L - N0
         S = B0(LROW)
         IF (LROW .GT. NUMLE) GO TO 463
            IF (S .GT. BMIN) GO TO 464
            IP = I
            BMIN = S
            GO TO 464
  463    S = -S
         BMIN = AMIN1(0.0,BMIN)
         IF (S .GT. BMIN) GO TO 464
         IP = I
         BMIN = S
  464 CONTINUE
      IF (CMIN .LE. 0.0 .OR. IP .EQ. 0) IP = IMIN
C
C               TRANSFORMATION OF XB
C
  500 IF (XB(IP) .EQ. 0.0) GO TO 510
      CONST = XB(IP)/Y(IP)
      DO 501 I = 1,M
         S = XB(I)
         XB(I) = XB(I) - CONST*Y(I)
         IF (XB(I) .GE. 0.0) GO TO 501
         IF (S .GE. 0.0 .OR. XB(I) .GE. RERRMX*S) XB(I) = 0.0
  501 CONTINUE
      XB(IP) = CONST
C
C               TRANSFORMATION OF BI
C
  510 DO 512 J = 1,M
         IF (BI(IP,J) .EQ. 0.0) GO TO 512
         CONST = BI(IP,J)/Y(IP)
         DO 511 I = 1,M
  511       BI(I,J) = BI(I,J) - CONST*Y(I)
         BI(IP,J) = CONST
  512 CONTINUE
C
C             UPDATING IBASIS AND BASIS
C
      IOUT = IBASIS(IP)
      IBASIS(IP) = JP
      BASIS(IOUT) = 0
      BASIS(JP) = 1
      IF (IOUT .GT. N) NUM = NUM - 1
C
C        CHECK THE ACCURACY OF BI AND RESET RERR
C
      IF (RERR .GT. 1.E-2) GO TO 530
      K = 0
      DO 521 J = 1,M
         KJ = IBASIS(J)
         IF (KJ .GT. N0) GO TO 521
         SUM = 0.0
         LMIN = ITA(KJ)
         LMAX = ITA(KJ + 1) - 1
         DO 520 LL = LMIN,LMAX
            L = JTA(LL)
            SUM = SUM + BI(J,L)*TA(LL)
  520    CONTINUE
         RERR = AMAX1(RERR,ABS(1.0-SUM))
         K = K + 1
         IF (K .GE. MCHECK) GO TO 522
  521 CONTINUE
  522 IF (RERR .LE. 1.E-2) GO TO 600
C
C        THE ACCURACY CRITERIA ARE NOT SATISFIED
C
  530 IF (ICOUNT .LT. 5) GO TO 600
      BFLAG = 1
      GO TO 100
C
  580 IF (ITER .EQ. 0) GO TO 12
      IF (BFLAG .EQ. 0) GO TO 590
      BFLAG = 0
      DO 581 IP = 1,M
         IF (JP .EQ. IBASIS(IP)) GO TO 582
  581 CONTINUE
  582 IBASIS(IP) = IOUT
      BASIS(JP) = 0
      BASIS(IOUT) = 1
      IF (IOUT .GT. N) NUM = NUM + 1
      GO TO 100
C
  590 IND = 3
      GO TO 220
C
C       SET UP THE R ARRAY FOR THE NSTEP = 1 CASE
C
  600 IF (NSTEP - 2) 601,630,700
  601 DO 602 J = 1,M
         IF (XB(J) .LT. 0.0) GO TO 610
  602 CONTINUE
      GO TO 630
C
  610 NSTEP = 1
      M0 = 0
      DO 611 L = 1,M
         IF (XB(L) .GE. 0.0) GO TO 611
         M0 = M0 + 1
         INDEX(M0) = L
  611 CONTINUE
C
      DO 623 J = 1,M
         DSUMP = 0.D0
         DSUMN = 0.D0
         DO 622 LL = 1,M0
            L = INDEX(LL)
            IF (BI(L,J)) 620,622,621
  620       DSUMN = DSUMN + DBLE(BI(L,J))
            GO TO 622
  621       DSUMP = DSUMP + DBLE(BI(L,J))
  622    CONTINUE
         Y(J) = DSUMP + DSUMN
         S = DSUMP
         T = DSUMN
         TOL = RERRMX*AMAX1(S,-T)
         IF (ABS(Y(J)) .LT. TOL) Y(J) = 0.0
  623 CONTINUE
      GO TO 650
C
C       SET UP THE R ARRAY FOR THE NSTEP = 2 CASE
C
  630 IF (N .EQ. NUM) GO TO 680
      NSTEP = 2
      M0 = 0
      DO 631 L = 1,M
         IF (IBASIS(L) .LE. N) GO TO 631
         M0 = M0 + 1
         INDEX(M0) = L
  631 CONTINUE
C
      DO 643 J = 1,M
         DSUMP = 0.D0
         DSUMN = 0.D0
         DO 642 LL = 1,M0
            L = INDEX(LL)
            IF (BI(L,J)) 640,642,641
  640       DSUMN = DSUMN + DBLE(BI(L,J))
            GO TO 642
  641       DSUMP = DSUMP + DBLE(BI(L,J))
  642    CONTINUE
         Y(J) = -(DSUMP + DSUMN)
         S = DSUMP
         T = DSUMN
         TOL = RERRMX*AMAX1(S,-T)
         IF (ABS(Y(J)) .LT. TOL) Y(J) = 0.0
  643 CONTINUE
C
  650 DO 652 J = 1,N0
         SUM = 0.0
         IF (BASIS(J) .NE. 0) GO TO 652
         LMIN = ITA(J)
         LMAX = ITA(J + 1) - 1
         IF (LMIN .GT. LMAX) GO TO 652
         DO 651 LL = LMIN,LMAX
            L = JTA(LL)
            SUM = SUM + Y(L)*TA(LL)
  651    CONTINUE
  652    R(J)=SUM
C
  660 IF (N0 .EQ. NS) GO TO 670
      JMIN = N0 + 1
      DO 661 J = JMIN,NS
         R(J) = 0.0
         IF (BASIS(J) .NE. 0) GO TO 661
         JJ = J - N0
         R(J) = Y(JJ)
  661 CONTINUE
C
  670 IF (NS .EQ. N) GO TO 200
      JMIN = NS + 1
      DO 671 J = JMIN,N
         R(J) = 0.0
         IF (BASIS(J) .NE. 0) GO TO 671
         JJ = J - N0
         R(J) = -Y(JJ)
  671 CONTINUE
      GO TO 200
C
C      SET UP A NEW R ARRAY FOR THE NSTEP = 3 CASE
C
  680 NSTEP = 3
      DO 682 J = 1,M
         DSUM = 0.D0
         DO 681 L = 1,M
            IL = IBASIS(L)
            IF (IL .LE. N0) DSUM = DSUM + DBLE(C(IL)*BI(L,J))
  681    CONTINUE
  682    Y(J) = DSUM
C
      DO 691 J = 1,N0
         R(J) = 0.0
         IF (BASIS(J) .NE. 0) GO TO 691
         DSUM = -C(J)
         LMIN = ITA(J)
         LMAX = ITA(J + 1) - 1
         R(J) = -C(J)
         IF (LMIN .GT. LMAX) GO TO 691
         DO 690 LL = LMIN,LMAX
            L = JTA(LL)
            DSUM = DSUM + DBLE(Y(L)*TA(LL))
  690    CONTINUE
         R(J) = DSUM
         IF (R(J) .GE. 0.0) GO TO 691
         TOL = RERRMX*ABS(C(J))
         IF (ABS(R(J)) .LT. TOL) R(J) = 0.0
  691 CONTINUE
      GO TO 660
C
C       UPDATE THE R ARRAY FOR THE NSTEP = 3 CASE
C
  700 CONST = R(JP)
      DO 703 J = 1,N0
         IF (BASIS(J) .EQ. 0) GO TO 701
            R(J) = 0.0
            GO TO 703
  701    SUM = 0.0
         LMIN = ITA(J)
         LMAX = ITA(J + 1) - 1
         IF (LMIN .GT. LMAX) GO TO 703
         DO 702 LL = LMIN,LMAX
            L = JTA(LL)
            SUM = SUM + BI(IP,L)*TA(LL)
  702    CONTINUE
         R(J) = R(J) - CONST*SUM
         IF (R(J) .GE. 0.0) GO TO 703
         TOL = RERRMX*ABS(C(J))
         IF (ABS(R(J)) .LT. TOL) R(J) = 0.0
  703 CONTINUE
C
  710 IF (N0 .EQ. NS) GO TO 720
      JMIN = N0 + 1
      DO 712 J = JMIN,NS
         IF (BASIS(J) .EQ. 0) GO TO 711
            R(J) = 0.0
            GO TO 712
  711    JJ = J - N0
         R(J) = R(J) - CONST*BI(IP,JJ)
  712 CONTINUE
C
  720 IF (NS .EQ. N) GO TO 200
      JMIN = NS + 1
      DO 722 J = JMIN,N
         IF (BASIS(J) .EQ. 0) GO TO 721
            R(J) = 0.0
            GO TO 722
  721    JJ = J - N0
         R(J) = R(J) + CONST*BI(IP,JJ)
  722 CONTINUE
      GO TO 200
C-----------------------------------------------------------------------
C               REFINE XB AND STORE THE RESULT IN Y
C-----------------------------------------------------------------------
  800 DO 801 I = 1,M
         R(I) = 0.0
         Y(I) = 0.0
  801 CONTINUE
C
      DO 831 J = 1,M
         KJ = IBASIS(J)
         IF (KJ .LE. N0) GO TO 810
         IF (KJ .LE. NS) GO TO 820
         IF (KJ .LE. N) GO TO 830
         GO TO 820
C
  810    LMIN = ITA(KJ)
         LMAX = ITA(KJ + 1) - 1
         DO 811 LL = LMIN,LMAX
            L = JTA(LL)
            DT = DBLE(R(L)) + DBLE(Y(L))
            DT = DT + DBLE(TA(LL)*XB(J))
            R(L) = DT
            Y(L) = DT - DBLE(R(L))
  811    CONTINUE
         GO TO 831
C
  820    L = KJ - N0
         DT = DBLE(R(L)) + DBLE(Y(L))
         DT = DT + DBLE(XB(J))
         R(L) = DT
         Y(L) = DT - DBLE(R(L))
         GO TO 831
C
  830    L = KJ - N0
         DT = DBLE(R(L)) + DBLE(Y(L))
         DT = DT - DBLE(XB(J))
         R(L) = DT
         Y(L) = DT - DBLE(R(L))
  831 CONTINUE
C
      DO 840 I = 1,M
         DT = DBLE(R(I)) + DBLE(Y(I))
         R(I) = DBLE(B0(I)) - DT
  840 CONTINUE
C
  850 RERR1 = AMIN1(RERRMX,RERR)
      DO 856 I = 1,M
         Y(I) = 0.0
         IF (XB(I)) 851,856,852
  851    SGN = -1.0
         DSUMP = 0.D0
         DSUMN = XB(I)
         GO TO 853
  852    SGN = 1.0
         DSUMP = XB(I)
         DSUMN = 0.D0
  853    DO 855 L = 1,M
            DT = BI(I,L)*R(L)
            IF (DT .GT. 0.D0) GO TO 854
               DSUMN = DSUMN + DT
               GO TO 855
  854       DSUMP = DSUMP + DT
  855    CONTINUE
         W = DSUMP + DSUMN
         IF (W .EQ. 0.0) GO TO 856
         IF (SGN .NE. SIGN(1.0,W)) GO TO 856
         S = DSUMP
         T = DSUMN
         TOL = RERR1*AMAX1(S,-T)
         IF (ABS(W) .GT. TOL) Y(I) = W
  856 CONTINUE
      IF (NSTEP - 2) 860,870,880
C
C         CHECK THE REFINEMENT (NSTEP = 1)
C
  860 DO 861 I = 1,M
         IF (Y(I) .GE. 0.0) GO TO 861
         IF (Y(I) .LT. -RERRMX) GO TO 240
         Y(I) = 0.0
  861    XB(I) = Y(I)
      GO TO 630
C
C         CHECK THE REFINEMENT (NSTEP = 2)
C
  870 DO 871 I = 1,M
         IF (IBASIS(I) .LE. N) GO TO 871
         IF (Y(I) .GT. RERRMX) GO TO 240
         Y(I) = 0.0
  871    XB(I) = Y(I)
      GO TO 680
C
C              COMPUTE Z  (NSTEP = 3)
C
  880 DSUM = 0.D0
      DO 881 I = 1,M
         KI = IBASIS(I)
         IF (KI .GT. N0) GO TO 881
         DSUM = DSUM + DBLE(C(KI)*Y(I))
  881    XB(I) = Y(I)
      Z = DSUM
      GO TO 220
      END
      SUBROUTINE CROUT1(A,KA,N,IEND,INDEX,TEMP,JP,IERR)
C     ******************************************************************
C     CROUT PROCEDURE FOR INVERTING MATRICES
C     ******************************************************************
C     A IS A MATRIX OF ORDER N WHERE N IS GREATER THAN OR EQUAL TO 1.
C     THE INVERSE OF A IS COMPUTED AND STORED IN A.
C
C     KA = LENGTH OF THE COLUMNS OF THE ARRAY A
C     JP = THE NUMBER OF THE COLUMN THAT CONTAINS THE SMALLEST PIVOT
C
C     IEND MAY BE 0,1,...,N-1.  IT IS ASSUMED THAT EACH OF THE FIRST
C     IEND COLUMNS OF THE MATRIX A CONTAINS ONLY ONE NONZERO ELEMENT
C     AND THAT THE NONZERO ELEMENT IS 1 OR -1.
C
C     INDEX IS AN ARRAY OF DIMENSION N-1 OR LARGER THAT IS USED BY THE
C     ROUTINE FOR KEEPING TRACK OF THE ROW INTERCHANGES THAT ARE MADE.
C
C     TEMP IS A TEMPORARY STORAGE ARRAY.
C
C     IERR REPORTS THE STATUS OF THE RESULTS. IF A IS NONSINGULAR THEN
C     THE INVERSE OF A IS COMPUTED AND IERR=0. OTHERWISE IF A IS FOUND
C     TO BE SINGULAR THEN IERR=1 AND THE ROUTINE TERMINATES.
C     --------------------
      DIMENSION A(*),INDEX(*),TEMP(N)
      DOUBLE PRECISION DSUM
      MAX = KA*N
      MCOL = IEND*KA
      IF (IEND .EQ. 0) GO TO 100
C
C           PROCESS THE FIRST IEND COLUMNS OF A
C
      KCOL = 0
      DO 32 K = 1,IEND
      KK = KCOL + K
      NK = KCOL + N
      DO 10 LK = KK,NK
      IF (A(LK)) 20,10,30
   10 CONTINUE
      JP = K
      GO TO 300
C
   20 L = LK - KCOL
      LJ0 = MCOL + L
      DO 21 LJ = LJ0,MAX,KA
   21 A(LJ) = -A(LJ)
C
   30 L = LK - KCOL
      INDEX(K) = L
      IF (K .EQ. L) GO TO 32
      LJ = LK
      DO 31 KJ = KK,MAX,KA
      C = A(KJ)
      A(KJ) = A(LJ)
      A(LJ) = C
   31 LJ = LJ + KA
   32 KCOL = KCOL + KA
C
C           PROCESS THE REMAINING COLUMNS OF A
C
  100 NM1 = N - 1
      JP = 1
      IERR = 0
      PMIN = 0.0
      IBEG = IEND + 1
      IF (IBEG .EQ. N) GO TO 190
C
      K = IBEG
      KM1 = IEND
      KP1 = K + 1
      KCOL = MCOL
      KK = KCOL + K
      DO 172 KCOUNT = IBEG,NM1
C
C     SEARCH FOR THE K-TH PIVOT ELEMENT (K=IBEG,...,N-1)
C
      L = K
      S = ABS(A(KK))
      DO 110 I = KP1,N
      IK = KCOL + I
      C = ABS(A(IK))
      IF (S .GE. C) GO TO 110
      L = I
      S = C
  110 CONTINUE
C
      IF (K.GT.IBEG .AND. S.GE.PMIN) GO TO 120
      JP = K
      PMIN = S
      IF (S .EQ. 0.0) GO TO 300
C
C              INTERCHANGING ROWS K AND L
C
  120 INDEX(K) = L
      IF (K .EQ. L) GO TO 130
      KJ0 = MCOL + K
      LJ  = MCOL + L
      DO 121 KJ = KJ0,MAX,KA
      C = A(KJ)
      A(KJ) = A(LJ)
      A(LJ) = C
  121 LJ = LJ + KA
C
C       COMPUTE THE K-TH ROW OF U (K=IBEG,...,N-1)
C
  130 C = A(KK)
      IF (K .GT. IBEG) GO TO 140
      KJ0 = KK + KA
      DO 131 KJ = KJ0,MAX,KA
  131 A(KJ) = A(KJ)/C
      GO TO 160
C
  140 KL = MCOL + K
      DO 141 L = IBEG,KM1
      TEMP(L) = A(KL)
  141 KL = KL + KA
C
      KJ0 = KK + KA
      DO 151 KJ = KJ0,MAX,KA
      JCOL = KJ - K
      DSUM = -A(KJ)
        DO 150 L = IBEG,KM1
        LJ = JCOL + L
  150   DSUM = DSUM + DBLE(TEMP(L))*DBLE(A(LJ))
  151 A(KJ) = SNGL(-DSUM)/C
C
C      COMPUTE THE K-TH COLUMN OF L (K=IBEG+1,...,N)
C
  160 KM1 = K
      K = KP1
      KP1 = K + 1
      KCOL = KCOL + KA
      KK = KCOL + K
      DO 161 L = IBEG,KM1
      LK = KCOL + L
  161 TEMP(L) = A(LK)
C
      DO 171 I = K,N
      IL = MCOL + I
      DSUM = 0.D0
        DO 170 L = IBEG,KM1
        DSUM = DSUM + DBLE(A(IL))*DBLE(TEMP(L))
  170   IL = IL + KA
  171 A(IL) = DBLE(A(IL)) - DSUM
  172 CONTINUE
C
C           CHECK THE N-TH PIVOT ELEMENT
C
  190 NCOL = MAX - KA
      NN = NCOL + N
      C = ABS(A(NN))
      IF (C .GT. PMIN) GO TO 200
      JP = N
      IF (C .EQ. 0.0) GO TO 300
C
C          REPLACE L WITH THE INVERSE OF L
C
  200 IF (IBEG .EQ. N) GO TO 213
      JJ = MCOL + IBEG
      I = KA + 1
      DO 212 J = IBEG,NM1
      A(JJ) = 1.0/A(JJ)
      TEMP(J) = A(JJ)
      KJ = JJ
        DO 211 KM1 = J,NM1
        K = KM1 + 1
        KJ = KJ + 1
        DSUM = 0.D0
        KL = KJ
          DO 210 L = J,KM1
          DSUM = DSUM + DBLE(A(KL)*TEMP(L))
  210     KL = KL + KA
        A(KJ) = SNGL(-DSUM)/A(KL)
  211   TEMP(K) = A(KJ)
  212 JJ = JJ + I
  213 A(NN) = 1.0/A(NN)
      IF (N .EQ. 1) RETURN
C
C       SOLVE UX = Y WHERE Y IS THE INVERSE OF L
C
      DO 242 NMK = 1,NM1
      K = N - NMK
      LMIN = MAX0(IBEG,K+1)
      KL = (LMIN-1)*KA + K
        DO 230 L = LMIN,N
        TEMP(L) = A(KL)
        A(KL) = 0.0
  230   KL = KL + KA
C
      KJ0 = MCOL + K
        DO 241 KJ = KJ0,MAX,KA
        DSUM = -A(KJ)
        LJ = (KJ - K) + LMIN
          DO 240 L = LMIN,N
          DSUM = DSUM + DBLE(TEMP(L)*A(LJ))
  240     LJ = LJ + 1
  241   A(KJ) = -DSUM
  242 CONTINUE
C
C                 COLUMN INTERCHANGES
C
      JCOL = NCOL - KA
      DO 251 NMJ = 1,NM1
      J = N - NMJ
      K = INDEX(J)
      IF (J .EQ. K) GO TO 251
      IJ = JCOL
      IK = (K-1)*KA
        DO 250 I = 1,N
        IJ = IJ + 1
        IK = IK + 1
        C = A(IJ)
        A(IJ) = A(IK)
  250   A(IK) = C
  251 JCOL = JCOL - KA
      RETURN
C
C                    ERROR RETURN
C
  300 IERR = 1
      RETURN
      END
      SUBROUTINE ASSGN (N,A,C,T,IWK,IERR)
C     -------------------
C     SOLUTION OF THE ASSIGNMENT PROBLEM
C     -------------------
      INTEGER A(N,*), C(N), T, IWK(*)
C
      I1 = N + 1
      I2 = I1 + N
      I3 = I2 + N
      I4 = I3 + N + 1
      I5 = I4 + N
      I6 = I5 + N
      CALL ASSGN1(N,A,C,T,IWK(1),IWK(I1),IWK(I2),IWK(I3),IWK(1),
     *            IWK(I3),IWK(I4),IWK(I5),IWK(I6),IERR)
      RETURN
      END
      SUBROUTINE ASSGN1(N,A,C,T,CH,LC,LR,LZ,NZ,RH,SLC,SLR,
     *                  U,IERR)
      INTEGER A(N,*), C(N), CH(N), LC(N), LR(N), LZ(N),
     *        NZ(N), RH(*), SLC(N), SLR(N), U(*)
      INTEGER H, Q, R, S, T
C
C THIS SUBROUTINE SOLVES THE SQUARE ASSIGNMENT PROBLEM
C THE MEANING OF THE INPUT PARAMETERS IS
C N = NUMBER OF ROWS AND COLUMNS OF THE COST MATRIX
C A(I,J) = ELEMENT IN ROW I AND COLUMN J OF THE COST MATRIX
C ( AT THE END OF COMPUTATION THE ELEMENTS OF A ARE CHANGED)
C THE MEANING OF THE OUTPUT PARAMETERS IS
C C(J) = ROW ASSIGNED TO COLUMN J (J=1,N)
C T = COST OF THE OPTIMAL ASSIGNMENT
C ALL PARAMETERS ARE INTEGER
C THE MEANING OF THE LOCAL VARIABLES IS
C A(I,J) = ELEMENT OF THE COST MATRIX IF A(I,J) IS POSITIVE,
C          COLUMN OF THE UNASSIGNED ZERO FOLLOWING IN ROW I
C          (I=1,N) THE UNASSIGNED ZERO OF COLUMN J (J=1,N)
C          IF A(I,J) IS NOT POSITIVE
C A(I,N+1) = COLUMN OF THE FIRST UNASSIGNED ZERO OF ROW I
C            (I=1,N)
C CH(I) = COLUMN OF THE NEXT UNEXPLORED AND UNASSIGNED ZERO
C         OF ROW I (I=1,N)
C LC(J) = LABEL OF COLUMN J (J=1,N)
C LR(I) = LABEL OF ROW I (I=1,N)
C LZ(I) = COLUMN OF THE LAST UNASSIGNED ZERO OF ROW I(I=1,N)
C NZ(I) = COLUMN OF THE NEXT UNASSIGNED ZERO OF ROW I(I=1,N)
C RH(I) = UNEXPLORED ROW FOLLOWING THE UNEXPLORED ROW I
C         (I=1,N)
C RH(N+1) = FIRST UNEXPLORED ROW
C SLC(K) = K-TH ELEMENT CONTAINED IN THE SET OF THE LABELLED
C          COLUMNS
C SLR(K) = K-TH ELEMENT CONTAINED IN THE SET OF THE LABELLED
C          ROWS
C U(I) = UNASSIGNED ROW FOLLOWING THE UNASSIGNED ROW I
C        (I=1,N)
C U(N+1) = FIRST UNASSIGNED ROW
C IERR = 0 IF THE ROUTINE TERMINATES SUCCESSFULLY. OTHERWISE
C          IERR = 1
C
C THE VECTORS C,CH,LC,LR,LZ,NZ,SLC,SLR MUST BE DIMENSIONED
C AT LEAST AT (N), THE VECTORS RH,U AT  LEAST AT (N+1),
C AND THE MATRIX A AT LEAST AT (N,N+1). TO SAVE STORAGE
C LZ AND RH MAY USE THE SAME STORAGE AREA, AND NZ AND CH
C MAY USE THE SAME STORAGE AREA.
C
C INITIALIZATION
      MAXNUM = IPMPAR(3)
      IERR = 0
      NP1 = N+1
      DO 10 J=1,N
        C(J) = 0
        LZ(J) = 0
        NZ(J) = 0
        U(J) = 0
   10 CONTINUE
      U(NP1) = 0
      T = 0
C REDUCTION OF THE INITIAL COST MATRIX
      DO 40 J=1,N
        S = A(1,J)
        DO 15 L=2,N
          IF ( A(L,J) .LT. S ) S = A(L,J)
   15   CONTINUE
        IF (S) 20,40,30
   20   MM = MAXNUM + S
        IF (T .LT. -MM) GO TO 400
        T = T + S
        DO 25 I = 1,N
          IF (A(I,J) .GT. MM) GO TO 400
          A(I,J) = A(I,J) - S
   25   CONTINUE
        GO TO 40
   30   MM = MAXNUM - S
        IF (T .GT. MM) GO TO 400
        T = T + S
        DO 35 I = 1,N
          A(I,J) = A(I,J) - S
   35   CONTINUE
   40 CONTINUE
      DO 70 I=1,N
        Q = A(I,1)
        DO 50 L=2,N
          IF ( A(I,L) .LT. Q ) Q = A(I,L)
   50   CONTINUE
        MM = MAXNUM - Q
        IF (T .GT. MM) GO TO 400
        T = T + Q
        L = NP1
        DO 60 J=1,N
          A(I,J) = A(I,J)-Q
          IF ( A(I,J) .NE. 0 ) GO TO 60
          A(I,L) = -J
          L = J
   60   CONTINUE
   70 CONTINUE
C CHOICE OF THE INITIAL SOLUTION
      K = NP1
      DO 140 I=1,N
        LJ = NP1
        J = -A(I,NP1)
   80   IF ( C(J) .EQ. 0 ) GO TO 130
        LJ = J
        J = -A(I,J)
        IF ( J .NE. 0 ) GO TO 80
        LJ = NP1
        J = -A(I,NP1)
   90   R = C(J)
        LM = LZ(R)
        M = NZ(R)
  100   IF ( M .EQ. 0 ) GO TO 110
        IF ( C(M) .EQ. 0 ) GO TO 120
        LM = M
        M = -A(R,M)
        GO TO 100
  110   LJ = J
        J = -A(I,J)
        IF ( J .NE. 0 ) GO TO 90
        U(K) = I
        K = I
        GO TO 140
  120   NZ(R) = -A(R,M)
        LZ(R) = J
        A(R,LM) = -J
        A(R,J) = A(R,M)
        A(R,M) = 0
        C(M) = R
  130   C(J) = I
        A(I,LJ) = A(I,J)
        NZ(I) = -A(I,J)
        LZ(I) = LJ
        A(I,J) = 0
  140 CONTINUE
C RESEARCH OF A NEW ASSIGNMENT
  150 IF ( U(NP1) .EQ. 0 ) RETURN
      DO 160 I=1,N
        CH(I) = 0
        LC(I) = 0
        LR(I) = 0
        RH(I) = 0
  160 CONTINUE
      RH(NP1) = -1
      KSLC = 0
      KSLR = 1
      R = U(NP1)
      LR(R) = -1
      SLR(1) = R
      IF ( A(R,NP1) .EQ. 0 ) GO TO 220
  170 L = -A(R,NP1)
      IF ( A(R,L) .EQ. 0 ) GO TO 180
      IF ( RH(R) .NE. 0 ) GO TO 180
      RH(R) = RH(NP1)
      CH(R) = -A(R,L)
      RH(NP1) = R
  180 IF ( LC(L) .EQ. 0 ) GO TO 200
      IF ( RH(R) .EQ. 0 ) GO TO 210
  190 L = CH(R)
      CH(R) = -A(R,L)
      IF ( A(R,L) .NE. 0 ) GO TO 180
      RH(NP1) = RH(R)
      RH(R) = 0
      GO TO 180
  200 LC(L) = R
      IF ( C(L) .EQ. 0 ) GO TO 360
      KSLC = KSLC+1
      SLC(KSLC) = L
      R = C(L)
      LR(R) = L
      KSLR = KSLR+1
      SLR(KSLR) = R
      IF ( A(R,NP1) .NE. 0 ) GO TO 170
  210 CONTINUE
      IF ( RH(NP1) .GT. 0 ) GO TO 350
C REDUCTION OF THE CURRENT COST MATRIX
  220 H = MAXNUM
      DO 240 J=1,N
        IF ( LC(J) .NE. 0 ) GO TO 240
        DO 230 K=1,KSLR
          I = SLR(K)
          IF ( A(I,J) .LT. H ) H = A(I,J)
  230   CONTINUE
  240 CONTINUE
      MM = MAXNUM - H
      IF (MM .EQ. 0 .OR. T .GT. MM) GO TO 400
      T = T + H
      DO 290 J=1,N
        IF ( LC(J) .NE. 0 ) GO TO 290
        DO 280 K=1,KSLR
          I = SLR(K)
          A(I,J) = A(I,J)-H
          IF ( A(I,J) .NE. 0 ) GO TO 280
          IF ( RH(I) .NE. 0 ) GO TO 250
          RH(I) = RH(NP1)
          CH(I) = J
          RH(NP1) = I
  250     L = NP1
  260     NL = -A(I,L)
          IF ( NL .EQ. 0 ) GO TO 270
          L = NL
          GO TO 260
  270     A(I,L) = -J
  280   CONTINUE
  290 CONTINUE
      IF ( KSLC .EQ. 0 ) GO TO 350
      DO 340 I=1,N
        IF ( LR(I) .NE. 0 ) GO TO 340
        DO 330 K=1,KSLC
          J = SLC(K)
          IF ( A(I,J) .GT. 0 ) GO TO 320
          L = NP1
  300     NL = - A(I,L)
          IF ( NL .EQ. J ) GO TO 310
          L = NL
          GO TO 300
  310     A(I,L) = A(I,J)
          A(I,J) = H
          GO TO 330
  320     MM = MAXNUM - H
          IF (A(I,J) .GT. MM) GO TO 400
          A(I,J) = A(I,J) + H
  330   CONTINUE
  340 CONTINUE
  350 R = RH(NP1)
      GO TO 190
C ASSIGNMENT OF A NEW ROW
  360 C(L) = R
      M = NP1
  370 NM = -A(R,M)
      IF ( NM .EQ. L ) GO TO 380
      M = NM
      GO TO 370
  380 A(R,M) = A(R,L)
      A(R,L) = 0
      IF ( LR(R) .LT. 0 ) GO TO 390
      L = LR(R)
      A(R,L) = A(R,NP1)
      A(R,NP1) = -L
      R = LC(L)
      GO TO 360
  390 U(NP1) = U(R)
      U(R) = 0
      GO TO 150
C ERROR RETURN - INTEGER OVERFLOW OCCURS
  400 IERR = 1
      RETURN
      END
      SUBROUTINE MKP (N,M,P,W,K,BCK,XSTAR,VSTAR,WK,IWK,NUM)
C
C SUBROUTINE TO SOLVE A 0-1 MULTIPLE KNAPSACK PROBLEM OF N
C ITEMS (WITH  N .GE. 2) AND  M  KNAPSACKS (WITH  M .GE. 1 ,
C I.E. ALSO SUITABLE FOR A 0-1 SINGLE KNAPSACK PROBLEM).
C THE PROBLEM TO BE SOLVED IS
C
C MAXIMIZE  VSTAR = P(1)*(X(1,1) + ... + X(M,1)) + ...
C                   ... + P(N)*(X(1,N) + ... + X(M,N))
C SUBJECT TO
C W(1)*X(I,1) + ... + W(N)*X(I,N) .LE. K(I)   FOR  I=1,...,M
C X(1,J) + ... + X(M,J) .LE. 1   FOR  J=1,...,N
C X(I,J) = 0 OR 1   FOR  I=1,...,M ,  J=1,...,N ,
C
C WHERE ALL P(J), W(J), AND K(I) ARE POSITIVE INTEGERS.
C BEFORE MKP IS CALLED, ARRAY K MUST BE SORTED SO THAT
C K(1) .LE. K(2) .LE. ... .LE. K(M) .
C
C MEANING OF THE INPUT PARAMETERS ...
C
C N    = NUMBER OF ITEMS.
C M    = NUMBER OF KNAPSACKS.
C P(J) = PROFIT OF ITEM  J  (J=1,...,N) .
C W(J) = WEIGHT OF ITEM  J  (J=1,...,N) .
C K(I) = CAPACITY OF KNAPSACK  I  (I=1,...,M) .
C BCK  = -1  IF EXACT SOLUTION IS REQUIRED.
C      = MAXIMUM NUMBER OF BACKTRACKINGS TO BE PERFORMED, IF
C        HEURISTIC SOLUTION IS REQUIRED.
C WK   = REAL WORK SPACE OF DIMENSION N.
C IWK  = WORK SPACE OF DIMENSION .GE. 5*M + 14*N + 4*M*N + 3
C NUM  = DIMENSION OF IWK
C
C MEANING OF THE OUTPUT PARAMETERS ...
C
C XSTAR(J) = 0  IF ITEM  J  IS NOT IN THE OPTIMAL SOLUTION
C               (I.E. IF  X(I,J) = 0  FOR ALL  I ).
C          = KNAPSACK WHERE ITEM  J  IS INSERTED, OTHERWISE
C            (I.E. IF  X(XSTAR(J),J) = 1 ).
C VSTAR    = VALUE OF THE OPTIMAL SOLUTION IF  VSTAR .GT. 0.
C          = ERROR CONDITION (INFEASIBILITY OR TRIVIALITY)
C            IN THE INPUT DATA IF  VSTAR .LT. 0 .
C            = -1  IF  N .LT. 2  OR  M .LT. 1 .
C            = -2  IF SOME  P(J) ,  W(J)  OR  K(I) ARE NOT
C                  POSITIVE.
C            = -3  IF A KNAPSACK CANNOT CONTAIN ANY ITEM.
C            = -4  IF AN ITEM CANNOT FIT INTO ANY KNAPSACK.
C            = -5  IF KNAPSACK  M  CONTAINS ALL THE ITEMS.
C            = -7  IF ARRAY  K IS NOT CORRECTLY SORTED.
C            = -8  IF NUM .LT. 5*M + 14*N + 4*M*N + 3.
C
C            (IN ALL THE ABOVE CASES ARRAY  XSTAR IS NOT
C            DEFINED).
C
C ALL THE PARAMETERS EXCEPT WK ARE OF INTEGER TYPE. WHEN MKP
C TERMINATES, ALL THE INPUT PARAMETERS ARE UNCHANGED EXCEPT
C BCK, WHICH GIVES THE NUMBER OF BACKTRACKINGS PERFORMED.
C
      INTEGER P(N),W(N),K(M),XSTAR(N),BCK,VSTAR,IWK(NUM)
      REAL WK(N)
      INTEGER BB, BL, X, XL
      INTEGER B, UBB
      INTEGER F, PBL, Q, V
      INTEGER BS, PS, WS, XS
C
C                    CHECK THE INPUT DATA
C
      IF (M .LT. 1 .OR. N .LT. 2) GO TO 100
      MN = M*N
      IF (NUM .LT. 5*M + 14*N + 4*MN + 3) GO TO 160
C
      IF (P(1) .LE. 0 .OR. W(1) .LE. 0) GO TO 110
      AP = P(1)
      AW = W(1)
      WK(1) = -AP/AW
      MAXW = W(1)
      MINW = W(1)
      ISUMW = W(1)
      DO 10 J = 2,N
         IF (P(J) .LE. 0 .OR. W(J) .LE. 0) GO TO 110
         AP = P(J)
         AW = W(J)
         WK(J) = -AP/AW
         IF (W(J) .GT. MAXW) MAXW = W(J)
         IF (W(J) .LT. MINW) MINW = W(J)
         ISUMW = ISUMW + W(J)
   10 CONTINUE
C
      IF (K(1) .LE. 0) GO TO 110
      IF (M .EQ. 1) GO TO 30
      DO 20 I = 2,M
         IF (K(I) .LE. 0) GO TO 110
         IF (K(I) .LT. K(I-1)) GO TO 150
   20 CONTINUE
C
   30 IF (MINW .GT. K(1)) GO TO 120
      IF (MAXW .GT. K(M)) GO TO 130
      IF (ISUMW .LE. K(M)) GO TO 140
      VSTAR = 0
C
C             REORDER THE ARRAYS P AND W SO THAT
C                P(J)/W(J) .GE. P(J+1)/W(J+1)
C
      N5 = 5*N
      DO 40 J = 1,N
         JJ = N5 + J
         IWK(JJ) = J
   40 CONTINUE
      CALL RISORT (WK, IWK(N5 + 1), N)
C
      DO 50 J = 1,N
         IWK(J) = P(J)
         JN = J + N
         IWK(JN) = W(J)
   50 CONTINUE
C
      DO 60 J = 1,N
         JJ = N5 + J
         L = IWK(JJ)
         P(J) = IWK(L)
         NPL = N + L
         W(J) = IWK(NPL)
   60 CONTINUE
C
C                PARTITION THE WORK SPACE IWK
C
      LX =  JJ + 1
      LXI = LX + N
      BS = LXI + N
      XS =  BS + N
      UBB = XS + N
C
      NP1 = N + 1
      B = UBB + N
      PS = B  + NP1
      WS = PS + NP1
C
      F = WS + NP1
      PBL = F + M
      Q = PBL + M
      V = Q + M
C
      BB = V + M
      X = BB + MN
      XL = X + MN
C
      BL = XL + MN
C
C                     SOLVE THE PROBLEM
C
      CALL MKP1 (N, M, P, W, K, BCK, XSTAR, VSTAR, NP1, N5,
     1           IWK(BB), IWK(BL), IWK(X), IWK(XL),
     2           IWK(B), IWK(UBB), IWK(LX), IWK(LXI),
     3           IWK(F), IWK(PBL), IWK(Q), IWK(V),
     4           IWK(BS), IWK(PS), IWK(WS), IWK(XS), IWK(1))
C
C           RESTORE THE INITIAL ORDERING TO P AND W,
C                AND REORDER XSTAR ACCORDINGLY
C
      DO 70 J = 1,N
         IWK(J) = P(J)
         JN = J + N
         IWK(JN) = W(J)
         JNN = JN + N
         IWK(JNN) = XSTAR(J)
   70 CONTINUE
C
      DO 80 J = 1,N
         JJ = N5 + J
         L = IWK(JJ)
         P(L) = IWK(J)
         JN = J + N
         W(L) = IWK(JN)
         JNN = JN + N
         XSTAR(L) = IWK(JNN)
   80 CONTINUE
      RETURN
C
C                        ERROR RETURN
C
  100 VSTAR = -1
      RETURN
  110 VSTAR = -2
      RETURN
  120 VSTAR = -3
      RETURN
  130 VSTAR = -4
      RETURN
  140 VSTAR = -5
      RETURN
  150 VSTAR = -7
      RETURN
  160 VSTAR = -8
      RETURN
      END
      SUBROUTINE MKP1 (N, M, P, W, K, BCK, XSTAR, VSTAR, NP1, N5,
     1                 BB, BL, X, XL, B, UBB, LX, LXI,
     2                 F, PBL, Q, V, BS, PS, WS, XS, IWK)
C
C MEANING OF THE MAIN INTERNAL VARIABLES AND ARRAYS ...
C
C I       = KNAPSACK CURRENTLY CONSIDERED.
C LB      = LOWER BOUND ON THE OPTIMAL SOLUTION.
C UB      = UPPER BOUND ON THE OPTIMAL SOLUTION.
C VB      = VALUE OF THE CURRENT SOLUTION.
C X(I,J)  = 1  IF ITEM  J  IS INSERTED IN KNAPSACK  I  IN
C              THE CURRENT SOLUTION.
C         = 0  OTHERWISE.
C F(I)    = POINTER TO THE LAST ITEM INSERTED IN KNAPSACK  I
C           ( = -1  IF KNAPSACK  I  IS EMPTY).
C BB(I,J) = POINTER TO THE ITEM INSERTED IN KNAPSACK  I
C           JUST BEFORE ITEM  J ( = -1  IF  J  IS THE FIRST
C           ITEM INSERTED IN KNAPSACK  I ).
C Q(I)    = CURRENT AVAILABLE CAPACITY OF KNAPSACK  I .
C B(J)    = 1  IF ITEM  J  IS NOT INSERTED IN ANY KNAPSACK.
C         = 0  IF ITEM  J  IS INSERTED IN A KNAPSACK.
C PBL(I)  = NUMBER OF THE ITEMS WHICH CAN BE INSERTED IN
C           KNAPSACK  I .
C BL(I,S) = POINTER TO THE  S-TH  ITEM WHICH CAN BE INSERTED
C           IN KNAPSACK  I .
C XL(I,J) = 1  IF ITEM  J  WAS INSERTED IN KNAPSACK  I  IN
C              THE LAST EXECUTION OF SUBROUTINE PI1.
C         = 0  OTHERWISE.
C IWK       WORK SPACE FOR THE SUBROUTINE SKNP.
C
      INTEGER P(N), W(N), K(M), XSTAR(N), BCK, VSTAR
      INTEGER BB(M,N), BL(M,NP1), X(M,N), XL(M,N)
      INTEGER B(NP1), UBB(N), LX(N), LXI(N)
      INTEGER F(M), PBL(M), Q(M), V(M)
      INTEGER BS(N), PS(NP1), WS(NP1), XS(N), IWK(N5)
      INTEGER S, U, UB, VB
C
      IF (M .EQ. 1) GO TO 250
C
C STEP 1 (INITIALIZATION)
C
      JBCK = BCK
      BCK = 0
      KUB = 0
      N1 = N + 1
      B(N1) = 1
      M1 = M - 1
      DO 40 J=1,N
        B(J) = 1
        DO 30 I=1,M
          X(I,J) = 0
          BB(I,J) = 0
   30   CONTINUE
   40 CONTINUE
      DO 50 I=1,M1
        Q(I) = K(I)
        F(I) = -1
   50 CONTINUE
      Q(M) = K(M)
      VSTAR = 0
      VB = 0
      I = 1
      CALL SIGMA1 (N,M,P,W,K,1,B,KUB,UB,NP1,N5,LX,LR,
     *             BS,PS,WS,XS,IWK)
      DO 60 J=1,N
        LXI(J) = LX(J)
   60 CONTINUE
      LRI = LR
      LUBI = UB
      IFLAG = 0
C
C STEP 2 (HEURISTIC)
C
   70 KUB = VSTAR - VB
      CALL PI1 (N,M,P,W,Q,I,B,BB,KUB,BL,LB,PBL,V,XL,
     *          NP1,N5,BS,PS,WS,XS,IWK)
      IF ( LB + VB .LE. VSTAR ) GO TO 140
      VSTAR = LB + VB
      DO 90 J=1,N
        XSTAR(J) = 0
        DO 80 S=1,I
          IF ( X(S,J) .EQ. 0 ) GO TO 80
          XSTAR(J) = S
          GO TO 90
   80   CONTINUE
   90 CONTINUE
      IP = PBL(I)
      IF ( IP .EQ. 0 ) GO TO 110
      DO 100 J=1,IP
        JJ = BL(I,J)
        IF ( XL(I,J) .EQ. 1 ) XSTAR(JJ) = I
  100 CONTINUE
  110 I1 = I + 1
      DO 130 II=I1,M
        IP = PBL(II)
        IF ( IP .EQ. 0 ) GO TO 130
        DO 120 J=1,IP
          JJ = BL(II,J)
          IF ( XL(II,J) .EQ. 1 ) XSTAR(JJ) = II
  120   CONTINUE
  130 CONTINUE
      IF ( UB .EQ. LB ) GO TO 200
C
C STEP 3 (UPDATING)
C
  140 IF ( V(I) .EQ. 0 ) GO TO 180
      IUV = UB + VB
      U = PBL(I)
      IBV = 0
      DO 170 S=1,U
        IF ( XL(I,S) .EQ. 0 ) GO TO 170
        J = BL(I,S)
        X(I,J) = 1
        Q(I) = Q(I) - W(J)
        VB = VB + P(J)
        B(J) = 0
        BB(I,J) = F(I)
        UBB(J) = IUV
        IF ( IFLAG .EQ. 1 ) GO TO 150
        LUB = IUV
        LJ = J
        LI = I
  150   F(I) = J
        IBV = IBV + P(J)
        IF ( IBV .EQ. V(I) ) GO TO 180
        CALL PARC (I,I,UB,IFLAG,VB,LUB,LJ,LI,F,BB,Q,B,N,M,NP1,
     *             LX,LXI,LR,LRI,LUBI)
        IF ( IFLAG .EQ. 1 ) GO TO 160
        KUB = VSTAR - VB
        CALL SIGMA1 (N,M,P,W,Q,I,B,KUB,UB,NP1,N5,LX,LR,
     *               BS,PS,WS,XS,IWK)
        LJ = N1
  160   IUV = UB + VB
        IF ( IUV .LE. VSTAR ) GO TO 200
  170 CONTINUE
  180 IF ( I .EQ. M - 1 ) GO TO 200
      IP1 = I + 1
      CALL PARC (IP1,I,UB,IFLAG,VB,LUB,LJ,LI,F,BB,Q,B,N,M,NP1,
     *           LX,LXI,LR,LRI,LUBI)
      IF ( IFLAG .EQ. 1 ) GO TO 190
      KUB = VSTAR - VB
      CALL SIGMA1 (N,M,P,W,Q,IP1,B,KUB,UB,NP1,N5,LX,LR,
     *             BS,PS,WS,XS,IWK)
      LJ = N1
  190 IF ( UB + VB .LE. VSTAR ) GO TO 200
      I = I + 1
      GO TO 140
C
C STEP 4 (BACKTRACKING)
C
  200 IF ( I .GT. 0 ) GO TO 210
      BCK = BCK - 1
      RETURN
  210 IF ( BCK .EQ. JBCK ) RETURN
      BCK = BCK + 1
      IF ( F(I) .NE. (-1) ) GO TO 230
      DO 220 J=1,N
        BB(I,J) = 0
  220 CONTINUE
      I = I - 1
      GO TO 200
  230 J = F(I)
      X(I,J) = 0
      B(J) = 1
      VB = VB - P(J)
      Q(I) = Q(I) + W(J)
      DO 240 S=1,N
        IF ( BB(I,S) .EQ. J ) BB(I,S) = 0
  240 CONTINUE
      F(I) = BB(I,J)
      IF ( UBB(J) .LE. VSTAR ) GO TO 200
      UB = UBB(J) - VB
      IFLAG = 1
      GO TO 70
C
C PARTICULAR CASE (0-1 SINGLE KNAPSACK PROBLEM)
C
  250 K1 = K(1)
      DO 260 J=1,N
        PS(J) = P(J)
        WS(J) = W(J)
  260 CONTINUE
      CALL SKNP (N,K1,0,VSTAR,N,NP1,N5,PS,WS,XS,IWK)
      DO 270 J=1,N
        XSTAR(J) = XS(J)
  270 CONTINUE
      BCK = 0
      RETURN
      END
      SUBROUTINE SIGMA1 (N,M,P,W,Q,I,B,KUB,UB,NP1,N5,LX,LR,
     *                   BS,PS,WS,XS,IWK)
C
C SUBROUTINE TO COMPUTE AN UPPER BOUND  UB  ON THE BEST
C FINAL SOLUTION WHICH CAN BE OBTAINED FROM THE CURRENT
C SOLUTION.
C
      INTEGER P(N),W(N),Q(M),B(NP1),UB,IWK(N5)
      INTEGER LX(N),BS(N),PS(NP1),WS(NP1),XS(N)
      INTEGER QS,SB
C
      NS = 0
      QS = 0
      DO 10 J=I,M
        QS = QS + Q(J)
   10 CONTINUE
      SB = 0
      DO 20 J=1,N
        LX(J) = 0
        IF ( B(J) .EQ. 0 ) GO TO 20
        NS = NS + 1
        BS(NS) = J
        PS(NS) = P(J)
        WS(NS) = W(J)
        SB = SB + W(J)
   20 CONTINUE
      IF ( SB .GT. QS ) GO TO 40
      LR = QS - SB
      UB = 0
      IF ( NS .EQ. 0 ) RETURN
      DO 30 J=1,NS
        UB = UB + PS(J)
        XS(J) = 1
   30 CONTINUE
      GO TO 50
   40 CALL SKNP (NS,QS,KUB,UB,N,NP1,N5,PS,WS,XS,IWK)
      LR = QS
   50 DO 60 J=1,NS
        JJ = BS(J)
        LX(JJ) = XS(J)
   60 CONTINUE
      RETURN
      END
      SUBROUTINE PI1 (N,M,P,W,Q,I,B,BB,KUB,BL,LB,PBL,V,XL,
     *                NP1,N5,BS,PS,WS,XS,IWK)
C
C SUBROUTINE TO COMPUTE A FEASIBLE SOLUTION TO THE CURRENT
C PROBLEM. THE SOLUTION IS STORED IN ARRAY  XL , THE
C CORRESPONDING VALUE IN  LB .
C
      INTEGER BB(M,N),BL(M,NP1),XL(M,N),IWK(N5)
      INTEGER P(N),W(N),Q(M),B(NP1),PBL(M),V(M)
      INTEGER BS(N),PS(NP1),WS(NP1),XS(N)
      INTEGER PB,QS,SB,U
C
C STEP 1
C
      U = 0
      DO 10 J=1,N
        IF ( B(J) .EQ. 0 ) GO TO 10
        U = U + 1
        BS(U) = J
   10 CONTINUE
      DO 20 J=I,M
        PBL(J) = 0
        V(J) = 0
   20 CONTINUE
      LB = 0
      IKUB = KUB
      IF ( U .EQ. 0 ) RETURN
      NS = 0
      SB = 0
      DO 30 J=1,U
        JJ = BS(J)
        IF ( BB(I,JJ) .NE. 0 ) GO TO 30
        IF ( W(JJ) .GT. Q(I) ) GO TO 30
        NS = NS + 1
        SB = SB + W(JJ)
        BL(I,NS) = JJ
        PS(NS) = P(JJ)
        WS(NS) = W(JJ)
   30 CONTINUE
      II = I
C
C STEP 2
C
   40 PBL(II) = NS
      IF ( SB .GT. Q(II) ) GO TO 60
      PB = 0
      IF ( NS .EQ. 0 ) GO TO 80
      DO 50 J=1,NS
        PB = PB + PS(J)
        XL(II,J) = 1
   50 CONTINUE
      GO TO 80
   60 QS = Q(II)
      KUB = 0
      IF ( II .EQ. M ) KUB = IKUB
      CALL SKNP (NS,QS,KUB,PB,N,NP1,N5,PS,WS,XS,IWK)
      DO 70 J=1,NS
        XL(II,J) = XS(J)
   70 CONTINUE
   80 LB = LB + PB
      IKUB = IKUB - PB
      V(II) = PB
      BL(II,NS+1) = N + 1
C
C STEP 3
C
      IF ( II .EQ. M ) RETURN
      JB = 1
      JBS = 0
      DO 100 J=1,U
        IF ( BS(J) .LT. BL(II,JB) ) GO TO 90
        JB = JB + 1
        IF ( XL(II,JB-1) .EQ. 1 ) GO TO 100
   90   JBS = JBS + 1
        BS(JBS) = BS(J)
  100 CONTINUE
      U = JBS
      IF ( U .EQ. 0 ) RETURN
      NS = 0
      SB = 0
      II = II + 1
      DO 110 J=1,U
        JJ = BS(J)
        IF( W(JJ) .GT. Q(II) ) GO TO 110
        NS = NS + 1
        SB = SB + W(JJ)
        BL(II,NS) = JJ
        PS(NS) = P(JJ)
        WS(NS) =  W(JJ)
  110 CONTINUE
      GO TO 40
      END
      SUBROUTINE PARC (I,II,UB,IFLAG,VB,LUB,LJ,LI,F,BB,Q,B,N,M,NP1,
     *                 LX,LXI,LR,LRI,LUBI)
C
C SUBROUTINE FOR PARAMETRIC COMPUTATION OF THE UPPER BOUNDS.
C
      INTEGER F(M),BB(M,N),Q(M),B(NP1),UB,VB,R,S
      INTEGER LX(N),LXI(N)
C
      IFLAG = 0
      IF ( B(LJ) .NE. 0 ) GO TO 60
      I1 = I - 1
      IF ( I1 .LT. LI ) GO TO 20
      IQ = 0
      DO 10 R=LI,I1
        IQ = IQ + Q(R)
   10 CONTINUE
      IF ( IQ .GT. LR ) RETURN
   20 R = II
      S = F(R)
   30 IF ( S .NE. (-1) ) GO TO 40
      R = R - 1
      S = F(R)
      GO TO 30
   40 IF ( LX(S) .EQ. 0 ) RETURN
      IF ( S .EQ. LJ ) GO TO 50
      S = BB(R,S)
      GO TO 30
   50 UB = LUB - VB
      IFLAG = 1
      RETURN
   60 I1 = I - 1
      IF ( I1 .LT. 1 ) GO TO 80
      IQ = 0
      DO 70 R=1,I1
        IQ = IQ + Q(R)
   70 CONTINUE
      IF ( IQ .GT. LRI ) RETURN
   80 DO 90 J=1,N
        IF ( B(J) .EQ. 1 ) GO TO 90
        IF ( LXI(J) .EQ. 0 ) RETURN
   90 CONTINUE
      UB = LUBI - VB
      IFLAG = 1
      RETURN
      END
      SUBROUTINE SKNP (NS,QS,KUB,VS,N,NP1,N5,PS,WS,XS,IWK)
C
C SUBROUTINE TO SOLVE THE 0-1 SINGLE KNAPSACK PROBLEM
C
C MAXIMIZE    VS = PS(1)*XS(1) + ... + PS(NS)*XS(NS)
C SUBJECT TO       WS(1)*XS(1) + ... + WS(NS)*XS(NS) .LE. QS
C                  XS(J) = 0 OR 1   FOR  J=1,...,NS
C                  VS .GT. KUB
C
C THIS SUBROUTINE IS A MODIFIED VERSION OF SUBROUTINE KP01
C WHICH APPEARED IN  COMPUTING 21, 81-86(1978).
C
      INTEGER QS, VS
      INTEGER PS(NP1), WS(NP1), XS(N), IWK(N5)
C
      I1 = 1
      I2 = I1 + N
      I3 = I2 + N
      I4 = I3 + N
      I5 = I4 + N
      CALL SKNP1 (NS,QS,KUB,VS,N,NP1,PS,WS,XS,IWK(I1),IWK(I2),
     *            IWK(I3),IWK(I4),IWK(I5))
      RETURN
      END
      SUBROUTINE SKNP1 (NS,QS,KUB,VS,N,NP1,PS,WS,XS,D,MIN,
     *                  PBAR,WBAR,ZBAR)
C
C SUBROUTINE TO SOLVE THE 0-1 SINGLE KNAPSACK PROBLEM
C
C MAXIMIZE    VS = PS(1)*XS(1) + ... + PS(NS)*XS(NS)
C SUBJECT TO       WS(1)*XS(1) + ... + WS(NS)*XS(NS) .LE. QS
C                  XS(J) = 0 OR 1   FOR  J=1,...,NS
C                  VS .GT. KUB
C
C THIS SUBROUTINE IS A MODIFIED VERSION OF SUBROUTINE KP01
C WHICH APPEARED IN  COMPUTING 21, 81-86(1978).
C
      INTEGER QS,VS,DIFF,PR,R,T
      INTEGER PS(NP1),WS(NP1),XS(N)
      INTEGER D(N),MIN(N),PBAR(N),WBAR(N),ZBAR(N)
C
      VS = KUB
      IP = 0
      MS = QS
      DO 10 L=1,NS
        LL = L
        IF ( WS(L) .GT. MS ) GO TO 20
        IP = IP + PS(L)
        MS = MS - WS(L)
   10 CONTINUE
   20 LL = LL - 1
      IF ( MS .EQ. 0 ) GO TO 50
      PS(NS+1) = 0
      WS(NS+1) = QS + 1
      LIM = IP + (MS*PS(LL+2))/WS(LL+2)
      A = IP + PS(LL+1)
      B = (WS(LL+1) - MS)*PS(LL)
      C = WS(LL)
      LIM1 = A - B/C
      IF ( LIM1 .GT. LIM ) LIM = LIM1
      IF ( LIM .LE. VS ) RETURN
      MINK = QS + 1
      MIN(NS) = MINK
      DO 30 J=2,NS
        KK = NS + 2 - J
        IF ( WS(KK) .LT. MINK ) MINK = WS(KK)
        MIN(KK-1) = MINK
   30 CONTINUE
      DO 40 J=1,NS
        D(J) = 0
   40 CONTINUE
      PR = 0
      LOLD = NS
      II = 1
      GO TO 170
   50 IF ( VS .GE. IP ) RETURN
      VS = IP
      DO 60 J=1,LL
        XS(J) = 1
   60 CONTINUE
      NN = LL + 1
      DO 70 J=NN,NS
        XS(J) = 0
   70 CONTINUE
      QS = 0
      RETURN
   80 IF ( WS(II) .LE. QS ) GO TO 90
      II1 = II + 1
      IF ( VS .GE. (QS*PS(II1))/WS(II1) + PR ) GO TO 280
      II = II1
      GO TO 80
   90 IP = PBAR(II)
      MS = QS - WBAR(II)
      IN = ZBAR(II)
      LL = NS
      IF ( IN .GT. NS) GO TO 110
      DO 100 L=IN,NS
        LL = L
        IF ( WS(L) .GT. MS ) GO TO 160
        IP = IP + PS(L)
        MS = MS - WS(L)
  100 CONTINUE
  110 IF ( VS .GE. IP + PR ) GO TO 280
      VS = IP + PR
      MFIRST = MS
      NN = II - 1
      DO 120 J=1,NN
        XS(J) = D(J)
  120 CONTINUE
      DO 130 J=II,LL
        XS(J) = 1
  130 CONTINUE
      IF ( LL .EQ. NS ) GO TO 150
      NN = LL + 1
      DO 140 J=NN,NS
        XS(J) = 0
  140 CONTINUE
  150 IF ( VS .NE. LIM ) GO TO 280
      QS = MFIRST
      RETURN
  160 L = LL
      LL = LL - 1
      IF ( MS .EQ. 0 ) GO TO 110
      IF ( VS .GE. PR + IP + (MS*PS(L))/WS(L) ) GO TO 280
  170 WBAR(II) = QS - MS
      PBAR(II) = IP
      ZBAR(II) = LL + 1
      D(II) = 1
      NN = LL - 1
      IF ( NN .LT. II ) GO TO 190
      DO 180 J=II,NN
        WBAR(J+1) = WBAR(J) - WS(J)
        PBAR(J+1) = PBAR(J) - PS(J)
        ZBAR(J+1) = LL + 1
        D(J+1) = 1
  180 CONTINUE
  190 J1 = LL + 1
      DO 200 J=J1,LOLD
        WBAR(J) = 0
        PBAR(J) = 0
        ZBAR(J) = J
  200 CONTINUE
      LOLD = LL
      QS = MS
      PR = PR + IP
      IF ( LL - (NS - 2) ) 240, 220, 210
  210 II = NS
      GO TO 250
  220 IF ( QS .LT. WS(NS) ) GO TO 230
      QS = QS - WS(NS)
      PR = PR + PS(NS)
      D(NS) = 1
  230 II = NS - 1
      GO TO 250
  240 II = LL + 2
      IF ( QS .GE. MIN(II-1) ) GO TO 80
  250 IF ( VS .GE. PR ) GO TO 270
      VS = PR
      DO 260 J=1,NS
        XS(J) = D(J)
  260 CONTINUE
      MFIRST = QS
      IF ( VS .EQ. LIM ) RETURN
  270 IF ( D(NS) .EQ. 0 ) GO TO 280
      D(NS) = 0
      QS = QS + WS(NS)
      PR = PR - PS(NS)
  280 NN = II - 1
      IF ( NN .EQ. 0 ) GO TO 300
      DO 290 J=1,NN
        KK = II - J
        IF ( D(KK) .EQ. 1 ) GO TO 310
  290 CONTINUE
  300 QS = MFIRST
      RETURN
  310 R = QS
      QS = QS + WS(KK)
      PR = PR - PS(KK)
      D(KK) = 0
      IF ( R .LT. MIN(KK) ) GO TO 320
      II = KK + 1
      GO TO 80
  320 NN = KK + 1
      II = KK
  330 IF ( VS .GE. PR + (QS*PS(NN))/WS(NN) ) GO TO 280
      DIFF = WS(NN) - WS(KK)
      IF ( DIFF ) 390, 340, 350
  340 NN = NN + 1
      GO TO 330
  350 IF ( DIFF .GT. R ) GO TO 340
      IF ( VS .GE. PR + PS(NN) ) GO TO 340
      VS = PR + PS(NN)
      DO 360 J=1,KK
        XS(J) = D(J)
  360 CONTINUE
      JJ = KK + 1
      DO 370 J=JJ,NS
        XS(J) = 0
  370 CONTINUE
      XS(NN) = 1
      MFIRST = QS - WS(NN)
      IF ( VS .NE. LIM ) GO TO 380
      QS = MFIRST
      RETURN
  380 R = R - DIFF
      KK = NN
      NN = NN + 1
      GO TO 330
  390 T = R - DIFF
      IF ( T .LT. MIN(NN) ) GO TO 340
      N1 = NN + 1
      IF ( VS .GE. PR + PS(NN) + (T*PS(N1))/WS(N1) ) GO TO 280
      QS = QS - WS(NN)
      PR = PR + PS(NN)
      D(NN) = 1
      II = NN + 1
      WBAR(NN) = WS(NN)
      PBAR(NN) = PS(NN)
      ZBAR(NN) = II
      DO 400 J=N1,LOLD
        WBAR(J) = 0
        PBAR(J) = 0
        ZBAR(J) = J
  400 CONTINUE
      LOLD = NN
      GO TO 80
      END
      SUBROUTINE LAINV (MO,FUN,T,AERR,RERR,Y,C,ERROR,NUM,IERR)
C-----------------------------------------------------------------------
C
C             COMPUTATION OF THE INVERSE LAPLACE TRANSFORM
C              OF A FUNCTION WHICH IS NOT TOO OSCILLATORY
C
C                          ------------------
C
C     MO IS AN INPUT INTEGER WHICH SPECIFIES THE SEARCH PROCEDURE
C     FOR DETERMINATION OF C.  A TWO-PASS PROCEDURE IS USED WHEN
C     MO = 0 , AND A ONE-PASS PROCEDURE IS USED WHEN MO IS NOT ZERO.
C     WHEN ALL SINGULARITIES OF F(Z) ARE EXPECTED TO BE REAL, MO = 0
C     IS PREFERABLE.
C
C     FUN IS A REAL SUBROUTINE DEFINED BY THE USER.  THE ACTUAL NAME
C     FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM.
C     FUN HAS THE ARGUMENTS X, Y, A, AND B.
C
C     T IS A POSITIVE VALUE OF THE INDEPENDENT VARIABLE FOR WHICH
C     THE INVERSE LAPLACE TRANSFORM IS TO BE CALCULATED.
C
C     C IS THE ABSCISSA OF CONVERGENCE.  IT MAY BE EITHER GIVEN
C     OR CALCULATED BY LAINV.
C
C     Y IS THE CALCULATED VALUE OF THE INVERSE LAPLACE TRANSFORM.
C
C     AERR IS THE ABSOLUTE ACCURACY REQUESTED.
C     RERR IS THE RELATIVE ACCURACY REQUESTED.  THE SUBROUTINE
C     ATTEMPTS TO SATISFY THE LESS STRINGENT OF THE TWO REQUIREMENTS.
C     IT IS ASSUMED THAT AERR AND RERR ARE .GE. 0.  IF ONE WANTS
C     ACCURACY TO K SIGNIFICANT FIGURES, THEN RERR SHOULD BE
C     SET = 10.0**(-K).
C
C     ERROR IS THE ESTIMATED ABSOLUTE ERROR OF Y.
C
C     NUM IS THE NUMBER OF EVALUATIONS OF FUN IN LAINV.
C
C     IERR MAY BE EITHER AN INPUT INTEGER OR AN OUTPUT INTEGER.  WHEN
C     IERR IS EQUAL TO ANY NEGATIVE INTEGER AT THE BEGINNING OF LAINV,
C     THE ABSCISSA OF CONVERGENCE IS CALCULATED AND THE VALUE OBTAINED
C     IS ASSIGNED TO THE ARGUMENT C.  OTHERWISE, C MUST BE INPUT BY
C     THE USER.  AFTER COMPLETION OF LAINV, IERR HAS ONE OF THE
C     FOLLOWING VALUES...
C
C        IERR = 0   THE CALCULATION WAS SUCCESSFUL.
C
C        IERR = 1   THE CALCULATED VALUE OF Y MAY NOT BE ACCURATE
C                   DUE TO POSSIBLE INACCURACY IN THE CALCULATION
C                   OF C.  THIS VALUE OF IERR MAY OCCUR ONLY WHEN
C                   IERR IS INITIALLY NEGATIVE.
C
C        IERR = 2   THE CALCULATION OF Y DID NOT CONVERGE, WHILE
C                   THE GIVEN OR CALCULATED VALUE OF C MAY BE
C                   CONSIDERED ACCURATE.
C
C        IERR = 3   THE CALCULATION OF Y DID NOT CONVERGE, AND THE
C                   CALCULATED VALUE OF C MAY BE INACCURATE.  THIS
C                   VALUE OF IERR MAY OCCUR ONLY WHEN IERR IS
C                   INITIALLY NEGATIVE.
C
C        IERR = 4   THE VALUE OF T IS LESS THAN OR EQUAL TO 0.
C                   THE SPECIAL VALUES Y = 0.0 AND ERROR = 1.0
C                   ARE ASSIGNED.
C
C        IERR = 5   C WAS NOT FOUND IN THE INTERVAL (-1.0E4,1.0E4).
C                   THE SPECIAL VALUES C = 0.0, Y = 0.0, AND
C                   ERROR = 1.0 ARE ASSIGNED.
C                   THIS VALUE OF IERR MAY OCCUR ONLY WHEN
C                   IERR IS INITIALLY NEGATIVE.
C
C        IERR = 6   T IS TOO LARGE FOR THE INVERSE TRANSFORM TO BE
C                   COMPUTED. THE VALUES Y = 0.0 AND ERROR = 1.0
C                   ARE ASSIGNED.
C
C-----------------------------------------------------------------------
      EXTERNAL FUN
C
      NUM = 0
      IERC = -1
      IF (IERR .GE. 0) GO TO 10
C
C     CALCULATION OF THE ABSCISSA OF CONVERGENCE.
C
      IF (MO .EQ. 0) GO TO 5
         CALL ABCON1 (FUN,C,NUM,IERC)
         GO TO 10
    5 CALL ABCON (FUN,C,NUM,IERC)
   10 IF (IERC .EQ. 2) GO TO 100
C
C     CHECK IF T IS TOO LARGE
C
      A = C + 2.0/T
      IF (A*T .GT. EXPARG(0)) GO TO 110
C
C     CALCULATION OF THE INVERSE LAPLACE TRANSFORM.
C
      CALL LAINV1 (FUN,T,C,RERR,AERR,Y,ERROR,NUM1,IER)
      NUM = NUM + NUM1
C
C     REPORT THE STATUS OF THE RESULTS.
C
      IF (IERC .GE. 0) GO TO 20
      IF (IER  .EQ. 0) GO TO 30
      IF (IER  .EQ. 1) GO TO 50
   20 IF (IER  .EQ. 2) GO TO 80
      IF (IER  .EQ. 1) GO TO 60
      IF (IERC .EQ. 1) GO TO 40
C
   30 IERR = 0
      RETURN
   40 IERR = 1
      RETURN
   50 IERR = 2
      RETURN
   60 IF (IERC .EQ. 1) GO TO 70
         IERR = 2
         RETURN
   70 IERR = 3
      RETURN
   80 IERR = 4
      RETURN
C
  100 Y = 0.0
      ERROR = 1.0
      IERR = 5
      RETURN
  110 Y = 0.0
      ERROR = 1.0
      IERR = 6
      RETURN
      END
      SUBROUTINE ABCON (FUN, C, NUM, IERR)
C-----------------------------------------------------------------------
C
C             COMPUTATION OF THE ABSCISSA OF CONVERGENCE
C             OF A FUNCTION WHICH IS NOT TOO OSCILLATORY
C
C                         -----------------
C
C     FUN IS A REAL SUBROUTINE DEFINED BY THE USER.  THE ACTUAL NAME
C     FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM.
C     FUN HAS THE ARGUMENTS X, Y, A, AND B.
C
C     C IS THE CALCULATED VALUE OF THE ABSCISSA OF CONVERGENCE.
C
C     NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER
C     OF EVALUATIONS OF FUN THAT WERE PERFORMED.
C
C     IERR IS AN OUTPUT INTEGER REPORTING THE STATUS OF THE
C     CALCULATION OF C.  IERR IS ASSIGNED VALUES AS FOLLOWS...
C
C        IERR = 0   THE CALCULATION WAS SUCCESSFUL.
C
C        IERR = 1   THE REQUESTED ACCURACY MAY NOT HAVE BEEN
C                   OBTAINED.  MORE SUBINTERVALS MAY BE REQUIRED
C                   IN THE NUMERICAL QUADRATURES IN SUBROUTINES
C                   ACOND AND XCOND.
C
C        IERR = 2   C COULD NOT BE CALCULATED WITH SUFFICIENT
C                   ACCURACY, OR AN INTERVAL CONTAINING C COULD
C                   NOT BE FOUND. THE SPECIAL VALUE C = 0.0 IS
C                   ASSIGNED.
C
C-----------------------------------------------------------------------
      LOGICAL FIND
      EXTERNAL FUN, ACOND, XCOND
C
      ETA = 0.01
      XMIN = -1.00358E4
C
C     CALCULATION OF THE LOCATION OF THE SINGULARITY ON THE REAL
C     AXIS WHICH IS FARTHEST TO THE RIGHT. SET THIS VALUE TO X0.
C
      CALL SRCH(FUN, XCOND, XMIN, ETA, X0, NUM, IERR)
      C = X0
      IF (IERR .EQ. 2) GO TO 20
      IF (IERR .EQ. 3) GO TO 10
C
C     CHECK IF X0 IS ON THE RIGHT OR LEFT OF THE ABSCISSA OF
C     CONVERGENCE. IF IT IS ON THE RIGHT THEN WE ARE DONE.
C
      CALL ACOND(FUN, X0, FIND, NUM1, IERR)
      NUM = NUM + NUM1
      IF (FIND) GO TO 20
C
C     SEARCH TO THE RIGHT OF X0 TO FIND THE ABSCISSA OF
C     CONVERGENCE.
C
   10 CALL SRCH(FUN, ACOND, X0, ETA, C, NUM1, IERR)
      NUM = NUM + NUM1
      IF (IERR .EQ. 3) C = 0.0
C
C     TERMINATION
C
   20 IERR = MIN0(IERR,2)
      RETURN
      END
      SUBROUTINE SRCH (FUN,COND,XL,ETA,X,NUM,IERR)
C-----------------------------------------------------------------------
C     SRCH COMPUTES AN UPPER BOUND FOR THE SMALLEST NUMBER X SUCH
C     THAT A GIVEN CONDITION IS SATISFIED. IT IS ASSUMED THAT THE
C     CONDITION IS SATISFIED FOR SUFFICIENTLY LARGE X.
C-----------------------------------------------------------------------
C     FUN IS A REAL SUBROUTINE DEFINED BY THE USER.  THE ACTUAL NAME
C     FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM.
C     FUN HAS THE ARGUMENTS X, Y, A, AND B.
C
C     COND IS A REAL SUBROUTINE DEFINED BY THE USER.  THE ACTUAL NAME
C     FOR COND NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM.
C     COND HAS THE ARGUMENTS FUN, X, CND, AND IER, WHERE CND IS
C     A LOGICAL VARIABLE.
C
C     XL IS THE SMALLEST VALUE OF X FOR WHICH A SEARCH IS MADE.  IT
C     SHOULD LIE IN THE RANGE - 1.0E4 .LE. XL .LT. 1.0E4.  IT IS
C     ASSUMED THAT THE LOGICAL VARIABLE CND CALCULATED BY COND IS
C     .FALSE. WHEN X = XL.
C
C     ETA IS THE RELATIVE TOLERANCE TO WHICH THE RESULT IS TO BE
C     DETERMINED. IT IS A POSITIVE REAL NUMBER. WHEN THIS SUBROUTINE
C     IS USED TO CALCULATE C FOR USE IN THE PIESSENS CODE LAINV1
C     (ALGORITHM 619), IT IS USUALLY SUFFICIENT TO TAKE ETA = 0.01.
C
C     X IS THE CALCULATED RESULT.  IT IS LARGER THAN THE EXACT
C     RESULT BY AN AMOUNT LESS THAN ETA*X.
C
C     NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER
C     OF EVALUATIONS OF FUN THAT WERE PERFORMED.
C
C     IERR IS AN OUTPUT INTEGER REPORTING THE STATUS OF THE
C     CALCULATION OF X.  IERR IS ASSIGNED VALUES AS FOLLOWS...
C
C          IERR = 0     THE CALCULATION WAS FULLY SUCCESSFUL.
C
C          IERR = 1     X MAY BE IN ERROR DUE TO THE CALCULATION
C                       OF COND.
C
C          IERR = 2     CND IS .FALSE. WHEN X = 1.0E4.  X IS SET = 0.0.
C
C          IERR = 3     CND IS .TRUE. FOR  X .GE. XL.  X IS SET TO XL.
C
      LOGICAL CND
      EXTERNAL FUN, COND
      IERR = 0
C
C     SEARCH FOR AN INTERVAL (X1, X2) CONTAINING X WHERE
C     X1 .GE. 0.01269
C
      X1 = AMAX1(.01269, XL)
      CALL COND(FUN,X1,CND,NUM,IER)
      IF (CND) GO TO 20
C
         X2 = 10.1269
         DO 10 I = 1,4
            IF (X2 .LE. X1) GO TO 10
            CALL COND(FUN,X2,CND,NUM1,IER)
            NUM = NUM + NUM1
            IF (CND) GO TO 200
            X1 = X2
   10       X2 = 10.0*X2
         GO TO 300
C
   20 IF (X1 .EQ. XL) GO TO 400
C
C     SEARCH FOR AN INTERVAL (X1, X2) CONTAINING X WHERE
C     X2 .LE. 0.01269
C
         X2 = X1
         X1 = -.100358
         DO 30 I = 1,6
            X1 = AMAX1(X1, XL)
            CALL COND(FUN,X1,CND,NUM1,IER)
            NUM = NUM + NUM1
            IF(.NOT. CND) GO TO 200
            X2 = X1
            IF (X1 .EQ. XL) GO TO 400
   30    X1 = 10.0*X1
C
C     SEARCH FOR X IN THE INTERVAL (X1, X2) BY BISECTION
C
  200       DX = X2 - X1
            XBAR = X1 + DX/2.0
            CALL COND(FUN,XBAR,CND,NUM1,IERR)
            NUM = NUM + NUM1
            XM = AMAX1(ABS(X1), ABS(X2))
            TOL = ETA
            IF (XM .GT. 1.0) TOL = ETA*XM
            IF (DX .LE. TOL) GO TO 250
               IF(CND) GO TO 225
                  X1 = XBAR
                  GO TO 200
  225          X2 = XBAR
               GO TO 200
C
C     FINAL ASSEMBLY
C
  250       IF(CND) GO TO 275
               X = X2
               RETURN
  275       X = XBAR
            RETURN
C
C     ERROR RETURN WHEN X COULD NOT BE FOUND IN THE INTERVAL
C     (-1.0E4, 1.OE4).
C
  300 X = 0.0
      IERR = 2
      RETURN
  400 X = XL
      IERR = 3
      RETURN
      END
      SUBROUTINE ABCON1 (FUN, C, NUM, IERR)
C-----------------------------------------------------------------------
C
C             COMPUTATION OF THE ABSCISSA OF CONVERGENCE
C             OF A FUNCTION WHICH IS NOT TOO OSCILLATORY
C
C                         -----------------
C
C     FUN IS A REAL SUBROUTINE DEFINED BY THE USER. THE ACTUAL NAME
C     FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM.
C     FUN HAS THE ARGUMENTS X, Y, A, AND B.
C
C     C IS THE CALCULATED VALUE OF THE ABSCISSA OF CONVERGENCE.
C
C     NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER
C     OF EVALUATIONS OF FUN THAT WERE PERFORMED.
C
C     IERR IS AN OUTPUT INTEGER REPORTING THE STATUS OF THE
C     CALCULATION OF C.  IERR IS ASSIGNED VALUES AS FOLLOWS...
C
C        IERR = 0   THE CALCULATION WAS SUCCESSFUL.
C
C        IERR = 1   THE REQUESTED ACCURACY MAY NOT HAVE BEEN
C                   OBTAINED.  MORE SUBINTERVALS MAY BE REQUIRED
C                   IN THE NUMERICAL QUADRATURES IN SUBROUTINES
C                   ACOND AND XCOND.
C
C        IERR = 2   C COULD NOT BE CALCULATED WITH SUFFICIENT
C                   ACCURACY, OR AN INTERVAL CONTAINING C COULD
C                   NOT BE FOUND. THE SPECIAL VALUE C = 0.0 IS
C                   ASSIGNED.
C
C-----------------------------------------------------------------------
      LOGICAL CMPLEX, IEND, RIGHT
      EXTERNAL FUN, ACOND, XCOND
C
      ETA = 0.01
      CMPLEX = .FALSE.
C
      X1 = .01269
      CALL XCOND (FUN,X1,RIGHT,NUM,IERR)
      IF (.NOT. RIGHT) GO TO 10
      CALL ACOND (FUN,X1,RIGHT,NUM1,IERR)
      NUM = NUM + NUM1
      IF (RIGHT) GO TO 30
      CMPLEX = .TRUE.
C
C     SEARCH FOR AN INTERVAL (X1, X2) CONTAINING X WHERE
C     X1 .GE. 0.01269
C
   10    X2 = 10.1269
         DO 22 I = 1,4
            IF (CMPLEX) GO TO 20
               CALL XCOND (FUN,X2,RIGHT,NUM1,IERR)
               NUM = NUM + NUM1
               IF (.NOT. RIGHT) GO TO 21
   20       CALL ACOND (FUN,X2,RIGHT,NUM1,IERR)
            NUM = NUM + NUM1
            IF (RIGHT) GO TO 50
            CMPLEX = .TRUE.
   21       X1 = X2
            X2 = 10.0*X2
   22    CONTINUE
         GO TO 100
C
C     SEARCH FOR AN INTERVAL (X1, X2) CONTAINING X WHERE
C     X2 .LE. 0.01269
C
   30    X2 = X1
         X1 = -.100358
         DO 40 I = 1,6
            CALL XCOND (FUN,X1,RIGHT,NUM1,IERR)
            NUM = NUM + NUM1
            IF (.NOT. RIGHT) GO TO 50
            CALL ACOND (FUN,X1,RIGHT,NUM1,IERR)
            NUM = NUM + NUM1
            IF (.NOT. RIGHT) GO TO 45
            X2 = X1
            X1 = 10.0*X1
   40    CONTINUE
         GO TO 100
C
   45    CMPLEX = .TRUE.
C
C     SEARCH FOR X IN THE INTERVAL (X1, X2) BY BISECTION
C
   50       DX = X2 - X1
            XBAR = X1 + DX/2.0
            XM = AMAX1(ABS(X1), ABS(X2))
            TOL = ETA
            IF (XM .GT. 1.0) TOL = ETA*XM
            IEND =  DX .LE. TOL
C
            IF (CMPLEX) GO TO 60
            CALL XCOND (FUN,XBAR,RIGHT,NUM1,IERR)
            NUM = NUM + NUM1
            IF (RIGHT) GO TO 60
               IF (IEND) GO TO 80
               X1 = XBAR
               GO TO 50
C
   60       CALL ACOND (FUN,XBAR,RIGHT,NUM1,IERR)
            NUM = NUM + NUM1
            IF (RIGHT) GO TO 70
               IF (IEND) GO TO 80
               X1 = XBAR
               CMPLEX = .TRUE.
               GO TO 50
   70       X2 = XBAR
            IF (.NOT. IEND) GO TO 50
C
C     STANDARD TERMINATION
C
   80    C = X2
         RETURN
C
C     ERROR RETURN WHEN X CANNOT BE FOUND IN (-1.E4, 1.E4)
C
  100 C = 0.0
      IERR = 2
      RETURN
      END
      SUBROUTINE ACOND (FUN, X, COND, NUM, IERR)
C-----------------------------------------------------------------------
C
C        THIS SUBROUTINE TESTS WHETHER OR NOT A GIVEN VALUE OF X
C        LIES TO THE RIGHT OF THE ABSCISSA OF CONVERGENCE OF THE
C        COMPLEX FUNCTION DEFINED BY FUN WHEN NO SINGULARITIES LIE
C        ON THE REAL AXIS.
C
C                      ----------------
C
C     FUN IS A REAL SUBROUTINE DEFINED BY THE USER.  THE ACTUAL NAME
C     FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM.
C     FUN HAS THE ARGUMENTS X, Y, A, AND B.
C
C     X IS A REAL NUMBER. THE LOGICAL VARIABLE COND = .TRUE. IF
C     X .GT. C, WHERE C IS THE ABSCISSA OF CONVERGENCE, AND .FALSE.
C     IF X .LT. C.
C
C     NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER
C     OF EVALUATIONS OF FUN THAT WERE PERFORMED.
C
C     IERR IS AN OUTPUT INTEGER INDICATING THE STATUS OF THE
C     CALCULATION. IT IS ASSIGNED VALUES AS FOLLOWS...
C
C        IERR = 0   THE CALCULATION WAS SUCCESSFUL.
C
C        IERR = 1   THE CALCULATION OF COND MAY NOT BE
C                   ACCURATE FOR ALL VALUES OF X.
C
C-----------------------------------------------------------------------
      DIMENSION IWK(100), WK(400)
      LOGICAL COND
      EXTERNAL FUN, ACONDF, ACONDG
C--------------------------
      DATA L /100/, M /400/
      DATA AERR /1.E-30/, RERR /1.E-4/, TOL /1.E-4/
C--------------------------
      C = X
C
C     CALCULATION OF THE INTEGRAL OF ACONDF FROM X TO INFINITY.
C
      CALL QAGI1 (ACONDF,FUN,Y,C,X,1,AERR,RERR,Z1,ERROR1,NUM1,IER1,
     *            L,M,N,IWK,WK)
C
C     CALCULATION OF THE INTEGRAL OF ACONDG FROM 0 TO INFINITY.
C
      A = 0.0
      CALL QAGI1 (ACONDG,FUN,Y,C,A,1,AERR,RERR,Z2,ERROR2,NUM2,IER2,
     *            L,M,N,IWK,WK)
      NUM = NUM1 + NUM2
      IER = MAX0(IER1, IER2)
C
C     DETERMINATION OF COND.
C
      COND = .FALSE.
      IF (ABS(Z1 - Z2) .LE. TOL*AMAX1(ABS(Z1),ABS(Z2))) COND = .TRUE.
C
C     SET IERR AND RETURN
C
      IERR = 0
      IF (IER .GT. 4) IERR = 1
      RETURN
      END
      FUNCTION ACONDF (X, Y, C, FUN)
C-----------------------------------------------------------------------
C        ACONDF IS THE FUNCTION INTEGRATED ALONG THE X-AXIS IN
C        ACOND. Y IS A DUMMY VARIABLE.
C-----------------------------------------------------------------------
      EXTERNAL FUN
C
      CALL FUN (X, 0.0, A, B)
      T = 1.0/((X - C) + 1.0)
      ACONDF = A*T*T
      RETURN
      END
      FUNCTION ACONDG (X, Y, C, FUN)
C-----------------------------------------------------------------------
C        ACONDG IS THE FUNCTION INTEGRATED ALONG THE LINE X = C
C        IN ACOND. Y IS A DUMMY VARIABLE.
C-----------------------------------------------------------------------
      EXTERNAL FUN
C
      CALL FUN (C, X, A, B)
      CALL CREC (1.0, X, S, T)
      U = S*S - T*T
      V = 2.0*S*T
      ACONDG = -(A*V + B*U)
      RETURN
      END
      SUBROUTINE XCOND (FUN, X, COND, NUM, IERR)
C-----------------------------------------------------------------------
C
C        THIS SUBROUTINE TESTS WHETHER OR NOT A GIVEN VALUE OF X
C        LIES TO THE RIGHT OF ALL SINGULARITIES OF THE COMPLEX
C        FUNCTION DEFINED BY FUN WHICH LIE ON THE REAL AXIS.
C
C                         ------------
C
C     FUN IS A REAL SUBROUTINE DEFINED BY THE USER.  THE ACTUAL NAME
C     FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM.
C     FUN HAS THE ARGUMENTS X, Y, A, AND B.
C
C     X IS A REAL NUMBER.  THE LOGICAL VARIABLE COND = .TRUE IF
C     X .GT. C, WHERE C IS THE ABSCISSA OF THE SINGULARITY ON THE
C     REAL AXIS WHICH LIES FARTHEST TO THE RIGHT, AND .FALSE. IF
C     X .LT. C.
C
C     NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER
C     OF EVALUATIONS OF FUN THAT WERE PERFORMED.
C
C     IERR IS AN OUTPUT INTEGER INDICATING THE STATUS OF THE
C     CALCULATION.  IT IS ASSIGNED VALUES AS FOLLOWS...
C
C        IERR = 0   THE CALCULATION WAS SUCCESSFUL.
C
C        IERR = 1   THE CALCULATION OF COND MAY NOT BE
C                   ACCURATE FOR ALL VALUES OF X.
C
C-----------------------------------------------------------------------
      DIMENSION IWK(100), WK(400)
      LOGICAL COND
      EXTERNAL FUN, XCONDX, XCONDY
C--------------------------
      DATA L /100/, M /400/
      DATA AERR /1.E-30/, RERR /1.E-4/, TOL /1.E-4/
      DATA EPSR /1.E-2/
C--------------------------
      C = 1.0 - X
      Y = EPSR
      COND = .FALSE.
C
C     NUMERICAL INTEGRATION OF THE IMAGINARY PART OF THE INTEGRAND
C     ALONG THE LINE Y = EPSR.
C
      CALL QAGI1 (XCONDY,FUN,Y,C,X,1,AERR,RERR,Z,ERROR,NUM,IERR,
     *            L,M,N,IWK,WK)
      IF (IERR .NE. 0) GO TO 100
C
C     DETERMINATION OF COND.
C
      Y1 = 0.5*Y
      T = (XCONDX(X,Y,C,FUN) + 4.0*XCONDX(X,Y1,C,FUN) +
     *           XCONDX(X,0.0,C,FUN))*EPSR/6.0
      NUM = NUM + 3
      IF (T*Z .GT. 0.0) RETURN
      IF (ABS(T + Z) .GT. TOL*AMAX1(ABS(T), ABS(Z))) RETURN
         COND = .TRUE.
         RETURN
C
C     ERROR RETURN
C
  100 IERR = 1
      RETURN
      END
      FUNCTION XCONDX (X,Y,C,FUN)
C
C     REAL PART OF THE INTEGRAND IN XCOND
C
      EXTERNAL FUN
C
      CALL FUN (X, Y, A, B)
      CALL CREC (X + C, Y, S, T)
      U = S*S - T*T
      V = 2.0*S*T
      XCONDX = A*U - B*V
      RETURN
      END
      FUNCTION XCONDY (X,Y,C,FUN)
C
C     IMAGINARY PART OF INTEGRAND IN XCOND
C
      EXTERNAL FUN
C
      CALL FUN (X, Y, A, B)
      CALL CREC (X + C, Y, S, T)
      U = S*S - T*T
      V = 2.0*S*T
      XCONDY = A*V + B*U
      RETURN
      END
       SUBROUTINE LAINV1(FUN,T,C,EPSRE,EPSAB,RESULT,ESTERR,NUM,
     *   IER)
C
C ......................................................................
C
C   1. LAINV1
C        INVERSION OF LAPLACE TRANSFORM USING THE DURBIN FORMULA
C        IN COMBINATION WITH THE EPSILON ALGORITHM
C
C   2. PURPOSE
C        THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO THE
C        INVERSE LAPLACE TRANSFORM F(T) OF FUN, FOR THE VALUE
C        OF THE INDEPENDENT VARIABLE EQUAL TO T, HOPEFULLY
C        SATISFYING THE FOLLOWING CLAIM FOR ACCURACY ....
C        ABS(F(T)-RESULT).LE.MAX(EPSAB,EPSRE*ABS(F(T)))
C
C   3. CALLING SEQUENCE
C        CALL LAINV1(FUN,T,C,EPSRE,EPSAB,RESULT,ESTERR,NUM,IER)
C
C      INPUT PARAMETERS
C        FUN    - REAL
C                 SUBROUTINE DEFINING THE LAPLACE TRANSFORM AS
C                 A COMPLEX FUNCTION.  THE CALLING SEQUENCE OF
C                 FUN IS CALL FUN(A,B,C,D) WHERE
C                 A - REAL
C                     REAL PART OF THE INDEPENDENT VARIABLE
C                     OF THE LAPLACE TRANSFORM (INPUT)
C                 B - REAL
C                     IMAGINARY PART OF THE INDEPENDENT
C                     VARIABLE OF THE LAPLACE TRANSFORM (INPUT)
C                 C - REAL
C                     REAL PART OF THE VALUE OF THE LAPLACE
C                     TRANSFORM (OUTPUT)
C                 D - REAL
C                     IMAGINARY PART OF THE VALUE OF THE
C                     LAPLACE TRANSFORM (OUTPUT)
C                 THE ACTUAL NAME FOR FUN NEEDS TO BE DECLARED
C                 EXTERNAL IN THE DRIVER PROGRAM.
C
C        T      - REAL
C                 VALUE OF THE INDEPENDENT VARIABLE FOR WHICH THE
C                 INVERSE LAPLACE TRANSFORM HAS TO BE COMPUTED.
C                 T SHOULD BE GREATER THAN ZERO.
C
C        C      - REAL
C                 ABSCISSA OF CONVERGENCE OF THE LAPLACE TRANSFORM
C
C        EPSRE  - REAL
C                 RELATIVE ACCURACY REQUESTED.  IT IS ASSUMED THAT
C                 EPSRE .GE. 0.  IF ONE WANTS ACCURACY TO K SIGNIFICANT
C                 FIGURES, THEN RERR SHOULD BE SET = 10.0**(-K).
C
C        EPSAB  - REAL
C                 ABSOLUTE ACCURACY REQUESTED.  IT IS ASSUMED THAT
C                 EPSAB .GE. 0.  THE ROUTINE TRIES TO SATISFY THE
C                 LEAST STRINGENT OF BOTH ACCURACY REQUIREMENTS.
C
C      OUTPUT PARAMETERS
C        RESULT - REAL
C                 INVERSE LAPLACE TRANSFORM
C
C        ESTERR - REAL
C                 ESTIMATE OF THE ABSOLUTE ERROR ABS(F(T)-RESULT)
C
C        NUM    - INTEGER
C                 NUMBER OF EVALUATIONS OF FUN
C
C        IER    - INTEGER
C                 PARAMETER GIVING INFORMATION ON THE TERMINATION
C                 OF THE ALGORITHM
C                 IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                         ROUTINE
C                 IER = 1 THE COMPUTATIONS ARE TERMINATED BECAUSE
C                         THE BOUND ON THE NUMBER OF EVALUATIONS
C                         OF FUN HAS BEEN ACHIEVED.  THIS BOUND
C                         IS EQUAL TO 8*MAX+5 WHERE  MAX  IS A
C                         NUMBER INITIALIZED IN A DATA
C                         STATEMENT.  ONE CAN ALLOW MORE FUNCTION
C                         EVALUATIONS BY INCREASING THE VALUE OF
C                         MAX IN THE DATA-STATEMENT.
C                 IER = 2 THE VALUE OF T IS LESS THAN OR EQUAL
C                         TO ZERO.
C
C   4. SUBROUTINES OR FUNCTIONS NEEDED
C                FUN - USER PROVIDED SUBROUTINE
C                CQEXT - EPSILON ALGORITHM
C                SPMPAR - THIS FUNCTION IS CALLED BY
C                          CQEXT, AND PROVIDES MACHINE CONSTANTS
C                ATAN, EXP, AMAX1, SIN, ABS,
C                DBLE, CMPLX, REAL - FORTRAN FUNCTIONS
C
C ......................................................................
C
      COMPLEX REX,CRES,RES3LA
      INTEGER I,IER,K,KC,KK,KS,M,NEX,NRES,NUM
      DIMENSION SI(32),RES3LA(3),REX(52)
C
C   THE ARRAY SI CONTAINS VALUES OF THE SINE AND COSINE FUNCTIONS
C   REQUIRED IN THE DURBIN FORMULA. SI(8) AND SI(16) ARE GIVEN IN
C   THE FOLLOWING DATA STATEMENT. THE OTHER VALUES ARE COMPUTED.
C
      DATA SI(8),SI(16)/ 1.0E+00,0.0E+00/
C
C   MAX IS A BOUND ON THE NUMBER OF TERMS USED IN THE DURBIN
C   FORMULA.
C
      DATA MAX/500/
C ....................................................
C
C   EPS IS A MACHINE DEPENDENT CONSTANT.  EPS IS THE
C   SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1.
C
      EPS = SPMPAR(1)
C ....................................................
C
C   CALCULATION OF THE RELATIVE TOLERANCE USED.
C
      TOL = 10.0*EPS
      EPSR1 = AMAX1(TOL,EPSRE)
C
C   TEST ON VALIDITY OF THE INPUT PARAMETER T
C
      IER = 2
      RESULT = 0.0E+00
      ESTERR = 1.0E+00
      NUM = 0
      IF (T.LE.0.0E+00) GO TO 999
C
C   PID16 IS EQUAL TO PI/16
C
      PID16 = ATAN(1.0E+00)/4.0E+00
C
C   COMPUTATION OF THE ELEMENTS OF THE ARRAY SI
C
      AK = 1.0E+00
      DO 10 K=1,7
        SI(K) = SIN(AK*PID16)
        AK = AK+1.0E+00
        KK = 16-K
        SI(KK) = SI(K)
10    CONTINUE
      IER = 0
      NRES = 0
      DO 20 K=17,32
        SI(K) = -SI(K-16)
20    CONTINUE
C
C   INITIALIZATION OF THE SUMMATION OF THE DURBIN FORMULA.
C
      ARG = PID16/T
      ARE = C+2.0E+00/T
      AIM = 0.0E+00
      BB = EXP(ARE*T)/(1.6E+01*T)
      CALL FUN (ARE,AIM,FRE,FIM)
      NUM = 5
      R = 5.0E-01*FRE
      S = 0.0
      NEX = 0
      KC = 8
      KS = 0
C
C   MAIN LOOP FOR THE SUMMATION
C
      DO 40 I=1,MAX
        M = 8
        IF (I.EQ.1) M = 12
        DO 30 K=1,M
          AIM = AIM+ARG
          KC = KC+1
          KS = KS+1
          IF (KC.GT.32) KC = 1
          IF (KS.GT.32) KS = 1
          CALL FUN(ARE,AIM,FRE,FIM)
      A = FRE*SI(KC)
      B = -FIM*SI(KS)
      R = DBLE(R) + DBLE(A) + DBLE(B)
      E = FRE*SI(KS)
      F = FIM*SI(KC)
      S = DBLE(S) + DBLE(E) + DBLE(F)
30      CONTINUE
        NUM = NUM+8
        NEX = NEX+1
        REX(NEX) = CMPLX(R, S)
C
C   EXTRAPOLATION USING THE EPSILON ALGORITHM
C
        IF(NEX.GE.3) CALL CQEXT(NEX,REX,CRES,ESTERR,RES3LA,NRES)
        IF(NRES.LT.4) GO TO 40
C
C   COMPUTATION OF INTERMEDIATE RESULT AND ESTIMATE OF THE
C   ABSOLUTE ERROR
C
        RESULT = REAL(CRES)
        RESULT = RESULT * BB
        ESTERR = ESTERR * BB
        IF (ESTERR.LT.AMAX1(EPSAB,EPSR1*ABS(RESULT)).AND.ABS(R*BB-
     *   RESULT).LT.5.0E-01*ABS(RESULT)) GO TO 999
40    CONTINUE
C
C   SET ERROR FLAG IN THE CASE THAT THE NUMBER OF TERMS IN THE
C   SUMMATION IS EQUAL TO MAX
C
      IER = 1
999   RETURN
      END
      SUBROUTINE CQEXT(N,EPSTAB,RESULT,ABSERR,RES3LA,NRES)
C
C 1.        CQEXT
C           EPSILON ALGORITHM
C              STANDARD FORTRAN SUBROUTINE
C              COMPLEX VERSION
C
C 2.        PURPOSE
C              THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF
C              APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM
C              OF P. WYNN.
C              AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN.
C              THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE
C              ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL
C              ARE PRESERVED.
C
C 3.        CALLING SEQUENCE
C              CALL CQEXT(N,EPSTAB,RESULT,ABSERR,RES3LA,NRES)
C
C           PARAMETERS
C              N      - INTEGER
C                       EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE
C                       FIRST COLUMN OF THE EPSILON TABLE.
C
C              EPSTAB - COMPLEX
C                       VECTOR OF DIMENSION 52 CONTAINING THE ELEMENTS
C                       OF THE TWO LOWER DIAGONALS OF THE
C                       TRIANGULAR EPSILON TABLE
C                       THE ELEMENTS ARE NUMBERED STARTING AT THE
C                       RIGHT-HAND CORNER OF THE TRIANGLE.
C
C              RESULT - COMPLEX
C                       RESULTING APPROXIMATION TO THE INTEGRAL
C
C              ABSERR - REAL
C                       ESTIMATE OF THE ABSOLUTE ERROR OF THE REAL
C                       PART OF RESULT COMPUTED FROM RESULT AND
C                       THE 3 PREVIOUS RESULTS
C
C              RES3LA - COMPLEX
C                       VECTOR OF DIMENSION 3 CONTAINING THE LAST 3
C                       RESULTS
C
C              NRES   - INTEGER
C                       NUMBER OF CALLS TO THE ROUTINE
C                       (SHOULD BE ZERO AT FIRST CALL)
C
C 4.        SUBROUTINES OR FUNCTIONS NEEDED
C                     - SPMPAR, CDIVID
C                     - FORTRAN ABS, AMAX1, CABS, CMPLX,
C                       REAL, AIMAG, SNGL
C
C     ..................................................................
C
      COMPLEX DELTA1,DELTA2,DELTA3,
     *  EPSTAB,E0,E1,E2,E3,
     *  RES,RESULT,RES3LA,SS
      DOUBLE PRECISION R,S,U1,U2,U3,V1,V2,V3,SS1,SS2,W1,W2
      INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM
      DIMENSION EPSTAB(52),RES3LA(3)
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           E0     - THE 4 ELEMENTS ON WHICH THE
C           E1       COMPUTATION OF A NEW ELEMENT IN
C           E2       THE EPSILON TABLE IS BASED
C           E3                 E0
C                        E3    E1    NEW
C                              E2
C           NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW
C                    DIAGONAL
C           ERROR  - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2)
C           RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE
C                    OF ERROR
C
C           MACHINE DEPENDENT CONSTANTS
C           ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C           LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON
C           TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER
C           DIAGONAL OF THE EPSILON TABLE IS DELETED.
C
C***FIRST EXECUTABLE STATEMENT
      OFLOW = SPMPAR(3)
      EPMACH = SPMPAR(1)
      NRES = NRES+1
      ABSERR = OFLOW
      RESULT = EPSTAB(N)
      IF(N.LT.3) GO TO 100
      LIMEXP = 50
      EPSTAB(N+2) = EPSTAB(N)
      NEWELM = (N-1)/2
      EPSTAB(N) = CMPLX(OFLOW,0.0)
      NUM = N
      K1 = N
      DO 40 I = 1,NEWELM
        K2 = K1-1
        K3 = K1-2
        RES = EPSTAB(K1+2)
        E0 = EPSTAB(K3)
        E1 = EPSTAB(K2)
        E2 = RES
        E1ABS = CABS(E1)
        A1 = REAL(E0)
        A2 = AIMAG(E0)
        B1 = REAL(E1)
        B2 = AIMAG(E1)
        C1 = REAL(E2)
        C2 = AIMAG(E2)
        ERR2 = ABS(C1 - B1)
        ERR3 = ABS(B1 - A1)
        IF(ABS(A1-B1) .GT. EPMACH*AMAX1(ABS(A1),ABS(B1)) .OR.
     *     ABS(A2-B2) .GT. EPMACH*AMAX1(ABS(A2),ABS(B2))) GO TO 10
        IF(ABS(B1-C1) .GT. EPMACH*AMAX1(ABS(B1),ABS(C1)) .OR.
     *     ABS(B2-C2) .GT. EPMACH*AMAX1(ABS(B2),ABS(C2))) GO TO 10
C
C           IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE
C           ACCURACY, CONVERGENCE IS ASSUMED.
C           RESULT = E2
C           ABSERR = CABS(E1-E0)+CABS(E2-E1)
C
        RESULT = RES
        ABSERR = ERR2+ERR3
C***JUMP OUT OF DO-LOOP
        GO TO 100
   10   E3 = EPSTAB(K1)
        EPSTAB(K1) = E1
        D1 = REAL(E3)
        D2 = AIMAG(E3)
        ERR1 = ABS(B1 - D1)
C
C           IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT
C           A PART OF THE TABLE BY ADJUSTING THE VALUE OF N
C
        DELTA1 = E1 - E3
        DELTA2 = E2 - E1
        DELTA3 = E1 - E0
        IF(CABS(DELTA1) .LE. EPMACH*AMAX1(E1ABS,CABS(E3))) GO TO 20
        IF(CABS(DELTA2) .LE. EPMACH*AMAX1(E1ABS,CABS(E2))) GO TO 20
        IF(CABS(DELTA3) .LE. EPMACH*AMAX1(CABS(E0),E1ABS)) GO TO 20
        R = REAL(DELTA1)
        S = AIMAG(DELTA1)
        CALL CDIVID(1.D0,0.D0,R,S,U1,V1)
        R = REAL(DELTA2)
        S = AIMAG(DELTA2)
        CALL CDIVID(1.D0,0.D0,R,S,U2,V2)
        R = REAL(DELTA3)
        S = AIMAG(DELTA3)
        CALL CDIVID(1.D0,0.D0,R,S,U3,V3)
        SS1 = U1 + U2 - U3
        SS2 = V1 + V2 - V3
        SS = CMPLX(SNGL(SS1), SNGL(SS2))
        EPSINF = CABS(SS*E1)
C
C           TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND
C           EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE
C           OF N.
C
        IF(EPSINF.GT.1.0E-04) GO TO 30
   20   N = I+I-1
C***JUMP OUT OF DO-LOOP
        GO TO 50
C
C           COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST
C           THE VALUE OF RESULT.
C
   30   CALL CDIVID(1.D0,0.D0,SS1,SS2,W1,W2)
        RES1 = REAL(E1) + SNGL(W1)
        RES2 = AIMAG(E1) + SNGL(W2)
        RES = CMPLX(RES1,RES2)
        EPSTAB(K1) = RES
        K1 = K1-2
        ERROR = ERR2+ABS(C1-REAL(RES))+ERR3
        IF(ERROR.GT.ABSERR) GO TO 40
        ABSERR = ERROR
        RESULT = RES
   40 CONTINUE
C
C           SHIFT THE TABLE.
C
   50 IF(N.EQ.LIMEXP) N = 2*(LIMEXP/2)-1
      IB = 1
      IF((NUM/2)*2.EQ.NUM) IB = 2
      IE = NEWELM+1
      DO 60 I=1,IE
        IB2 = IB+2
        EPSTAB(IB) = EPSTAB(IB2)
        IB = IB2
   60 CONTINUE
      IF(NUM.EQ.N) GO TO 80
      INDX = NUM-N+1
      DO 70 I = 1,N
        EPSTAB(I)= EPSTAB(INDX)
        INDX = INDX+1
   70 CONTINUE
   80 IF(NRES.GE.4) GO TO 90
      RES3LA(NRES) = RESULT
      ABSERR = OFLOW
      GO TO 100
C
C           COMPUTE ERROR ESTIMATE
C
   90 ABSERR = ABS(REAL(RESULT-RES3LA(3)))+ABS(REAL(RESULT-RES3LA(2)))
     *  +ABS(REAL(RESULT-RES3LA(1)))
      RES3LA(1) = RES3LA(2)
      RES3LA(2) = RES3LA(3)
      RES3LA(3) = RESULT
  100 ABSERR = AMAX1(ABSERR,5.0E+00*EPMACH*ABS(REAL(RESULT)))
      RETURN
      END
      SUBROUTINE QAGI1(F,PHI,Y,C,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,
     *                 NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK)
C-----------------------------------------------------------------------
C
C                   INTEGRATION OVER INFINITE INTERVALS
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           INTEGRAL    I = INTEGRAL OF  F  OVER (BOUND,+INFINITY)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,BOUND)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,+INFINITY),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). F HAS THE
C           ARGUMENTS X AND PHI WHERE PHI IS A FUNCTION.
C
C        PARAMETERS
C         ON ENTRY
C            F      - REAL
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C                     F HAS THE ARGUMENTS X AND PHI.
C
C            PHI    - REAL
C                     FUNCTION SUBPROGRAM HAVING A SINGLE REAL ARGUMENT.
C                     THE ACTUAL NAME FOR PHI MUST BE DECLARED EXTERNAL
C                     IN THE DRIVER PROGRAM.
C
C            BOUND  - REAL
C                     FINITE BOUND OF INTEGRATION RANGE
C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
C
C            Y      - REAL
C                     PARAMETER FOR USE IN XCOND.  ORDINATE OF
C                     HORIZONTAL LINE ALONG WHICH INTEGRATION
C                     IS PERFORMED.
C
C            C       - REAL
C                      PARAMETER FOR USE IN ACOND AND XCOND.
C
C            INF    - INTEGER
C                     INDICATING THE KIND OF INTEGRATION RANGE
C                     INVOLVED
C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
C                     INF = -1            TO  (-INFINITY,BOUND),
C                     INF = 2             TO (-INFINITY,+INFINITY).
C
C            EPSABS - REAL
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - REAL
C                     RELATIVE ACCURACY REQUESTED
C
C         ON RETURN
C            RESULT - REAL
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - REAL
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                   - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS NOT BEEN ACHIEVED.
C
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE
C                             OF LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A LOCAL
C                             DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE
C                             SUBRANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE, LIMIT .LT. 1,
C                             OR LENW .LT. 4 * LIMIT.
C                             RESULT, ABSERR, NEVAL, LAST ARE
C                             SET TO ZERO.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LIMIT DETERMINES THE MAXIMUM NUMBER
C                    OF SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                    INTEGRATION INTERVAL (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH
C                    IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*4.
C                    IF LENW.LT.LIMIT*4, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF
C                    SUBINTERVALS PRODUCED IN THE SUBDIVISION
C                    PROCESS, WHICH DETERMINES THE NUMBER OF SIGNIFICANT
C                    ELEMENTS ACTUALLY IN THE WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                    K ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS,
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                    K = LIMIT+1-LAST OTHERWISE
C
C            WORK  - REAL
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST)
C                     CONTAIN THE INTEGRAL APPROXIMATIONS OVER
C                     THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE ERROR ESTIMATES.
C
C        SUBROUTINES OR FUNCTIONS NEEDED
C              - QAGIE1
C              - QK15I1
C              - QPSRT
C              - QELG
C              - F (USER PROVIDED FUNCTION)
C              - PHI (USER PROVIDED FUNCTION)
C              - SPMPAR
C
C-----------------------------------------------------------------------
      REAL WORK(LENW)
      INTEGER IWORK(LIMIT)
      EXTERNAL F, PHI
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0
      ABSERR = 0.0
      IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN
C
C         PREPARE CALL FOR QAGIE1.
C
      L1 = LIMIT + 1
      L2 = LIMIT + L1
      L3 = LIMIT + L2
C
      CALL QAGIE1(F,PHI,Y,C,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *          NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
      RETURN
      END
      SUBROUTINE QAGIE1(F,PHI,Y,C,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,
     *              ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
C-----------------------------------------------------------------------
C
C                   INTEGRATION OVER INFINITE INTERVALS
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           INTEGRAL    I = INTEGRAL OF  F  OVER (BOUND,+INFINITY)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,BOUND)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,+INFINITY),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - REAL
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C                     F HAS THE ARGUMENTS X AND PHI.
C
C            PHI    - REAL
C                     FUNCTION SUBPROGRAM HAVING A SINGLE REAL ARGUMENT.
C                     THE ACTUAL NAME FOR PHI MUST BE DECLARED EXTERNAL
C                     IN THE DRIVER PROGRAM.
C
C            BOUND  - REAL
C                     FINITE BOUND OF INTEGRATION RANGE
C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
C
C            Y      - REAL
C                     PARAMETER FOR USE IN XCOND.  ORDINATE OF
C                     HORIZONTAL LINE ALONG WHICH INTEGRATION
C                     IS PERFORMED.
C
C            C      - REAL
C                     PARAMETER FOR USE IN ACOND AND XCOND.
C
C            INF    - INTEGER
C                     INDICATING THE KIND OF INTEGRATION RANGE
C                     INVOLVED
C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
C                     INF = -1            TO  (-INFINITY,BOUND),
C                     INF = 2             TO (-INFINITY,+INFINITY).
C
C            EPSABS - REAL
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - REAL
C                     RELATIVE ACCURACY REQUESTED
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPER BOUND ON THE NUMBER OF
C                     SUBINTERVALS IN THE PARTITION OF (A,B),
C                     LIMIT.GE.1
C
C         ON RETURN
C            RESULT - REAL
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - REAL
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                   - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS NOT BEEN ACHIEVED.
C
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE
C                             OF LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A LOCAL
C                             DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE
C                             SUBRANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE.
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
C                             ELIST(1) AND IORD(1) ARE SET TO ZERO.
C                             ALIST(1) AND BLIST(1) ARE SET TO 0
C                             AND 1 RESPECTIVELY.
C
C            ALIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
C
C            BLIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
C
C            RLIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT,  THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI
C                     OF THE ABSOLUTE ERROR ESTIMATES ON THE
C                     SUBINTERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE
C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED
C                     IN THE SUBDIVISION PROCESS
C
C        SUBROUTINES OR FUNCTIONS NEEDED
C              - QK15I1
C              - QPSRT
C              - QELG
C              - F (USER-PROVIDED FUNCTION)
C              - PHI (USER-PROVIDED FUNCTION)
C              - SPMPAR
C
C-----------------------------------------------------------------------
      LOGICAL EXTRAP,NOEXT
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     *  RES3LA(3),RLIST(LIMIT),RLIST2(52)
C
      EXTERNAL F, PHI
C
C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
C            LIMEXP IN SUBROUTINE QELG.
C
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           RLIST2    - ARRAY OF DIMENSION AT LEAST (LIMEXP+2),
C                       CONTAINING THE PART OF THE EPSILON TABLE
C                       WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
C                       ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
C           NUMRL2    - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN
C                       APPROPRIATE APPROXIMATION TO THE COMPOUNDED
C                       INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN
C                       RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED
C                       BY ONE.
C           SMALL     - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP
C                       TO NOW, MULTIPLIED BY 1.5
C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E.
C                       BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE
C                       TRY TO DECREASE THE VALUE OF ERLARG.
C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION
C                       IS NO LONGER ALLOWED (TRUE-VALUE)
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
      EPMACH = SPMPAR(1)
      UFLOW = SPMPAR(2)
      OFLOW = SPMPAR(3)
C
C           TEST ON VALIDITY OF PARAMETERS
C           -----------------------------
C
      NEVAL = 0
      LAST = 0
      RESULT = 0.0
      ABSERR = 0.0
      ALIST(1) = 0.0
      BLIST(1) = 1.0
      RLIST(1) = 0.0
      ELIST(1) = 0.0
      IORD(1) = 0
      IER = 6
      IF (EPSABS .LT. 0.0 .OR. EPSREL .LT. 0.0) GO TO 999
      IER = 0
      RERR = AMAX1(EPSREL, 50.0*EPMACH, 0.5E-14)
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
C           DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1).
C           IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE
C           I1 = INTEGRAL OF F OVER (-INFINITY,0),
C           I2 = INTEGRAL OF F OVER (0,+INFINITY).
C
      BOUN = BOUND
      IF (INF .EQ. 2) BOUN = 0.0
      CALL QK15I1 (F, PHI, Y, C, BOUN, INF, 0.0, 1.0, RESULT, ABSERR,
     *             DEFABS, RESABS, EPMACH, UFLOW)
C
C           TEST ON ACCURACY
C
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      DRES = ABS(RESULT)
      ERRBND = AMAX1(EPSABS,RERR*DRES)
      IF (ABSERR .LE. 100.0*EPMACH*DEFABS .AND. ABSERR .GT. ERRBND)
     *          IER = 2
      IF (LIMIT .EQ. 1) IER = 1
      IF (IER .NE. 0 .OR. (ABSERR .LE. ERRBND .AND. ABSERR .NE. RESABS)
     *    .OR. ABSERR .EQ. 0.0) GO TO 130
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      CORREC = 0.0
      NRMAX = 1
      NRES = 0
      KTMIN = 0
      NUMRL2 = 2
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IERRO = 0
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF (DRES .GE. (1.0 - 50.0*EPMACH)*DEFABS) KSGN = 1
      T = 1.0 + 100.0*EPMACH
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST
C           ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5*(ALIST(MAXERR) + BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL QK15I1 (F, PHI, Y, C, BOUN, INF, A1, B1, AREA1, ERROR1,
     *               RESABS, DEFAB1, EPMACH, UFLOW)
        CALL QK15I1 (F, PHI, Y, C, BOUN, INF, A2, B2, AREA2, ERROR2,
     *               RESABS, DEFAB2, EPMACH, UFLOW)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1 + AREA2
        ERRO12 = ERROR1 + ERROR2
        ERRSUM = ERRSUM + ERRO12 - ERRMAX
        AREA = AREA + AREA12 - RLIST(MAXERR)
        IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15
        IF (ABS(RLIST(MAXERR) - AREA12) .GT. 0.1E-04*ABS(AREA12)
     *      .OR. ERRO12 .LT. 0.99*ERRMAX) GO TO 10
        IF (EXTRAP) IROFF2 = IROFF2 + 1
        IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1
   10   IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = AMAX1(EPSABS,RERR*ABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY
C           SET ERROR FLAG.
C
        IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2
        IF (IROFF2 .GE. 5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
C           SUBINTERVALS EQUALS LIMIT.
C
        IF (LAST .EQ. LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT SOME POINTS OF THE INTEGRATION RANGE.
C
        IF (AMAX1(ABS(A1),ABS(B2)) .LE.
     *      T*(ABS(A2) + 0.1E+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF (ERROR2 .GT. ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE
C           SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE
C           BISECTED NEXT).
C
   30   CALL QPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
        IF(ERRSUM.LE.ERRBND) GO TO 115
        IF(IER.NE.0) GO TO 100
        IF(LAST.EQ.2) GO TO 80
        IF(NOEXT) GO TO 90
        ERLARG = ERLARG-ERLAST
        IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12
        IF(EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
   40   IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS
C           OVER THE LARGER INTERVALS (ERLARG) AND PERFORM
C           EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
          IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
          NRMAX = NRMAX+1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2+1
        RLIST2(NUMRL2) = AREA
        CALL QELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES,
     *             EPMACH, OFLOW)
        KTMIN = KTMIN+1
        IF(KTMIN.GT.5.AND.ABSERR.LT.0.1E-02*ERRSUM) IER = 5
        IF(ABSEPS.GE.ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = AMAX1(EPSABS,RERR*ABS(RESEPS))
        IF(ABSERR.LE.ERTEST) GO TO 100
C
C            PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF(NUMRL2.EQ.1) NOEXT = .TRUE.
        IF(IER.EQ.5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5E+00
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = 0.375E+00
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF (ABSERR .EQ. OFLOW) GO TO 115
      IF (IER + IERRO .EQ. 0) GO TO 110
      IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC
      IF (IER .EQ. 0) IER = 3
      IF (RESULT .NE. 0.0 .AND. AREA .NE. 0.0) GO TO 105
      IF (ABSERR .GT. ERRSUM) GO TO 115
      IF (AREA .EQ. 0.0) GO TO 130
      GO TO 110
  105 IF (ABSERR/ABS(RESULT) .GT. ERRSUM/ABS(AREA)) GO TO 115
C
C           TEST ON DIVERGENCE
C
  110 IF (KSGN .EQ. -1 .AND. AMAX1(ABS(RESULT),ABS(AREA)) .LE.
     *    DEFABS*0.1E-01) GO TO 130
      IF (0.1E-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1E+03
     *    .OR. ERRSUM .GT. ABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.0
      DO 120 K = 1,LAST
        RESULT = RESULT + RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 NEVAL = 30*LAST - 15
      IF (INF .EQ. 2) NEVAL = 2*NEVAL
      IF (IER .GT. 2) IER = IER - 1
  999 RETURN
      END
      SUBROUTINE QK15I1 (F, PHI, Y, C, BOUN, INF, A, B, RESULT, ABSERR,
     *                   RESABS, RESASC, EPMACH, UFLOW)
C-----------------------------------------------------------------------
C
C 1.        PURPOSE
C              THE ORIGINAL (INFINITE) INTEGRATION RANGE IS MAPPED
C              ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1).
C              IT IS THE PURPOSE TO COMPUTE
C              I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B),
C              J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B).
C
C 2.        PARAMETERS
C            ON ENTRY
C              F      - REAL
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS
C                       TO BE DECLARED E X T E R N A L IN THE
C                       CALLING PROGRAM. F HAS THE ARGUMENTS X AND
C                       PHI.
C
C              PHI    - REAL
C                       FUNCTION SUBPROGRAM HAVING A SINGLE REAL
C                       ARGUMENT. THE ACTUAL NAME FOR PHI MUST BE
C                       DECHARED EXTERNAL IN THE DRIVER PROGRAM.
C
C              BOUN   - REAL
C                       FINITE BOUND OF ORIGINAL INTEGRATION
C                       RANGE (SET TO ZERO IF INF = +2)
C
C              INF    - INTEGER
C                       IF INF = -1, THE ORIGINAL INTERVAL IS
C                                   (-INFINITY,BOUND),
C                       IF INF = +1, THE ORIGINAL INTERVAL IS
C                                   (BOUND,+INFINITY),
C                       IF INF = +2, THE ORIGINAL INTERVAL IS
C                                   (-INFINITY,+INFINITY) AND
C                       THE INTEGRAL IS COMPUTED AS THE SUM OF TWO
C                       INTEGRALS, ONE OVER (-INFINITY,0)
C                       AND ONE OVER (0,+INFINITY).
C
C              A      - REAL
C                       LOWER LIMIT FOR INTEGRATION OVER SUBRANGE
C                       OF (0,1)
C
C              B      - REAL
C                       UPPER LIMIT FOR INTEGRATION OVER SUBRANGE
C                       OF (0,1)
C
C              EPMACH - REAL
C                       THE RELATIVE PRECISION OF THE FLOATING
C                       ARITHMETIC BEING USED.
C
C              UFLOW  - REAL
C                       THE SMALLEST POSITIVE MAGNITUDE.
C
C            ON RETURN
C              RESULT - REAL
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE 15-POINT
C                       KRONROD RULE(RESK) OBTAINED BY OPTIMAL
C                       ADDITION OF ABSCISSAE TO THE 7-POINT GAUSS
C                       RULE(RESG).
C
C              ABSERR - REAL
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C              RESABS - REAL
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - REAL
C                       APPROXIMATION TO THE INTEGRAL OF
C                       ABS((TRANSFORMED INTEGRAND)-I/(B-A))
C                       OVER (A,B)
C
C 3.        SUBROUTINES OR FUNCTIONS NEEDED
C                 - F (USER-PROVIDED FUNCTION)
C                 - PHI (USER-PROVIDED FUNCTION)
C
C-----------------------------------------------------------------------
      REAL FV1(7), FV2(7), XGK(8), WGK(8), WG(8)
C
      EXTERNAL F, PHI
C
C           THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL
C           (-1,1).  BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND
C           THEIR CORRESPONDING WEIGHTS ARE GIVEN.
C
C           XGK    - ABSCISSAE OF THE 15-POINT KRONROD RULE
C                    XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT
C                    GAUSS RULE
C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
C                    ADDED TO THE 7-POINT GAUSS RULE
C
C           WGK    - WEIGHTS OF THE 15-POINT KRONROD RULE
C
C           WG     - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING
C                    TO THE ABSCISSAE XGK(2), XGK(4), ...
C                    WG(1), WG(3), ... ARE SET TO ZERO.
C
      DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),
     *  XGK(8)/
     *     0.9914553711208126E+00,     0.9491079123427585E+00,
     *     0.8648644233597691E+00,     0.7415311855993944E+00,
     *     0.5860872354676911E+00,     0.4058451513773972E+00,
     *     0.2077849550078985E+00,     0.0000000000000000E+00/
C
      DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),
     *  WGK(8)/
     *     0.2293532201052922E-01,     0.6309209262997855E-01,
     *     0.1047900103222502E+00,     0.1406532597155259E+00,
     *     0.1690047266392679E+00,     0.1903505780647854E+00,
     *     0.2044329400752989E+00,     0.2094821410847278E+00/
C
      DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/
     *     0.0000000000000000E+00,     0.1294849661688697E+00,
     *     0.0000000000000000E+00,     0.2797053914892767E+00,
     *     0.0000000000000000E+00,     0.3818300505051189E+00,
     *     0.0000000000000000E+00,     0.4179591836734694E+00/
C
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTERVAL
C           ABSC*  - ABSCISSA
C           TABSC* - TRANSFORMED ABSCISSA
C           FVAL*  - FUNCTION VALUE
C           RESG   - RESULT OF THE 7-POINT GAUSS FORMULA
C           RESK   - RESULT OF THE 15-POINT KRONROD FORMULA
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED
C                    INTEGRAND OVER (A,B), I.E. TO I/(B-A)
C
C
      DINF = MIN0(1,INF)
C
      CENTR = 0.5*(A + B)
      HLGTH = 0.5*(B - A)
      TABSC1 = BOUN + DINF*(1.0 - CENTR)/CENTR
      FVAL1 = F(TABSC1,Y,C,PHI)
      IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1,Y,C,PHI)
      FC = (FVAL1/CENTR)/CENTR
C
C           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO
C           THE INTEGRAL, AND ESTIMATE THE ERROR.
C
      RESG = WG(8)*FC
      RESK = WGK(8)*FC
      RESABS = ABS(RESK)
      DO 10 J = 1,7
        ABSC = HLGTH*XGK(J)
        ABSC1 = CENTR - ABSC
        ABSC2 = CENTR + ABSC
        TABSC1 = BOUN + DINF*(1.0 - ABSC1)/ABSC1
        TABSC2 = BOUN + DINF*(1.0 - ABSC2)/ABSC2
        FVAL1 = F(TABSC1,Y,C,PHI)
        FVAL2 = F(TABSC2,Y,C,PHI)
        IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1,Y,C,PHI)
        IF (INF .EQ. 2) FVAL2 = FVAL2 + F(-TABSC2,Y,C,PHI)
        FVAL1 = (FVAL1/ABSC1)/ABSC1
        FVAL2 = (FVAL2/ABSC2)/ABSC2
        FV1(J) = FVAL1
        FV2(J) = FVAL2
        FSUM = FVAL1 + FVAL2
        RESG = RESG + WG(J)*FSUM
        RESK = RESK + WGK(J)*FSUM
        RESABS = RESABS + WGK(J)*(ABS(FVAL1) + ABS(FVAL2))
   10 CONTINUE
      RESKH = RESK*0.5
      RESASC = WGK(8)*ABS(FC - RESKH)
      DO 20 J = 1,7
        RESASC = RESASC + WGK(J)*(ABS(FV1(J)-RESKH) +
     *                            ABS(FV2(J)-RESKH))
   20 CONTINUE
      RESULT = RESK*HLGTH
      RESASC = RESASC*HLGTH
      RESABS = RESABS*HLGTH
      ABSERR = ABS((RESK - RESG)*HLGTH)
      IF (RESASC .NE. 0.0 .AND. ABSERR .NE. 0.0) ABSERR = RESASC*
     *    AMIN1(1.0, (0.2E+03*ABSERR/RESASC)**1.5)
      TOL = 50.0*EPMACH
      IF (RESABS .GT. UFLOW/TOL) ABSERR = AMAX1(ABSERR, TOL*RESABS)
      RETURN
      END
      SUBROUTINE FFT (C,N,ISN,IERR)
      REAL C(*)
C-----------------------------------------------------------------------
C     THE COMPLEX ARRAY C OF DIMENSION N IS INTERPRETED BY THE CODE
C     AS A REAL ARRAY OF DIMENSION 2*N. IF THIS ASSOCIATION IS NOT
C     PERMITTED BY THE FORTRAN BEING USED, THEN THE USER MAY USE THE
C     SUBROUTINE FFT1.
C-----------------------------------------------------------------------
      IF (IABS(ISN) .NE. 1) GO TO 10
      CALL SFFT (C(1),C(2),N,N,N,ISN+ISN,IERR)
      RETURN
   10 IERR = 4
      RETURN
      END
      SUBROUTINE FFT1 (A,B,N,ISN,IERR)
      REAL A(N), B(N)
C     ------------
      IF (IABS(ISN) .NE. 1) GO TO 10
      CALL SFFT (A,B,N,N,N,ISN,IERR)
      RETURN
   10 IERR = 4
      RETURN
      END
      SUBROUTINE MFFT (C,N,NDIM,ISN,IERR)
      REAL C(*)
      INTEGER N(NDIM)
C-----------------------------------------------------------------------
C     LET NTOT DENOTE THE PRODUCT OF N(1),...,N(NDIM). THE COMPLEX
C     ARRAY C OF DIMENSION NTOT IS INTERPRETED BY THE ROUTINE AS
C     A REAL ARRAY OF DIMENSION 2*NTOT. IF THIS ASSOCIATION IS NOT
C     PERMITTED BY THE FORTRAN BEING USED, THEN THE USER MAY USE
C     THE SUBROUTINE MFFT1.
C-----------------------------------------------------------------------
      IF (IABS(ISN) .NE. 1) GO TO 40
      IF (NDIM .LE. 0) GO TO 50
      NTOT = 1
      DO 10 I = 1,NDIM
         NTOT = N(I)*NTOT
   10 CONTINUE
      IF (NTOT .LT. 1) GO TO 30
C
      ISIGN = ISN + ISN
      NSPAN = 1
      DO 20 I = 1,NDIM
         NSPAN = N(I)*NSPAN
         CALL SFFT (C(1),C(2),NTOT,N(I),NSPAN,ISIGN,IERR)
         IF (IERR .NE. 0) RETURN
   20 CONTINUE
      RETURN
C
   30 IERR = 1
      RETURN
   40 IERR = 4
      RETURN
   50 IERR = 5
      RETURN
      END
      SUBROUTINE MFFT1 (A,B,N,NDIM,ISN,IERR)
      REAL A(*), B(*)
      INTEGER N(NDIM)
C     ------------
      IF (IABS(ISN) .NE. 1) GO TO 40
      IF (NDIM .LE. 0) GO TO 50
      NTOT = 1
      DO 10 I = 1,NDIM
         NTOT = N(I)*NTOT
   10 CONTINUE
      IF (NTOT .LT. 1) GO TO 30
C
      NSPAN = 1
      DO 20 I = 1,NDIM
         NSPAN = N(I)*NSPAN
         CALL SFFT (A,B,NTOT,N(I),NSPAN,ISN,IERR)
         IF (IERR .NE. 0) RETURN
   20 CONTINUE
      RETURN
C
   30 IERR = 1
      RETURN
   40 IERR = 4
      RETURN
   50 IERR = 5
      RETURN
      END
      SUBROUTINE SFFT(A,B,NTOT,N,NSPAN,ISN,IERR)
C  MULTIVARIATE COMPLEX FOURIER TRANSFORM, COMPUTED IN PLACE
C    USING MIXED-RADIX FAST FOURIER TRANSFORM ALGORITHM.
C  BY R. C. SINGLETON, STANFORD RESEARCH INSTITUTE, OCT. 1968
C    MODIFIED BY A. H. MORRIS, NSWC/DL, DAHLGREN VA
C  ARRAYS A AND B ORIGINALLY HOLD THE REAL AND IMAGINARY
C    COMPONENTS OF THE DATA, AND RETURN THE REAL AND
C    IMAGINARY COMPONENTS OF THE RESULTING FOURIER COEFFICIENTS.
C  MULTIVARIATE DATA IS INDEXED ACCORDING TO THE FORTRAN
C    ARRAY ELEMENT SUCCESSOR FUNCTION, WITHOUT LIMIT
C    ON THE NUMBER OF IMPLIED MULTIPLE SUBSCRIPTS.
C    THE SUBROUTINE IS CALLED ONCE FOR EACH VARIATE.
C    THE CALLS FOR A MULTIVARIATE TRANSFORM MAY BE IN ANY ORDER.
C  NTOT IS THE TOTAL NUMBER OF COMPLEX DATA VALUES.
C  N IS THE DIMENSION OF THE CURRENT VARIABLE.
C  NSPAN/N IS THE SPACING OF CONSECUTIVE DATA VALUES
C    WHILE INDEXING THE CURRENT VARIABLE.
C  THE SIGN OF ISN DETERMINES THE SIGN OF THE COMPLEX
C    EXPONENTIAL, AND THE MAGNITUDE OF ISN IS NORMALLY ONE.
C  A TRI-VARIATE TRANSFORM WITH A(N1,N2,N3), B(N1,N2,N3)
C    IS COMPUTED BY
C      CALL SFFT(A,B,N1*N2*N3,N1,N1,1,IERR)
C      CALL SFFT(A,B,N1*N2*N3,N2,N1*N2,1,IERR)
C      CALL SFFT(A,B,N1*N2*N3,N3,N1*N2*N3,1,IERR)
C  FOR A SINGLE-VARIATE TRANSFORM,
C    NTOT = N = NSPAN = (NUMBER OF COMPLEX DATA VALUES), E.G.
C      CALL SFFT(A,B,N,N,N,1,IERR)
C  THE DATA MAY ALTERNATIVELY BE STORED IN A SINGLE COMPLEX
C    ARRAY A, THEN THE MAGNITUDE OF ISN CHANGED TO TWO TO
C    GIVE THE CORRECT INDEXING INCREMENT AND A(2) USED TO
C    PASS THE INITIAL ADDRESS FOR THE SEQUENCE OF IMAGINARY
C    VALUES, E.G.
C      CALL SFFT(A,A(2),NTOT,N,NSPAN,2,IERR)
C  ARRAYS NFAC(MAXN),NP(MAXP),AT(MAXF),CK(MAXF),BT(MAXF),SK(MAXF)
C    ARE USED FOR TEMPORARY STORAGE.
C    MAXN MUST BE .GE. THE NUMBER OF FACTORS OF N
C    MAXF MUST BE .GE. THE MAXIMUM PRIME FACTOR OF N.
C    MAXP MUST BE .GT. THE NUMBER OF PRIME FACTORS OF N.
C    IN ADDITION, MAXN IS ASSUMED TO BE ODD.
C    IF THE SQUARE-FREE PORTION K OF N HAS TWO OR MORE PRIME
C    FACTORS, THEN MAXP MUST BE .GE. K-1.
C  IERR IS A VARIABLE. IERR IS SET TO 0 IF NO INPUT ERRORS ARE
C    DETECTED. OTHERWISE, IERR IS ASSIGNED ONE OF THE VALUES
C      IERR=1    N IS LESS THAN 1
C      IERR=2    N HAS MORE THAN MAXN FACTORS
C      IERR=3    N HAS A PRIME FACTOR GREATER THAN
C                MAXF OR THE SQUARE-FREE PORTION OF
C                N IS GREATER THAN MAXP+1
      DIMENSION A(*),B(*)
C  ARRAY STORAGE IN NFAC FOR A MAXIMUM OF 15 FACTORS OF N.
C  IF N HAS MORE THAN ONE SQUARE-FREE FACTOR, THE PRODUCT OF THE
C    SQUARE-FREE FACTORS MUST BE .LE. 210
      DIMENSION NFAC(15),NP(209)
C  ARRAY STORAGE FOR MAXIMUM PRIME FACTOR OF 23
      DIMENSION AT(23),CK(23),BT(23),SK(23)
      EQUIVALENCE (I,II)
C  THE FOLLOWING CONSTANTS SHOULD AGREE WITH THE ARRAY DIMENSIONS.
      MAXN=15
      MAXF=23
      MAXP=209
C  SET THE FOLLOWING CONSTANTS
C     RAD=2.0*PI
C     S72=SIN(RAD/5.0)
C     C72=COS(RAD/5.0)
C     S120=SQRT(0.75)
      RAD=6.2831853071796
      S72=.951056516295154
      C72=.309016994374947
      S120=.86602540378444
C
      IERR=0
      IF(N-1) 1000,960,5
    5 INC=ISN
      IF(ISN .GE. 0) GO TO 10
      S72=-S72
      S120=-S120
      RAD=-RAD
      INC=-INC
   10 NT=INC*NTOT
      KS=INC*NSPAN
      KSPAN=KS
      NN=NT-INC
      JC=KS/N
      RADF=RAD*FLOAT(JC)*0.5
      I=0
      JF=0
C  DETERMINE THE FACTORS OF N
      M=0
      K=N
      MAX=MAXN/2
      GO TO 20
   15 IF(M .EQ. MAX) GO TO 1001
      M=M+1
      NFAC(M)=4
      K=L
   20 L=K/16
      IF(K .EQ. L*16) GO TO 15
      J=3
      JJ=9
      GO TO 30
   25 IF(M .EQ. MAX) GO TO 1001
      M=M+1
      NFAC(M)=J
      K=K/JJ
   30 IF(MOD(K,JJ) .EQ. 0) GO TO 25
      J=J+2
      JJ=J**2
      IF(J .LE. MAXF .AND. JJ .LE. K) GO TO 30
      IF(K .GT. 4) GO TO 40
      KT=M
      NFAC(M+1)=K
      IF(K .NE. 1) M=M+1
      GO TO 80
   40 L=K/4
      IF(K .NE. L*4) GO TO 50
      IF(M .EQ. MAX) GO TO 1001
      M=M+1
      NFAC(M)=2
      K=L
      KT=M
      IF(K .EQ. 1) GO TO 85
   50 KT=M
      IF(K-1 .GT. MAXP) GO TO 1002
      NUM=MAXN-KT-KT
      J=2
   60 IF(MOD(K,J) .NE. 0) GO TO 70
      M=M+1
      NFAC(M)=J
      NUM=NUM-1
      K=K/J
      IF(K .EQ. 1) GO TO 80
      IF(NUM .LE. 0) GO TO 1001
   70 L=(J+1)/2
      J=L+L+1
      IF(J .LE. MAXF) GO TO 60
      GO TO 1002
   80 IF(KT .EQ. 0) GO TO 100
   85 J=KT
   90 M=M+1
      NFAC(M)=NFAC(J)
      J=J-1
      IF(J .NE. 0) GO TO 90
C  COMPUTE FOURIER TRANSFORM
  100 SD=RADF/FLOAT(KSPAN)
      CD=2.0*SIN(SD)**2
      SD=SIN(SD+SD)
      KK=1
      I=I+1
      IF(NFAC(I) .NE. 2) GO TO 400
C  TRANSFORM FOR FACTOR OF 2 (INCLUDING ROTATION FACTOR)
      KSPAN=KSPAN/2
      K1=KSPAN+2
  210 K2=KK+KSPAN
      AK=A(K2)
      BK=B(K2)
      A(K2)=A(KK)-AK
      B(K2)=B(KK)-BK
      A(KK)=A(KK)+AK
      B(KK)=B(KK)+BK
      KK=K2+KSPAN
      IF(KK .LE. NN) GO TO 210
      KK=KK-NN
      IF(KK .LE. JC) GO TO 210
      IF(KK .GT. KSPAN) GO TO 800
  220 C1=1.0-CD
      S1=SD
  230 K2=KK+KSPAN
      AK=A(KK)-A(K2)
      BK=B(KK)-B(K2)
      A(KK)=A(KK)+A(K2)
      B(KK)=B(KK)+B(K2)
      A(K2)=C1*AK-S1*BK
      B(K2)=S1*AK+C1*BK
      KK=K2+KSPAN
      IF(KK .LT. NT) GO TO 230
      K2=KK-NT
      C1=-C1
      KK=K1-K2
      IF(KK .GT. K2) GO TO 230
      U=SD*S1+CD*C1
      V=SD*C1-CD*S1
      AK=C1-U
      S1=S1+V
C  THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION ERROR.
C    IF ROUNDED ARITHMETIC IS USED THEN ONE MAY SUBSTITUTE
C     C1=AK
      C1=1.5-0.5*(AK*AK+S1*S1)
      S1=C1*S1
      C1=C1*AK
      KK=KK+JC
      IF(KK .LT. K2) GO TO 230
      K1=K1+INC+INC
      KK=(K1-KSPAN)/2+JC
      IF(KK .LE. JC+JC) GO TO 220
      GO TO 100
C  TRANSFORM FOR FACTOR OF 3 (OPTIONAL CODE)
  320 K1=KK+KSPAN
      K2=K1+KSPAN
      AK=A(KK)
      BK=B(KK)
      AJ=A(K1)+A(K2)
      BJ=B(K1)+B(K2)
      A(KK)=AK+AJ
      B(KK)=BK+BJ
      AK=-0.5*AJ+AK
      BK=-0.5*BJ+BK
      AJ=(A(K1)-A(K2))*S120
      BJ=(B(K1)-B(K2))*S120
      A(K1)=AK-BJ
      B(K1)=BK+AJ
      A(K2)=AK+BJ
      B(K2)=BK-AJ
      KK=K2+KSPAN
      IF(KK .LT. NN) GO TO 320
      KK=KK-NN
      IF(KK .LE. KSPAN) GO TO 320
      GO TO 700
C  TRANSFORM FOR FACTOR OF 4
  400 IF(NFAC(I) .NE. 4) GO TO 600
      KSPNN=KSPAN
      KSPAN=KSPAN/4
  410 C1=1.0
      S1=0.0
  420 K1=KK+KSPAN
      K2=K1+KSPAN
      K3=K2+KSPAN
      AKP=A(KK)+A(K2)
      AKM=A(KK)-A(K2)
      AJP=A(K1)+A(K3)
      AJM=A(K1)-A(K3)
      A(KK)=AKP+AJP
      AJP=AKP-AJP
      BKP=B(KK)+B(K2)
      BKM=B(KK)-B(K2)
      BJP=B(K1)+B(K3)
      BJM=B(K1)-B(K3)
      B(KK)=BKP+BJP
      BJP=BKP-BJP
      IF(ISN .LT. 0) GO TO 450
      AKP=AKM-BJM
      AKM=AKM+BJM
      BKP=BKM+AJM
      BKM=BKM-AJM
      IF(S1 .EQ. 0.0) GO TO 460
  430 A(K1)=AKP*C1-BKP*S1
      B(K1)=AKP*S1+BKP*C1
      A(K2)=AJP*C2-BJP*S2
      B(K2)=AJP*S2+BJP*C2
      A(K3)=AKM*C3-BKM*S3
      B(K3)=AKM*S3+BKM*C3
      KK=K3+KSPAN
      IF(KK .LE. NT) GO TO 420
  440 U=SD*S1+CD*C1
      V=SD*C1-CD*S1
      C2=C1-U
      S1=S1+V
C  THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION ERROR.
C    IF ROUNDED ARITHMETIC IS USED THEN ONE MAY SUBSTITUTE
C     C1=C2
      C1=1.5-0.5*(C2*C2+S1*S1)
      S1=C1*S1
      C1=C1*C2
      C2=C1*C1-S1*S1
      S2=2.0*C1*S1
      C3=C2*C1-S2*S1
      S3=C2*S1+S2*C1
      KK=KK-NT+JC
      IF(KK .LE. KSPAN) GO TO 420
      KK=KK-KSPAN+INC
      IF(KK .LE. JC) GO TO 410
      IF(KSPAN .EQ. JC) GO TO 800
      GO TO 100
  450 AKP=AKM+BJM
      AKM=AKM-BJM
      BKP=BKM-AJM
      BKM=BKM+AJM
      IF(S1 .NE. 0.0) GO TO 430
  460 A(K1)=AKP
      B(K1)=BKP
      A(K2)=AJP
      B(K2)=BJP
      A(K3)=AKM
      B(K3)=BKM
      KK=K3+KSPAN
      IF(KK .LE. NT) GO TO 420
      GO TO 440
C  TRANSFORM FOR FACTOR OF 5 (OPTIONAL CODE)
  510 C2=C72**2-S72**2
      S2=2.0*C72*S72
  520 K1=KK+KSPAN
      K2=K1+KSPAN
      K3=K2+KSPAN
      K4=K3+KSPAN
      AKP=A(K1)+A(K4)
      AKM=A(K1)-A(K4)
      BKP=B(K1)+B(K4)
      BKM=B(K1)-B(K4)
      AJP=A(K2)+A(K3)
      AJM=A(K2)-A(K3)
      BJP=B(K2)+B(K3)
      BJM=B(K2)-B(K3)
      AA=A(KK)
      BB=B(KK)
      A(KK)=AA+AKP+AJP
      B(KK)=BB+BKP+BJP
      AK=AKP*C72+AJP*C2+AA
      BK=BKP*C72+BJP*C2+BB
      AJ=AKM*S72+AJM*S2
      BJ=BKM*S72+BJM*S2
      A(K1)=AK-BJ
      A(K4)=AK+BJ
      B(K1)=BK+AJ
      B(K4)=BK-AJ
      AK=AKP*C2+AJP*C72+AA
      BK=BKP*C2+BJP*C72+BB
      AJ=AKM*S2-AJM*S72
      BJ=BKM*S2-BJM*S72
      A(K2)=AK-BJ
      A(K3)=AK+BJ
      B(K2)=BK+AJ
      B(K3)=BK-AJ
      KK=K4+KSPAN
      IF(KK .LT. NN) GO TO 520
      KK=KK-NN
      IF(KK .LE. KSPAN) GO TO 520
      GO TO 700
C  TRANSFORM FOR ODD FACTORS
  600 K=NFAC(I)
      KSPNN=KSPAN
      KSPAN=KSPAN/K
      IF(K .EQ. 3) GO TO 320
      IF(K .EQ. 5) GO TO 510
      IF(K .EQ. JF) GO TO 640
      JF=K
      S1=RAD/FLOAT(K)
      C1=COS(S1)
      S1=SIN(S1)
      CK(JF)=1.0
      SK(JF)=0.0
      J=1
  630 CK(J)=CK(K)*C1+SK(K)*S1
      SK(J)=CK(K)*S1-SK(K)*C1
      K=K-1
      CK(K)=CK(J)
      SK(K)=-SK(J)
      J=J+1
      IF(J .LT. K) GO TO 630
  640 K1=KK
      K2=KK+KSPNN
      AA=A(KK)
      BB=B(KK)
      AK=AA
      BK=BB
      J=1
      K1=K1+KSPAN
  650 K2=K2-KSPAN
      J=J+1
      AT(J)=A(K1)+A(K2)
      AK=AT(J)+AK
      BT(J)=B(K1)+B(K2)
      BK=BT(J)+BK
      J=J+1
      AT(J)=A(K1)-A(K2)
      BT(J)=B(K1)-B(K2)
      K1=K1+KSPAN
      IF(K1 .LT. K2) GO TO 650
      A(KK)=AK
      B(KK)=BK
      K1=KK
      K2=KK+KSPNN
      J=1
  660 K1=K1+KSPAN
      K2=K2-KSPAN
      JJ=J
      AK=AA
      BK=BB
      AJ=0.0
      BJ=0.0
      K=1
  670 K=K+1
      AK=AT(K)*CK(JJ)+AK
      BK=BT(K)*CK(JJ)+BK
      K=K+1
      AJ=AT(K)*SK(JJ)+AJ
      BJ=BT(K)*SK(JJ)+BJ
      JJ=JJ+J
      IF(JJ .GT. JF) JJ=JJ-JF
      IF(K .LT. JF) GO TO 670
      K=JF-J
      A(K1)=AK-BJ
      B(K1)=BK+AJ
      A(K2)=AK+BJ
      B(K2)=BK-AJ
      J=J+1
      IF(J .LT. K) GO TO 660
      KK=KK+KSPNN
      IF(KK .LE. NN) GO TO 640
      KK=KK-NN
      IF(KK .LE. KSPAN) GO TO 640
C  MULTIPLY BY ROTATION FACTOR (EXCEPT FOR FACTORS OF 2 AND 4)
  700 IF(I .EQ. M) GO TO 800
      KK=JC+1
  710 C2=1.0-CD
      S1=SD
  720 C1=C2
      S2=S1
      KK=KK+KSPAN
  730 AK=A(KK)
      A(KK)=C2*AK-S2*B(KK)
      B(KK)=S2*AK+C2*B(KK)
      KK=KK+KSPNN
      IF(KK .LE. NT) GO TO 730
      AK=S1*S2
      S2=S1*C2+C1*S2
      C2=C1*C2-AK
      KK=KK-NT+KSPAN
      IF(KK .LE. KSPNN) GO TO 730
      U=SD*S1+CD*C1
      V=SD*C1-CD*S1
      C2=C1-U
      S1=S1+V
C  THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION
C    ERROR.  IF ROUNDED ARITHMETIC IS USED THEN THEY MAY
C    BE DELETED.
      C1=1.5-0.5*(C2*C2+S1*S1)
      S1=C1*S1
      C2=C1*C2
      KK=KK-KSPNN+JC
      IF(KK .LE. KSPAN) GO TO 720
      KK=KK-KSPAN+JC+INC
      IF(KK .LE. JC+JC) GO TO 710
      GO TO 100
C  PERMUTE THE RESULTS TO NORMAL ORDER---DONE IN TWO STAGES
C  PERMUTATION FOR SQUARE FACTORS OF N
  800 NP(1)=KS
      IF(KT .EQ. 0) GO TO 890
      K=KT+KT+1
      IF(M .LT. K) K=K-1
      J=1
      NP(K+1)=JC
  810 NP(J+1)=NP(J)/NFAC(J)
      NP(K)=NP(K+1)*NFAC(J)
      J=J+1
      K=K-1
      IF(J .LT. K) GO TO 810
      K3=NP(K+1)
      KSPAN=NP(2)
      KK=JC+1
      K2=KSPAN+1
      J=1
      IF(N .NE. NTOT) GO TO 850
C  PERMUTATION FOR SINGLE-VARIATE TRANSFORM (OPTIONAL CODE)
  820 AK=A(KK)
      A(KK)=A(K2)
      A(K2)=AK
      BK=B(KK)
      B(KK)=B(K2)
      B(K2)=BK
      KK=KK+INC
      K2=KSPAN+K2
      IF(K2 .LT. KS) GO TO 820
  830 K2=K2-NP(J)
      J=J+1
      K2=NP(J+1)+K2
      IF(K2 .GT. NP(J)) GO TO 830
      J=1
  840 IF(KK .LT. K2) GO TO 820
      KK=KK+INC
      K2=KSPAN+K2
      IF(K2 .LT. KS) GO TO 840
      IF(KK .LT. KS) GO TO 830
      JC=K3
      GO TO 890
C  PERMUTATION FOR MULTIVARIATE TRANSFORM
  850 K=KK+JC
  860 AK=A(KK)
      A(KK)=A(K2)
      A(K2)=AK
      BK=B(KK)
      B(KK)=B(K2)
      B(K2)=BK
      KK=KK+INC
      K2=K2+INC
      IF(KK .LT. K) GO TO 860
      KK=KK+KS-JC
      K2=K2+KS-JC
      IF(KK .LT. NT) GO TO 850
      K2=K2-NT+KSPAN
      KK=KK-NT+JC
      IF(K2 .LT. KS) GO TO 850
  870 K2=K2-NP(J)
      J=J+1
      K2=NP(J+1)+K2
      IF(K2 .GT. NP(J)) GO TO 870
      J=1
  880 IF(KK .LT. K2) GO TO 850
      KK=KK+JC
      K2=KSPAN+K2
      IF(K2 .LT. KS) GO TO 880
      IF(KK .LT. KS) GO TO 870
      JC=K3
  890 IF(2*KT+1 .GE. M) RETURN
      KSPNN=NP(KT+1)
C  PERMUTATION FOR SQUARE-FREE FACTORS OF N
      J=M-KT
      NFAC(J+1)=1
  900 NFAC(J)=NFAC(J)*NFAC(J+1)
      J=J-1
      IF(J .NE. KT) GO TO 900
      KT=KT+1
      NN=NFAC(KT)-1
      JJ=0
      J=0
      GO TO 906
  902 JJ=JJ-K2
      K2=KK
      K=K+1
      KK=NFAC(K)
  904 JJ=KK+JJ
      IF(JJ .GE. K2) GO TO 902
      NP(J)=JJ
  906 K2=NFAC(KT)
      K=KT+1
      KK=NFAC(K)
      J=J+1
      IF(J .LE. NN) GO TO 904
C  DETERMINE THE PERMUTATION CYCLES OF LENGTH GREATER THAN 1
      J=0
      GO TO 914
  910 K=KK
      KK=NP(K)
      NP(K)=-KK
      IF(KK .NE. J) GO TO 910
      K3=KK
  914 J=J+1
      KK=NP(J)
      IF(KK .LT. 0) GO TO 914
      IF(KK .NE. J) GO TO 910
      NP(J)=-J
      IF(J .NE. NN) GO TO 914
      MAXF=INC*MAXF
C  REORDER A AND B, FOLLOWING THE PERMUTATION CYCLES
      GO TO 950
  924 J=J-1
      IF(NP(J) .LT. 0) GO TO 924
      JJ=JC
  926 KSPAN=JJ
      IF(JJ .GT. MAXF) KSPAN=MAXF
      JJ=JJ-KSPAN
      K=NP(J)
      KK=JC*K+II+JJ
      K1=KK+KSPAN
      K2=0
  928 K2=K2+1
      AT(K2)=A(K1)
      BT(K2)=B(K1)
      K1=K1-INC
      IF(K1 .NE. KK) GO TO 928
  932 K1=KK+KSPAN
      K2=K1-JC*(K+NP(K))
      K=-NP(K)
  936 A(K1)=A(K2)
      B(K1)=B(K2)
      K1=K1-INC
      K2=K2-INC
      IF(K1 .NE. KK) GO TO 936
      KK=K2
      IF(K .NE. J) GO TO 932
      K1=KK+KSPAN
      K2=0
  940 K2=K2+1
      A(K1)=AT(K2)
      B(K1)=BT(K2)
      K1=K1-INC
      IF(K1 .NE. KK) GO TO 940
      IF(JJ .NE. 0) GO TO 926
      IF(J .NE. 1) GO TO 924
  950 J=K3+1
      NT=NT-KSPNN
      II=NT-INC+1
      IF(NT .GE. 0) GO TO 924
  960 RETURN
C  ERROR FINISH - THERE IS AN INPUT ERROR
 1000 IERR=1
      RETURN
 1001 IERR=2
      RETURN
 1002 IERR=3
      RETURN
      END
C     ******************************************************************
C
C     SUBROUTINE COSQI(N,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE COSQI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C     BOTH COSQF AND COSQB. 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 ARRAY TO BE TRANSFORMED.  THE METHOD
C             IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
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 COSQF AND COSQB
C             AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS
C             ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF
C             WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF COSQF OR COSQB.
C
      SUBROUTINE COSQI (N,WSAVE)
      DIMENSION       WSAVE(*)
      DATA PIH /1.57079632679491/
      DT = PIH/FLOAT(N)
      FK = 0.
      DO 101 K=1,N
         FK = FK+1.
         WSAVE(K) = COS(FK*DT)
  101 CONTINUE
      CALL RFFTI (N,WSAVE(N+1))
      RETURN
      END
C     ******************************************************************
C
C     SUBROUTINE COSQF(N,X,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE COSQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER
C     WAVE DATA. THAT IS , COSQF COMPUTES THE COEFFICIENTS IN A COSINE
C     SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS. THE TRANSFORM
C     IS DEFINED BELOW AT OUTPUT PARAMETER X
C
C     COSQF IS THE UNNORMALIZED INVERSE OF COSQB SINCE A CALL OF COSQF
C     FOLLOWED BY A CALL OF COSQB WILL MULTIPLY THE INPUT SEQUENCE X
C     BY 4*N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COSQF MUST BE
C     INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE).
C
C
C     INPUT PARAMETERS
C
C     N       THE LENGTH OF THE ARRAY X TO BE TRANSFORMED.  THE METHOD
C             IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C     X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15
C             IN THE PROGRAM THAT CALLS COSQF. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE COSQI(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
C     OUTPUT PARAMETERS
C
C     X       FOR I=1,...,N
C
C                  X(I) = X(1) PLUS THE SUM FROM K=2 TO K=N OF
C
C                     2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N))
C
C                  A CALL OF COSQF FOLLOWED BY A CALL OF
C                  COSQB WILL MULTIPLY THE SEQUENCE X BY 4*N.
C                  THEREFORE COSQB IS THE UNNORMALIZED INVERSE
C                  OF COSQF.
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT
C             BE DESTROYED BETWEEN CALLS OF COSQF OR COSQB.
C
      SUBROUTINE COSQF (N,X,WSAVE)
      DIMENSION X(*), WSAVE(*)
      DATA SQRT2 /1.4142135623731/
      IF (N-2) 102,101,103
  101 TSQX = SQRT2*X(2)
      X(2) = X(1)-TSQX
      X(1) = X(1)+TSQX
  102 RETURN
  103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1))
      RETURN
      END
      SUBROUTINE COSQF1 (N,X,W,XH)
      DIMENSION       X(*)       ,W(*)       ,XH(*)
      NS2 = (N+1)/2
      NP2 = N+2
      DO 101 K=2,NS2
         KC = NP2-K
         XH(K) = X(K)+X(KC)
         XH(KC) = X(K)-X(KC)
  101 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1)
      DO 102 K=2,NS2
         KC = NP2-K
         X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K)
         X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC)
  102 CONTINUE
      IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1)
      CALL RFFTF (N,X,XH)
      DO 103 I=3,N,2
         XIM1 = X(I-1)-X(I)
         X(I) = X(I-1)+X(I)
         X(I-1) = XIM1
  103 CONTINUE
      RETURN
      END
C     ******************************************************************
C
C     SUBROUTINE COSQB(N,X,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE COSQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER
C     WAVE DATA. THAT IS , COSQB COMPUTES A SEQUENCE FROM ITS
C     REPRESENTATION IN TERMS OF A COSINE SERIES WITH ODD WAVE NUMBERS.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X.
C
C     COSQB IS THE UNNORMALIZED INVERSE OF COSQF SINCE A CALL OF COSQB
C     FOLLOWED BY A CALL OF COSQF WILL MULTIPLY THE INPUT SEQUENCE X
C     BY 4*N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COSQB MUST BE
C     INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE).
C
C
C     INPUT PARAMETERS
C
C     N       THE LENGTH OF THE ARRAY X TO BE TRANSFORMED.  THE METHOD
C             IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C     X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C     WSAVE   A WORK ARRAY THAT MUST BE DIMENSIONED AT LEAST 3*N+15
C             IN THE PROGRAM THAT CALLS COSQB. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE COSQI(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
C     OUTPUT PARAMETERS
C
C     X       FOR I=1,...,N
C
C                  X(I)= THE SUM FROM K=1 TO K=N OF
C
C                    4*X(K)*COS((2*K-1)*(I-1)*PI/(2*N))
C
C                  A CALL OF COSQB FOLLOWED BY A CALL OF
C                  COSQF WILL MULTIPLY THE SEQUENCE X BY 4*N.
C                  THEREFORE COSQF IS THE UNNORMALIZED INVERSE
C                  OF COSQB.
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT
C             BE DESTROYED BETWEEN CALLS OF COSQB OR COSQF.
C
      SUBROUTINE COSQB (N,X,WSAVE)
      DIMENSION X(*), WSAVE(*)
      DATA TSQRT2 /2.82842712474619/
      IF (N-2) 101,102,103
  101 X(1) = 4.*X(1)
      RETURN
  102 X1 = 4.*(X(1)+X(2))
      X(2) = TSQRT2*(X(1)-X(2))
      X(1) = X1
      RETURN
  103 CALL COSQB1 (N,X,WSAVE,WSAVE(N+1))
      RETURN
      END
      SUBROUTINE COSQB1 (N,X,W,XH)
      DIMENSION       X(*)       ,W(*)       ,XH(*)
      NS2 = (N+1)/2
      NP2 = N+2
      DO 101 I=3,N,2
         XIM1 = X(I-1)+X(I)
         X(I) = X(I)-X(I-1)
         X(I-1) = XIM1
  101 CONTINUE
      X(1) = X(1)+X(1)
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) X(N) = X(N)+X(N)
      CALL RFFTB (N,X,XH)
      DO 102 K=2,NS2
         KC = NP2-K
         XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K)
         XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC)
  102 CONTINUE
      IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1))
      DO 103 K=2,NS2
         KC = NP2-K
         X(K) = XH(K)+XH(KC)
         X(KC) = XH(K)-XH(KC)
  103 CONTINUE
      X(1) = X(1)+X(1)
      RETURN
      END
C     ******************************************************************
C
C     SUBROUTINE SINQF(N,X,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE SINQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER
C     WAVE DATA. THAT IS , SINQF COMPUTES THE COEFFICIENTS IN A SINE
C     SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS. THE TRANSFORM
C     IS DEFINED BELOW AT OUTPUT PARAMETER X.
C
C     SINQB IS THE UNNORMALIZED INVERSE OF SINQF SINCE A CALL OF SINQF
C     FOLLOWED BY A CALL OF SINQB WILL MULTIPLY THE INPUT SEQUENCE X
C     BY 4*N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINQF MUST BE
C     INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE).
C
C
C     INPUT PARAMETERS
C
C     N       THE LENGTH OF THE ARRAY X TO BE TRANSFORMED.  THE METHOD
C             IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C     X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15.
C             IN THE PROGRAM THAT CALLS SINQF. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE SINQI(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
C     OUTPUT PARAMETERS
C
C     X       FOR I=1,...,N
C
C                  X(I) = (-1)**(I-1)*X(N)
C
C                     + THE SUM FROM K=1 TO K=N-1 OF
C
C                     2*X(K)*SIN((2*I-1)*K*PI/(2*N))
C
C                  A CALL OF SINQF FOLLOWED BY A CALL OF
C                  SINQB WILL MULTIPLY THE SEQUENCE X BY 4*N.
C                  THEREFORE SINQB IS THE UNNORMALIZED INVERSE
C                  OF SINQF.
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT
C             BE DESTROYED BETWEEN CALLS OF SINQF OR SINQB.
C
      SUBROUTINE SINQF (N,X,WSAVE)
      DIMENSION       X(*)       ,WSAVE(*)
      IF (N .EQ. 1) RETURN
      NS2 = N/2
      DO 101 K=1,NS2
         KC = N-K
         XHOLD = X(K)
         X(K) = X(KC+1)
         X(KC+1) = XHOLD
  101 CONTINUE
      CALL COSQF (N,X,WSAVE)
      DO 102 K=2,N,2
         X(K) = -X(K)
  102 CONTINUE
      RETURN
      END
C     ******************************************************************
C
C     SUBROUTINE SINQB(N,X,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE SINQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER
C     WAVE DATA. THAT IS , SINQB COMPUTES A SEQUENCE FROM ITS
C     REPRESENTATION IN TERMS OF A SINE SERIES WITH ODD WAVE NUMBERS.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X.
C
C     SINQF IS THE UNNORMALIZED INVERSE OF SINQB SINCE A CALL OF SINQB
C     FOLLOWED BY A CALL OF SINQF WILL MULTIPLY THE INPUT SEQUENCE X
C     BY 4*N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINQB MUST BE
C     INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE).
C
C
C     INPUT PARAMETERS
C
C     N       THE LENGTH OF THE ARRAY X TO BE TRANSFORMED.  THE METHOD
C             IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C     X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15.
C             IN THE PROGRAM THAT CALLS SINQB. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE SINQI(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
C     OUTPUT PARAMETERS
C
C     X       FOR I=1,...,N
C
C                  X(I)= THE SUM FROM K=1 TO K=N OF
C
C                    4*X(K)*SIN((2K-1)*I*PI/(2*N))
C
C                  A CALL OF SINQB FOLLOWED BY A CALL OF
C                  SINQF WILL MULTIPLY THE SEQUENCE X BY 4*N.
C                  THEREFORE SINQF IS THE UNNORMALIZED INVERSE
C                  OF SINQB.
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT
C             BE DESTROYED BETWEEN CALLS OF SINQB OR SINQF.
C
      SUBROUTINE SINQB (N,X,WSAVE)
      DIMENSION       X(*)       ,WSAVE(*)
      IF (N .GT. 1) GO TO 101
      X(1) = 4.*X(1)
      RETURN
  101 NS2 = N/2
      DO 102 K=2,N,2
         X(K) = -X(K)
  102 CONTINUE
      CALL COSQB (N,X,WSAVE)
      DO 103 K=1,NS2
         KC = N-K
         XHOLD = X(K)
         X(K) = X(KC+1)
         X(KC+1) = XHOLD
  103 CONTINUE
      RETURN
      END
C     ******************************************************************
C
C     SUBROUTINE RFFTI(N,WSAVE)
C
C       ****************************************************************
C
C     SUBROUTINE RFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C     BOTH RFFTF AND RFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH
C     A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C     STORED IN WSAVE.
C
C     INPUT 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 2*N+15.
C             THE SAME WORK ARRAY CAN BE USED FOR BOTH RFFTF AND RFFTB
C             AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS
C             ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF
C             WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF RFFTF OR RFFTB.
C
      SUBROUTINE RFFTI (N,WSAVE)
      DIMENSION       WSAVE(*)
      IF (N .EQ. 1) RETURN
      CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
      SUBROUTINE RFFTI1 (N,WA,IFAC)
      REAL WA(*), IFAC(*)
      INTEGER NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 6.28318530717959
      ARGH = TPI/FLOAT(N)
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 110 K1=1,NFM1
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         DO 109 J=1,IPM
            LD = LD+L1
            I = IS
            ARGLD = FLOAT(LD)*ARGH
            FI = 0.
            DO 108 II=3,IDO,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IS = IS+IDO
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END
C     ******************************************************************
C
C     SUBROUTINE RFFTB(N,R,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE RFFTB COMPUTES THE REAL PERODIC SEQUENCE FROM ITS
C     FOURIER COEFFICIENTS (FOURIER SYNTHESIS). THE TRANSFORM IS DEFINED
C     BELOW AT OUTPUT PARAMETER R.
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 A PRODUCT OF SMALL PRIMES.
C             N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED
C
C     R       A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C             TO BE TRANSFORMED
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15.
C             IN THE PROGRAM THAT CALLS RFFTB. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE RFFTI(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 RFFTF AND RFFTB.
C
C
C     OUTPUT PARAMETERS
C
C     R       FOR N EVEN AND FOR I = 1,...,N
C
C                  R(I) = R(1)+(-1)**(I-1)*R(N)
C
C                       PLUS THE SUM FROM K=2 TO K=N/2 OF
C
C                        2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                       -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C             FOR N ODD AND FOR I = 1,...,N
C
C                  R(I) = R(1) PLUS THE SUM FROM K=2 TO K=(N+1)/2 OF
C
C                       2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                      -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C      *****  NOTE
C                  THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF
C                  FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT
C                  SEQUENCE BY N.
C
C     WSAVE   CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN
C             CALLS OF RFFTB OR RFFTF.
C
C
      SUBROUTINE RFFTB (N,R,WSAVE)
      DIMENSION       R(*)       ,WSAVE(*)
      IF (N .EQ. 1) RETURN
      CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
      SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC)
      REAL C(*), CH(*), WA(*), IFAC(*)
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDL1 = IDO*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL RADB2 (IDO,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL RADB2 (IDO,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 110
         CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (IDO .EQ. 1) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDO
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      DO 117 I=1,N
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END
      SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1)
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,*)           ,
     1                WA1(*)
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 108
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
            TR2 = CC(I-1,1,K)-CC(IC-1,2,K)
            CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)
            TI2 = CC(I,1,K)+CC(IC,2,K)
            CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
            CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2
  103    CONTINUE
  104 CONTINUE
      GO TO 111
  108 DO 110 I=3,IDO,2
         IC = IDP2-I
         DO 109 K=1,L1
            CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
            TR2 = CC(I-1,1,K)-CC(IC-1,2,K)
            CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)
            TI2 = CC(I,1,K)+CC(IC,2,K)
            CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
            CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2
  109    CONTINUE
  110 CONTINUE
  111 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K)
         CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K))
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2)
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,*)           ,
     1                WA1(*)     ,WA2(*)
      DATA TAUR,TAUI /-.5,.866025403784439/
      DO 101 K=1,L1
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         CI3 = TAUI*(CC(1,3,K)+CC(1,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,3,K)-CC(IC,2,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
            CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
         DO 105 K=1,L1
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,3,K)-CC(IC,2,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
            CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
      SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3)
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,*)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)
      DATA SQRT2 /1.414213562373095/
      DO 101 K=1,L1
         TR1 = CC(1,1,K)-CC(IDO,4,K)
         TR2 = CC(1,1,K)+CC(IDO,4,K)
         TR3 = CC(IDO,2,K)+CC(IDO,2,K)
         TR4 = CC(1,3,K)+CC(1,3,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,2) = TR1-TR4
         CH(1,K,3) = TR2-TR3
         CH(1,K,4) = TR1+TR4
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 108
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            TI1 = CC(I,1,K)+CC(IC,4,K)
            TI2 = CC(I,1,K)-CC(IC,4,K)
            TI3 = CC(I,3,K)-CC(IC,2,K)
            TR4 = CC(I,3,K)+CC(IC,2,K)
            TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
            TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
            TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1-TR4
            CR4 = TR1+TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
            CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
            CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
            CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
            CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
            CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
  103    CONTINUE
  104 CONTINUE
      GO TO 111
  108 DO 110 I=3,IDO,2
         IC = IDP2-I
         DO 109 K=1,L1
            TI1 = CC(I,1,K)+CC(IC,4,K)
            TI2 = CC(I,1,K)-CC(IC,4,K)
            TI3 = CC(I,3,K)-CC(IC,2,K)
            TR4 = CC(I,3,K)+CC(IC,2,K)
            TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
            TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
            TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1-TR4
            CR4 = TR1+TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
            CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
            CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
            CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
            CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
            CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
  109    CONTINUE
  110 CONTINUE
  111 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         TI1 = CC(1,2,K)+CC(1,4,K)
         TI2 = CC(1,4,K)-CC(1,2,K)
         TR1 = CC(IDO,1,K)-CC(IDO,3,K)
         TR2 = CC(IDO,1,K)+CC(IDO,3,K)
         CH(IDO,K,1) = TR2+TR2
         CH(IDO,K,2) = SQRT2*(TR1-TI1)
         CH(IDO,K,3) = TI2+TI2
         CH(IDO,K,4) = -SQRT2*(TR1+TI1)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,*)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)
      DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
     1-.809016994374947,.587785252292473/
      DO 101 K=1,L1
         TI5 = CC(1,3,K)+CC(1,3,K)
         TI4 = CC(1,5,K)+CC(1,5,K)
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)
         TR3 = CC(IDO,4,K)+CC(IDO,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI5 = TI11*TI5+TI12*TI4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(1,K,5) = CR2+CI5
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            TI5 = CC(I,3,K)+CC(IC,2,K)
            TI2 = CC(I,3,K)-CC(IC,2,K)
            TI4 = CC(I,5,K)+CC(IC,4,K)
            TI3 = CC(I,5,K)-CC(IC,4,K)
            TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
            TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
            CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
            CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
            CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
            CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
         DO 105 K=1,L1
            TI5 = CC(I,3,K)+CC(IC,2,K)
            TI2 = CC(I,3,K)-CC(IC,2,K)
            TI4 = CC(I,5,K)+CC(IC,4,K)
            TI3 = CC(I,5,K)-CC(IC,4,K)
            TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
            TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
            CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
            CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
            CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
            CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
      SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),
     2                CH2(IDL1,IP)           ,WA(*)
      DATA TPI/6.28318530717959/
      ARG = TPI/FLOAT(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IF (IDO .LT. L1) GO TO 103
      DO 102 K=1,L1
         DO 101 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  101    CONTINUE
  102 CONTINUE
      GO TO 106
  103 DO 105 I=1,IDO
         DO 104 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
  106 DO 108 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 107 K=1,L1
            CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K)
            CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K)
  107    CONTINUE
  108 CONTINUE
      IF (IDO .EQ. 1) GO TO 116
      IF (NBD .LT. L1) GO TO 112
      DO 111 J=2,IPPH
         JC = IPP2-J
         DO 110 K=1,L1
            DO 109 I=3,IDO,2
               IC = IDP2-I
               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      GO TO 116
  112 DO 115 J=2,IPPH
         JC = IPP2-J
         DO 114 I=3,IDO,2
            IC = IDP2-I
            DO 113 K=1,L1
               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  113       CONTINUE
  114    CONTINUE
  115 CONTINUE
  116 AR1 = 1.
      AI1 = 0.
      DO 120 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 117 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2)
            C2(IK,LC) = AI1*CH2(IK,IP)
  117    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 119 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 118 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC)
  118       CONTINUE
  119    CONTINUE
  120 CONTINUE
      DO 122 J=2,IPPH
         DO 121 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  121    CONTINUE
  122 CONTINUE
      DO 124 J=2,IPPH
         JC = IPP2-J
         DO 123 K=1,L1
            CH(1,K,J) = C1(1,K,J)-C1(1,K,JC)
            CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC)
  123    CONTINUE
  124 CONTINUE
      IF (IDO .EQ. 1) GO TO 132
      IF (NBD .LT. L1) GO TO 128
      DO 127 J=2,IPPH
         JC = IPP2-J
         DO 126 K=1,L1
            DO 125 I=3,IDO,2
               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      GO TO 132
  128 DO 131 J=2,IPPH
         JC = IPP2-J
         DO 130 I=3,IDO,2
            DO 129 K=1,L1
               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
  129       CONTINUE
  130    CONTINUE
  131 CONTINUE
  132 CONTINUE
      IF (IDO .EQ. 1) RETURN
      DO 133 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  133 CONTINUE
      DO 135 J=2,IP
         DO 134 K=1,L1
            C1(1,K,J) = CH(1,K,J)
  134    CONTINUE
  135 CONTINUE
      IF (NBD .GT. L1) GO TO 139
      IS = -IDO
      DO 138 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 137 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 136 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  136       CONTINUE
  137    CONTINUE
  138 CONTINUE
      GO TO 143
  139 IS = -IDO
      DO 142 J=2,IP
         IS = IS+IDO
         DO 141 K=1,L1
            IDIJ = IS
            DO 140 I=3,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  140       CONTINUE
  141    CONTINUE
  142 CONTINUE
  143 RETURN
      END
C     ******************************************************************
C
C     SUBROUTINE RFFTF(N,R,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE RFFTF COMPUTES THE FOURIER COEFFICIENTS OF A REAL
C     PERODIC SEQUENCE (FOURIER ANALYSIS). THE TRANSFORM IS DEFINED
C     BELOW AT OUTPUT PARAMETER R.
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 A PRODUCT OF SMALL PRIMES.
C             N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED
C
C     R       A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C             TO BE TRANSFORMED
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15.
C             IN THE PROGRAM THAT CALLS RFFTF. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE RFFTI(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 RFFTF AND RFFTB.
C
C
C     OUTPUT PARAMETERS
C
C     R       R(1) = THE SUM FROM I=1 TO I=N OF R(I)
C
C             IF N IS EVEN SET L =N/2   , IF N IS ODD SET L = (N+1)/2
C
C               THEN FOR K = 2,...,L
C
C                  R(2*K-2) = THE SUM FROM I = 1 TO I = N OF
C
C                       R(I)*COS((K-1)*(I-1)*2*PI/N)
C
C                  R(2*K-1) = THE SUM FROM I = 1 TO I = N OF
C
C                      -R(I)*SIN((K-1)*(I-1)*2*PI/N)
C
C             IF N IS EVEN
C
C                  R(N) = THE SUM FROM I = 1 TO I = N OF
C
C                       (-1)**(I-1)*R(I)
C
C      *****  NOTE
C                  THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF
C                  FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT
C                  SEQUENCE BY N.
C
C     WSAVE   CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN
C             CALLS OF RFFTF OR RFFTB.
C
C
      SUBROUTINE RFFTF (N,R,WSAVE)
      DIMENSION       R(*)       ,WSAVE(*)
      IF (N .EQ. 1) RETURN
      CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
      SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC)
      REAL C(*), CH(*), WA(*), IFAC(*)
      NF = IFAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = IFAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .NE. 4) GO TO 102
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  101    CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  102    IF (IP .NE. 2) GO TO 104
         IF (NA .NE. 0) GO TO 103
         CALL RADF2 (IDO,L1,C,CH,WA(IW))
         GO TO 110
  103    CALL RADF2 (IDO,L1,CH,C,WA(IW))
         GO TO 110
  104    IF (IP .NE. 3) GO TO 106
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 105
         CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 110
  105    CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
         GO TO 110
  106    IF (IP .NE. 5) GO TO 108
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  107    CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  108    IF (IDO .EQ. 1) NA = 1-NA
         IF (NA .NE. 0) GO TO 109
         CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         NA = 1
         GO TO 110
  109    CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
         NA = 0
  110    L2 = L1
  111 CONTINUE
      IF (NA .EQ. 1) RETURN
      DO 112 I=1,N
         C(I) = CH(I)
  112 CONTINUE
      RETURN
      END
      SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1)
      DIMENSION       CH(IDO,2,L1)           ,CC(IDO,L1,*)           ,
     1                WA1(*)
      DO 101 K=1,L1
         CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 108
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CH(I,1,K) = CC(I,K,1)+TI2
            CH(IC,2,K) = TI2-CC(I,K,1)
            CH(I-1,1,K) = CC(I-1,K,1)+TR2
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  103    CONTINUE
  104 CONTINUE
      GO TO 111
  108 DO 110 I=3,IDO,2
         IC = IDP2-I
         DO 109 K=1,L1
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CH(I,1,K) = CC(I,K,1)+TI2
            CH(IC,2,K) = TI2-CC(I,K,1)
            CH(I-1,1,K) = CC(I-1,K,1)+TR2
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  109    CONTINUE
  110 CONTINUE
  111 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         CH(1,2,K) = -CC(IDO,K,2)
         CH(IDO,1,K) = CC(IDO,K,1)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2)
      DIMENSION       CH(IDO,3,L1)           ,CC(IDO,L1,*)           ,
     1                WA1(*)     ,WA2(*)
      DATA TAUR,TAUI /-.5,.866025403784439/
      DO 101 K=1,L1
         CR2 = CC(1,K,2)+CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2
         CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
         CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR2 = DR2+DR3
            CI2 = DI2+DI3
            CH(I-1,1,K) = CC(I-1,K,1)+CR2
            CH(I,1,K) = CC(I,K,1)+CI2
            TR2 = CC(I-1,K,1)+TAUR*CR2
            TI2 = CC(I,K,1)+TAUR*CI2
            TR3 = TAUI*(DI2-DI3)
            TI3 = TAUI*(DR3-DR2)
            CH(I-1,3,K) = TR2+TR3
            CH(IC-1,2,K) = TR2-TR3
            CH(I,3,K) = TI2+TI3
            CH(IC,2,K) = TI3-TI2
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
         DO 105 K=1,L1
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR2 = DR2+DR3
            CI2 = DI2+DI3
            CH(I-1,1,K) = CC(I-1,K,1)+CR2
            CH(I,1,K) = CC(I,K,1)+CI2
            TR2 = CC(I-1,K,1)+TAUR*CR2
            TI2 = CC(I,K,1)+TAUR*CI2
            TR3 = TAUI*(DI2-DI3)
            TI3 = TAUI*(DR3-DR2)
            CH(I-1,3,K) = TR2+TR3
            CH(IC-1,2,K) = TR2-TR3
            CH(I,3,K) = TI2+TI3
            CH(IC,2,K) = TI3-TI2
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
      SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
      DIMENSION       CC(IDO,L1,*)           ,CH(IDO,4,L1)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)
      DATA HSQT2 /.7071067811865475/
      DO 101 K=1,L1
         TR1 = CC(1,K,2)+CC(1,K,4)
         TR2 = CC(1,K,1)+CC(1,K,3)
         CH(1,1,K) = TR1+TR2
         CH(IDO,4,K) = TR2-TR1
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
         CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 111
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  103    CONTINUE
  104 CONTINUE
      GO TO 110
  111 DO 109 I=3,IDO,2
         IC = IDP2-I
         DO 108 K=1,L1
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  108    CONTINUE
  109 CONTINUE
  110 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
         TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
         CH(IDO,1,K) = TR1+CC(IDO,K,1)
         CH(IDO,3,K) = CC(IDO,K,1)-TR1
         CH(1,2,K) = TI1-CC(IDO,K,3)
         CH(1,4,K) = TI1+CC(IDO,K,3)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      DIMENSION       CC(IDO,L1,*)           ,CH(IDO,5,L1)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)
      DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
     1-.809016994374947,.587785252292473/
      DO 101 K=1,L1
         CR2 = CC(1,K,5)+CC(1,K,2)
         CI5 = CC(1,K,5)-CC(1,K,2)
         CR3 = CC(1,K,4)+CC(1,K,3)
         CI4 = CC(1,K,4)-CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2+CR3
         CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
         CH(1,3,K) = TI11*CI5+TI12*CI4
         CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
         CH(1,5,K) = TI12*CI5-TI11*CI4
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
            CR2 = DR2+DR5
            CI5 = DR5-DR2
            CR5 = DI2-DI5
            CI2 = DI2+DI5
            CR3 = DR3+DR4
            CI4 = DR4-DR3
            CR4 = DI3-DI4
            CI3 = DI3+DI4
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
            CH(I,1,K) = CC(I,K,1)+CI2+CI3
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
            TR5 = TI11*CR5+TI12*CR4
            TI5 = TI11*CI5+TI12*CI4
            TR4 = TI12*CR5-TI11*CR4
            TI4 = TI12*CI5-TI11*CI4
            CH(I-1,3,K) = TR2+TR5
            CH(IC-1,2,K) = TR2-TR5
            CH(I,3,K) = TI2+TI5
            CH(IC,2,K) = TI5-TI2
            CH(I-1,5,K) = TR3+TR4
            CH(IC-1,4,K) = TR3-TR4
            CH(I,5,K) = TI3+TI4
            CH(IC,4,K) = TI4-TI3
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
         DO 105 K=1,L1
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
            CR2 = DR2+DR5
            CI5 = DR5-DR2
            CR5 = DI2-DI5
            CI2 = DI2+DI5
            CR3 = DR3+DR4
            CI4 = DR4-DR3
            CR4 = DI3-DI4
            CI3 = DI3+DI4
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
            CH(I,1,K) = CC(I,K,1)+CI2+CI3
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
            TR5 = TI11*CR5+TI12*CR4
            TI5 = TI11*CI5+TI12*CI4
            TR4 = TI12*CR5-TI11*CR4
            TI4 = TI12*CI5-TI11*CI4
            CH(I-1,3,K) = TR2+TR5
            CH(IC-1,2,K) = TR2-TR5
            CH(I,3,K) = TI2+TI5
            CH(IC,2,K) = TI5-TI2
            CH(I-1,5,K) = TR3+TR4
            CH(IC-1,4,K) = TR3-TR4
            CH(I,5,K) = TI3+TI4
            CH(IC,4,K) = TI4-TI3
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
      SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),
     2                CH2(IDL1,IP)           ,WA(*)
      DATA TPI/6.28318530717959/
      ARG = TPI/FLOAT(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IPPH = (IP+1)/2
      IPP2 = IP+2
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IF (IDO .EQ. 1) GO TO 119
      DO 101 IK=1,IDL1
         CH2(IK,1) = C2(IK,1)
  101 CONTINUE
      DO 103 J=2,IP
         DO 102 K=1,L1
            CH(1,K,J) = C1(1,K,J)
  102    CONTINUE
  103 CONTINUE
      IF (NBD .GT. L1) GO TO 107
      IS = -IDO
      DO 106 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 105 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 104 K=1,L1
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  104       CONTINUE
  105    CONTINUE
  106 CONTINUE
      GO TO 111
  107 IS = -IDO
      DO 110 J=2,IP
         IS = IS+IDO
         DO 109 K=1,L1
            IDIJ = IS
            DO 108 I=3,IDO,2
               IDIJ = IDIJ+2
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  108       CONTINUE
  109    CONTINUE
  110 CONTINUE
  111 IF (NBD .LT. L1) GO TO 115
      DO 114 J=2,IPPH
         JC = IPP2-J
         DO 113 K=1,L1
            DO 112 I=3,IDO,2
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  112       CONTINUE
  113    CONTINUE
  114 CONTINUE
      GO TO 121
  115 DO 118 J=2,IPPH
         JC = IPP2-J
         DO 117 I=3,IDO,2
            DO 116 K=1,L1
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  116       CONTINUE
  117    CONTINUE
  118 CONTINUE
      GO TO 121
  119 DO 120 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  120 CONTINUE
  121 DO 123 J=2,IPPH
         JC = IPP2-J
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
            C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
  122    CONTINUE
  123 CONTINUE
C
      AR1 = 1.
      AI1 = 0.
      DO 127 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 124 IK=1,IDL1
            CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
            CH2(IK,LC) = AI1*C2(IK,IP)
  124    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 126 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 125 IK=1,IDL1
               CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
               CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      DO 129 J=2,IPPH
         DO 128 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+C2(IK,J)
  128    CONTINUE
  129 CONTINUE
C
      IF (IDO .LT. L1) GO TO 132
      DO 131 K=1,L1
         DO 130 I=1,IDO
            CC(I,1,K) = CH(I,K,1)
  130    CONTINUE
  131 CONTINUE
      GO TO 135
  132 DO 134 I=1,IDO
         DO 133 K=1,L1
            CC(I,1,K) = CH(I,K,1)
  133    CONTINUE
  134 CONTINUE
  135 DO 137 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 136 K=1,L1
            CC(IDO,J2-2,K) = CH(1,K,J)
            CC(1,J2-1,K) = CH(1,K,JC)
  136    CONTINUE
  137 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IF (NBD .LT. L1) GO TO 141
      DO 140 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 139 K=1,L1
            DO 138 I=3,IDO,2
               IC = IDP2-I
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  138       CONTINUE
  139    CONTINUE
  140 CONTINUE
      RETURN
  141 DO 144 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 143 I=3,IDO,2
            IC = IDP2-I
            DO 142 K=1,L1
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  142       CONTINUE
  143    CONTINUE
  144 CONTINUE
      RETURN
      END
      SUBROUTINE CHEBY (A, B, F, G, PHI, EPS, ITNO, MXITER, L, M,
     X                    P, Q, ERROR, IERR, W)
C     ******************************************************************
C     RATIONAL CHEBYCHEV APPROXIMATION OF CONTINUOUS FUNCTIONS
C     ******************************************************************
      DOUBLE PRECISION A, B, F, G, PHI, EPS, ERROR
      DOUBLE PRECISION P(*), Q(*), W(*)
      EXTERNAL F, G, PHI
C     -------------------
      IF (L .LT. 0 .OR. M .LT. 0) GO TO 10
      LP1 = L + 1
      MP1 = M + 1
      LPM = L + M
      N = LPM + 1
      NP1 = N + 1
C     -------------------
      I1 = NP1 + 1
      I2 = I1 + NP1
      I3 = I2 + NP1*NP1
      I4 = I3 + NP1
      I5 = I4 + NP1
      CALL CHEBY1 (A, B, F, G, PHI, EPS, ITNO, MXITER, L, M, P, Q,
     1              ERROR, IERR, LP1, MP1, LPM, N, NP1, W(1),
     2              W(I1), W(I2), W(I3), W(I4), W(I5))
      RETURN
C     ------------------------------------------------------------------
C     ERROR RETURN
C     ------------------------------------------------------------------
   10 IERR = 1
      RETURN
      END
      SUBROUTINE CHEBY1 (A, B, F, G, PHI, EPS, ITNO, MXITER, L, M,
     1                   P, Q, ERROR, IERR, LP1, MP1, LPM, N, NP1,
     2                   X, XVAL, C, D, ERR, H)
C     ------------------------------------------------------------------
      DOUBLE PRECISION A, B, F, G, PHI, EPS, ERROR
      DOUBLE PRECISION P(LP1), Q(MP1), X(NP1), XVAL(NP1), C(NP1,NP1),
     1          D(NP1), ERR(NP1), H(NP1)
      DOUBLE PRECISION B1, C0, DEL, DN, DNP1, EPS0, HALF, H1,
     1          OLDERR, ONE, PI, SIGN, SUM, TAU, TEMPL, TEN, TEST,
     2          U, XI, XLB, XM1, Y, Y2, Y3, Z, ZERO, ZZ, Z1, Z2, Z3
      EXTERNAL F, G, PHI
C     -------------------
      DATA PI/3.14159265358979323846264338328D0/
      DATA ZERO/0.D0/, HALF/.5D0/, ONE/1.D0/, TEN/10.D0/
      DATA EPS0/1.D-2/, TAU/.015D0/, C0/.0625D0/
C     -------------------
      ERROR = ZERO
      IF (EPS .LE. ZERO .OR. EPS .GE. EPS0) GO TO 200
      IERR = 0
C
      ITNO = 1
      XLB = ZERO
      DN = N
      DNP1 = NP1
C
      DO 10 I = 1,LP1
   10 P(I) = ZERO
      DO 11 I = 1,MP1
   11 Q(I) = ZERO
      Q(1) = ONE
C
C     COMPUTE INITIAL APPROXIMATIONS OF THE CRITICAL POINTS
C
      X(1) = A
      X(NP1) = B
      K = N/2
      IF (K .LE. 0) GO TO 30
      B1 = HALF*(B - A)
      XM1 = HALF*(A + B)
      DO 20 I = 1,K
      XI = I
      Z = -B1*DCOS(PI*(XI/DN))
      X(I+1) = Z + XM1
      II = NP1 - I
   20 X(II) = XM1 - Z
C
C     EVALUATE PHI AT THE CRITICAL POINTS
C
   30 DO 31 I = 1,NP1
   31 XVAL(I) = PHI(X(I))
      KOUNT = 1
C
C     SET UP THE LINEAR EQUATIONS
C
   40 K = L + 2
      SIGN = ONE
      DO 45 I = 1,NP1
      SIGN = -SIGN
      C(I,1) = ONE
      IF (L .LE. 0) GO TO 42
      DO 41 J = 2,LP1
   41 C(I,J) = C(I,J-1)*XVAL(I)
   42 D(I) = F(X(I))
      IF (M .LE. 0) GO TO 44
      TEMPL = SIGN*XLB*G(X(I)) - D(I)
      C(I,K) = XVAL(I)*TEMPL
      IF (K .GT. LPM) GO TO 44
      DO 43 J = K,LPM
   43 C(I,J+1) = C(I,J)*XVAL(I)
   44 C(I,NP1) = SIGN*G(X(I))
   45 CONTINUE
C
C     SOLVE THE EQUATIONS CX = D AND STORE THE RESULTS IN D
C
      CALL DPSLV (NP1, 1, C, NP1, D, NP1, IERR)
      IF (IERR .NE. 0) GO TO 220
      IF (KOUNT .GT. 1) GO TO 50
C
C     REDEFINE THE EQUATIONS AND SOLVE
C
      XLB = (D(NP1) + XLB*DN)/DNP1
      IF (M .LE. 0) GO TO 61
      KOUNT = 2
      GO TO 40
C
   50 TEST = DABS(XLB - D(NP1))
      XLB = (D(NP1) + XLB*DN)/DNP1
      KOUNT = KOUNT + 1
      IF (KOUNT .LE. 4 .AND. TEST .GT. EPS0*DABS(XLB)) GO TO 40
C
C     STORE THE RESULTS IN P AND Q
C
      DO 60 I = 2,MP1
      LPI = L + I
   60 Q(I) = D(LPI)
   61 DO 62 I = 1,LP1
   62 P(I) = D(I)
C
C     SEARCH FOR NEW CRITICAL POINTS
C
      OLDERR = ERROR
      ERROR = ZERO
      Z1 = ZERO
      U = ONE
      IF (XLB .LT. ZERO) U = -U
C
      IF (N .GT. 1) GO TO 70
      H(1) = TAU*(X(2) - X(1))
      H(2) = -H(1)
      GO TO 72
   70 DO 71 I = 2,N
   71 H(I) = TAU*(X(I+1) - X(I-1))
      H(1) = HALF*H(2)
      H(NP1) = -HALF*H(N)
   72 CONTINUE
C
      DO 92 I = 1,NP1
      Y2 = X(I)
      H1 = H(I)
      Y3 = Y2 + H1
      CALL CERR(Y2, F(Y2), G(Y2), PHI(Y2), DEL, IERR, L, LP1, M, NP1, D)
      IF (IERR .NE. 0) RETURN
      Z2 = U*DEL
      CALL CERR(Y3, F(Y3), G(Y3), PHI(Y3), DEL, IERR, L, LP1, M, NP1, D)
      IF (IERR .NE. 0) RETURN
      Z3 = U*DEL
      IF (Z2 .LT. Z3) GO TO 80
      H1 = -H1
      Z = Z3
      Z3 = Z2
      Z2 = Z
      Y = Y3
      Y3 = Y2
      Y2 = Y
C
   80 Y = Y3 + H1
      IF (Y .GE. A) GO TO 81
      Y = A
      GO TO 90
   81 IF (Y .LE. B) GO TO 82
      Y = B
      GO TO 90
   82 CALL CERR(Y, F(Y), G(Y), PHI(Y), DEL, IERR, L, LP1, M, NP1, D)
      IF (IERR .NE. 0) RETURN
      Z = U*DEL
      IF (Z .LE. Z3) GO TO 83
      Y2 = Y3
      Y3 = Y
      Z2 = Z3
      Z3 = Z
      GO TO 80
   83 Y = (Z - Z3) + (Z2 - Z3)
      IF (Y .NE. ZERO) GO TO 84
      Y = Y3
      GO TO 90
   84 Y = HALF*(Y2 + Y3) + H1*(Z2 - Z3)/Y
C
   90 X(I) = Y
      CALL CERR(Y, F(Y), G(Y), PHI(Y), DEL, IERR, L, LP1, M, NP1, D)
      IF (IERR .NE. 0) RETURN
      ERR(I) = DEL
      U = -U
      IF (I .EQ. 1) GO TO 91
      IF (X(I) .LE. X(I-1)) GO TO 230
   91 Z = DABS(ERR(I))
      ERROR = DMAX1(ERROR, Z)
      IF (Z .GE. TEN) GO TO 240
      Y = DABS(XLB)
      ZZ = ONE
      IF (Y .NE. ZERO) ZZ = DABS(Z - Y)/Y
      IF (Z1 .LT. ZZ) Z1 = ZZ
   92 CONTINUE
C
C     SEARCH FOR AN EXTRA EXTREMAL POINT BETWEEN THE ENDPOINTS
C     OF THE INTERVAL AND THE CRITICAL POINTS
C
      IF (X(1) .LE. A) GO TO 110
      H1 = C0*(X(1) - A)
      U = ONE
      IF (XLB .GE. ZERO) U = -U
      Z3 = ZERO
      Y = A
      DO 100 I = 1,16
      CALL CERR(Y, F(Y), G(Y), PHI(Y), DEL, IERR, L, LP1, M, NP1, D)
      IF (IERR .NE. 0) RETURN
      Z = U*DEL
      IF (Z .LE. Z3) GO TO 100
      Z3 = Z
      Z2 = Y
  100 Y = Y + H1
      ERROR = DMAX1(ERROR, Z3)
      Z = DABS(XLB)
      IF (Z3 .LE. Z) GO TO 110
      I = NP1
      DO 101 II = 2,NP1
      ERR(I) = ERR(I-1)
      X(I) = X(I-1)
  101 I = I - 1
      X(1) = Z2
      ERR(1) = U*Z3
      GO TO 113
C
  110 IF (X(NP1) .GE. B) GO TO 120
      H1 = C0*(B - X(NP1))
      U = ONE
      IF (ERR(NP1) .GE. ZERO) U = -U
      Z3 = ZERO
      Y = B
      DO 111 I = 1,16
      CALL CERR(Y, F(Y), G(Y), PHI(Y), DEL, IERR, L, LP1, M, NP1, D)
      IF (IERR .NE. 0) RETURN
      Z = U*DEL
      IF (Z .LE. Z3) GO TO 111
      Z3 = Z
      Z2 = Y
  111 Y = Y - H1
      ERROR = DMAX1(ERROR, Z3)
      Z = DABS(XLB)
      IF (Z3 .LE. Z) GO TO 120
      DO 112 I = 1,N
      ERR(I) = ERR(I+1)
  112 X(I) = X(I+1)
      X(NP1) = Z2
      ERR(NP1) = U*Z3
  113 XLB = -XLB
      ZZ = ONE
      IF (Z .NE. ZERO) ZZ = DABS(Z3 - Z)/Z
      IF (Z1 .LT. ZZ) Z1 = ZZ
C
C     CHECK FOR CONVERGENCE
C
  120 IF (Z1 .LE. EPS) RETURN
C
C     SET UP FOR THE NEXT ITERATION
C
      IF (ITNO .GE. MXITER) GO TO 210
      SUM = ZERO
      SIGN = ONE
      DO 130 I = 1,NP1
      SUM = SUM + SIGN*ERR(I)
  130 SIGN = -SIGN
      XLB = SUM/DNP1
      ITNO = ITNO + 1
      GO TO 30
C     ------------------------------------------------------------------
C     ERROR RETURN
C     ------------------------------------------------------------------
C     INPUT ERROR
C
  200 IERR = 1
      RETURN
C
C     MXITER ITERATIONS WERE PERFORMED - MORE ITERATIONS ARE NEEDED
C
  210 IERR = 2
      RETURN
C
C     THE LINEAR EQUATIONS CANNOT BE SOLVED
C
  220 IF (ITNO .EQ. 1) GO TO 250
      IERR = 3
      RETURN
C
C     THE SEQUENCE OF CRITICAL POINTS IS NOT MONOTONICALLY INCREASING
C
  230 IERR = 4
      IF (I .LE. N) ERROR = OLDERR
      RETURN
C
C     IT APPEARS THAT THE ALGORITHM HAS FAILED TO CONVERGE
C     THERE MAY BE POLES IN THE RATIONAL APPROXIMATION
C
  240 IERR = 5
      RETURN
C
C     THE ROUTINE HAS COMPLETELY FAILED - THE RESULTS SHOULD BE IGNORED
C
  250 IERR = 6
      RETURN
      END
      SUBROUTINE CERR (T, FT, GT, PHIT, DEL, IERR, L, LP1, M, NP1, D)
C     ------------------------------------------------------------------
C     COMPUTE THE APPROXIMATION ERROR AT POINT T
C     ------------------------------------------------------------------
      DOUBLE PRECISION T, FT, GT, PHIT, DEL, D(NP1)
      DOUBLE PRECISION P, Q, R, ZERO, ONE
      DATA ZERO/0.D0/, ONE/1.D0/
C     -------------------
      P = D(LP1)
      IF (L .LE. 0) GO TO 20
      DO 10 I = 1,L
      II = LP1 - I
   10 P = P*PHIT + D(II)
C
   20 Q = ZERO
      IF (M .LE. 0) GO TO 22
      DO 21 I = 1,M
      II = NP1 - I
   21 Q = (Q + D(II))*PHIT
   22 Q = Q + ONE
C
      IF (Q .EQ. ZERO) GO TO 110
      IF (GT .EQ. ZERO) GO TO 100
      R = P/Q
      DEL = (R - FT)/GT
      RETURN
C     ------------------------------------------------------------------
C     ERROR RETURN
C     ------------------------------------------------------------------
C     THE FUNCTION G IS ZERO AT POINT T
C
  100 IERR = 1
      RETURN
C
C     THE ROUTINE HAS COMPLETELY FAILED - THE RESULTS SHOULD BE IGNORED
C
  110 IERR = 6
      RETURN
      END
      SUBROUTINE ADAPT (F, XLFT, XRGT, EPSLN, NPIECE, ERREST, XKNOTS,
     * COEFS, IERR, KMAX, NDEG, NSMTH, ANORM, DX, MO, KBREAK, BRAKPT,
     * KDIFF, VALLFT, VALRGT)
C
C        ===============================================================
C
C     TABULATION OF THE INTERNAL AND EXTERNAL NAMES OF THE ARGUMENTS.
C
C
C    INTERNAL   EXTERNAL
C     F          F
C     A          XLFT
C     B          XRGT
C     ACCUR      EPSLN
C     KNOTS      NPIECE
C     ERROR      ERREST
C     XKNOTS     XKNOTS
C     COEFS      COEFS
C     IERR       IERR
C     KMAX       KMAX
C     DEGREE     NDEG
C     SMOOTH     NSMTH
C     NORM       ANORM
C     CHARF      DX
C     EDIST      MO
C     NBREAK     KBREAK
C     XBREAK     BRAKPT
C     DBREAK     KDIFF
C     BLEFT      VALLFT
C     BRIGHT     VALRGT
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION XKNOTS(*), COEFS(KMAX,*)
      DOUBLE PRECISION ANORM, BRAKPT, DX, EPSLN, ERREST, VALLFT,
     * VALRGT, XLFT, XRGT
      DIMENSION BRAKPT(KBREAK), KDIFF(KBREAK), VALLFT(KBREAK),
     * VALRGT(KBREAK)
      DOUBLE PRECISION F
      EXTERNAL F
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
C
   10 A = XLFT
      B = XRGT
      ACCUR = EPSLN
      DEGREE = NDEG
      SMOOTH = NSMTH
      NORM = ANORM
      CHARF = DX
      EDIST = MO
      NBREAK = KBREAK
      IF (NBREAK.LE.0 .OR. NBREAK.GE.21) GO TO 30
      DO 20 K=1,NBREAK
        XBREAK(K) = BRAKPT(K)
        DBREAK(K) = KDIFF(K)
        BLEFT(K) = VALLFT(K)
        BRIGHT(K) = VALRGT(K)
   20 CONTINUE
   30 CONTINUE
C
      KDIMEN = KMAX+1
      NDIMEN = NDEG+1
      CALL ADAPT1(F, XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR)
      NPIECE = KNOTS
      ERREST = ERROR
      RETURN
      END
      SUBROUTINE ADAPT1(F, XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR)
C
C     THIS ALGORITHM COMPUTES A PIECEWISE POLYNOMIAL APPROXIMATION
C  OF SPECIFIED SMOOTHNESS, ACCURACY AND DEGREE.  THE INPUT TO THE
C  COMPUTATION IS
C
C   F      - FUNCTION BEING APPROXIMATED. IT MUST PROVIDE VALUES OF
C            DERIVATIVES UP TO THE ORDER OF SMOOTHNESS SPECIFIED FOR
C            THE APPROXIMATION.  THE CALLING SEQUENCE IS F(X,FDERV) AND
C            FDERV CONTAINS THE DERIVATIVES( SEE CONSTRAINT BELOW)
C   A,B    - THE ENDPOINTS OF THE INTERVAL OF APPROXIMATION
C   ACCUR  - THE ACCURACY REQUIRED FOR THE APPROXIMATION
C   SMOOTH - THE SMOOTHNESS REQUIRED FOR THE APPROXIMATION
C              = 0  MEANS CONTINUOUS
C              = 1  MEANS CONTINUOUS SLOPE
C              = 2  MEANS CONTINUOUS SECOND DERIVATIVE, ETC.
C   DEGREE - THE DEGREE OF THE POLYNOMIAL PIECES.
C            MUST HAVE DEGREE GT 2*SMOOTH
C   CHARF  - CHARACTERISTIC LENGTH OF THE FUNCTION F(X). PIECES ARE NOT
C            LONGER THAN THIS LENGTH.
C   NORM   - NORM TO MEASURE THE APPROXIMATION ERROR
C              = 1  L1 APPROXIMATION (LEAST DEVIATIONS)
C              = 2  L2 APPROXIMATION (LEAST SQUARES)
C              = 3  TCHEBYCHEFF (MINIMAX) APPROXIMATION
C              =-P  (NEGATIVE VALUE) GENERAL LP APPROXIMATION
C   NBREAK - NUMBER OF SPECIAL BREAK POINTS IN THE APPROXIMATION.
C            ASSOCIATED INPUT VARIABLES ARE
C              XBREAK(J)  - LOCATION OF BREAK POINTS
C              DBREAK(J)  - DERIVATIVE BROKEN AT XBREAK
C              BLEFT (J)  - VALUE FROM LEFT FOR DBREAK DERIVATIVE
C              BRIGHT(J)  -   -    -   RIGHT -    -        -
C   EDIST  - SWITCH TO CHANGE FROM PROPORTIONAL ERROR DISTRIBUTION
C            TO FIXED DISTRIBUTION. THIS IS PRIMARILY OF USE IN
C            APPROXIMATION OF FUNCTIONS WITH SINGULARITIES. ONE SHOULD
C            USE NORM = 1. OR SO IN SUCH CASES
C              = 0  PROPORTIONAL DISTRIBUTION
C              = 1  APPROXIMATE FIXED ERROR DISTRIBUTION
C                   ATTEMPTS TO ACHIEVE SPECIFIED ACCURACY VALUE ACCUR
C              = 2  TRUE FIXED ERROR DISTRIBUTION
C
C  ********** OUTPUT **********
C     THE OUTPUT OF THE COMPUTATION CONSISTS OF 4 PARTS, EACH RETURNED
C     TO THE USER IN A DIFFERENT WAY. THEY ARE
C
C   XKNOTS,COEFS - ARRAYS DEFINING THE PIECEWISE POLYNOMIAL RESULT.
C            XKNOTS(K)  = KNOTS OF THE APPROXIMATION ( K = 1 TO KNOTS)
C                         THE LAST ONE IS RIGHT END POINT OF INTERVAL
C            COEFS(K,N) = COEFFICIENT OF (X - XKNOT(K))**(N-1) IN THE
C                         INTERVAL XKNOT(K) TO XKNOT(K+1)
C                           K = 1 TO KNOTS-1  AND  N = 1 TO DEGREE+1
C            THESE ARRAYS ARE PASSED AS ARGUMENTS SO AS TO USE VARIABLE
C            DIMENSIONS. THE ARRAYS ARE OF DIMENSION XKNOTS(KDIMEN) AND
C            COEFS(KMAX,NDIMEN). IT IS ASSUMED THAT KDIMEN = KMAX+1.
C               ***** NOTE ***** SEVERAL SMALL ARRAYS HERE HAVE FIXED
C                        DIMENSIONS THAT LIMIT DEGREE AND THUS NDIMEN
C                        SHOULD NOT EXCEED THIS LIMIT (CURRENTLY = 20)
C
C   RESULZ - A LABELED COMMON BLOCK CONTAINING KNOTS AND ERROR
C              KNOTS - NUMBER OF KNOTS OF THE APPROXIMATION
C              ERROR - ESTIMATED ACCURACY OF THE APPROXIMATION
C
C   IERR - STATUS INDICATOR. IERR TAKES THE VALUES
C      0   THE APPROXIMATION WAS SUCCESSFULLY CONSTRUCTED.
C     -1   INPUT ERROR REPORTED BY ADSET.
C     -2   A AND B ARE TOO CLOSE.
C     -3   CHARF IS TOO SMALL.
C     -4   EITHER ALL THE BREAK POINTS ARE NOT BETWEEN A AND B, OR
C          XBREAK(I).GE.XBREAK(I+1) FOR SOME I.
C     -5   DBREAK(I).LT.0 .OR. DBREAK(I).GT.(DEGREE-1)/2 FOR SOME I.
C      1   THE KNOT LIMIT WAS EXCEEDED.
C      2   BREAK POINT ADJUSTMENT REQUIRES THAT A SUBINTERVAL BE
C          PARTITIONED. HOWEVER, THIS CANNOT BE DONE EITHER BECAUSE
C          THE INTERVAL STACK IS FULL, OR PARTITIONING WILL PRODUCE
C          TOO SMALL AN INTERVAL.
C      3   A SUBINTERVAL MUST BE PARTITIONED BECAUSE ITS LENGTH IS
C          GREATER THAN CHARF. HOWEVER, THIS CANNOT BE DONE SINCE THE
C          INTERVAL STACK IS FULL.
C      4   A SUBINTERVAL MUST BE PARTITIONED SO THAT THE ACCURACY
C          CRITERIA CAN BE SATISFIED. HOWEVER, THIS CANNOT BE DONE
C          EITHER BECAUSE THE INTERVAL STACK IS FULL, OR PARTITIONING
C          WILL PRODUCE TOO SMALL AN INTERVAL.
C
C  ********** DIMENSION CONSTRAINTS **********
C     MAXKNT - MAX NUMBER OF KNOTS TAKEN FROM USER VIA KDIMEN
C              ARRAYS WITH THIS DIMENSION (OR RELATED VALUES)
C                   COEFS   XKNOTS
C     MAXPAR - MAX NUMBER OF PARAMETERS PER INTERVAL (CURRENTLY = 20)
C                   USER PROVIDED NDIMEN MUST HAVE NDIMEN LE MAXPAR
C                   MUST HAVE  DEGREE + 1 LE MAXPAR
C              ARRAYS WITH THIS DIMENSION (OR RELATED VALUES)
C                D       DDTEMP  FDERVL  FDERVR  FDUMB   FACTOR
C                FINTRP  FLEFT   FRIGHT  POWERS  XTEMP   XINTRP  XDD
C              ***** NOTE ***** MAXPAR ALSO AFFECTS ARGUMENT FDERV
C              OF FUNCTION F.  FDERVL, FDERVR ARE ALSO INVOLVED.
C              SHOULD DECLARE FDERV OF SIZE 10 IN F TO BE SAFE.
C     MAXAUX - MAXIMUM NUMBER OF AUXILIARY INPUT ( = 20 NOW ). ARRAYS
C                 XBREAK  DBREAK  BLEFT   BRIGHT
C     MAXSTK - MAX SIZE OF ACTIVE INTERVAL STACK
C              MIN INTERVAL LENGTH IS 2**(-MAXSTK)*(B-A). ARRAYS
C                 XLEFT   XRIGHT
C
C  **********  PORTABILITY CONSIDERATIONS  **********
C
C     ALL THE ROUTINES IN THIS PACKAGE (EXCEPT ADAPT) ARE WRITTEN IN
C     ANSI STANDARD FORTRAN. IN ADDITION, THEY MEET ALL THE REQUIREMENTS
C     OF THE BELL LABS PORTABLE FORTRAN -PFORT-.  NEVERTHELESS, THE
C     ROUTINES ARE AFFECTED BY A CHANGE IN MACHINE WORD LENGTH AND
C     CHANGING TO SINGLE PRECISION.
C
C     ***** THE GAUSS WEIGHTS AND ABSCISSAE IN ADCOMP ARE GIVEN TO
C           30 DIGITS. THE PARAMETER EPS0 IN ADSET SPECIFIES THE
C           ACCURACY OF THESE CONSTANTS. IF THE ACCURACY IS CHANGED
C           TO K DECIMAL DIGITS THEN SET EPS0 = 10**(-K).
C
C     ***** THE INTERVAL STACK SIZE MAXSTK IS DEFINED IN ADSET TO
C           BE 50. IF MAXSTK IS MODIFIED THEN SET THE DIMENSIONS OF
C           XLEFT AND XRIGHT TO THE NEW VALUE FOR MAXSTK. NOTE THAT
C           THE MINIMUM INTERVAL LENGTH IS 2**(-MAXSTK)*(B-A).
C
C  SINGLE PRECISION CONVERSION -- REQUIRES FOUR STEPS
C     1. DECLARE ALL DOUBLE PRECISION VARIABLES TO BE REAL.
C
C     2. CHANGE ALL DOUBLE PRECISION NUMBERS IN THE DATA STATEMENTS.
C        (FLOATING POINT NUMBERS APPEAR ONLY IN DATA STATEMENTS.)
C
C     3. CHANGE DABS,DMAX1,DMIN1 AT MANY PLACES.
C
C     4. CHANGE DPMPAR TO SPMPAR IN ADSET.
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION XKNOTS(KDIMEN), COEFS(KMAX,NDIMEN)
      DOUBLE PRECISION F
      EXTERNAL F
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
C                      KNTDIM - KDIMEN, NAME CHANGED TO PUT IN COMMON
C                      NPARDM - NDIMEN, NAME CHANGED TO PUT IN COMMON
      COMMON /RESULZ/ ERROR, KNOTS
C                      KNOTS = FINAL NO. OF KNOTS, INCLUDES B AS ONE.
C                      ERROR = ESTIMATE OF ERROR ACTUALLY ACHIEVED.
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
C             KONTRL CONTAINS GENERALLY USEFUL VARIABLES
C                      MAXSTK - SEE COMMENTS ABOVE
C                      BUFFER - THE MACHINE DEPENDENT TOLERANCE USED
C                               BY THE ALGORITHM
C                      NSTACK - COUNTER FOR INTERVAL STACK, CONSISTS OF
C                               (XLEFT(J),XRIGHT(J))  J = 1 TO NSTACK
C                      ERRORI - ERROR ESTIMATE FOR TOP INTERVAL
C                      DSCTOL - TOLERANCE TO CHECK DISCARDING INTERVALS
C                      DISCRD - SWITCH TO SIGNAL DISCARD OF TOP INTERVAL
C                      FACTOR - ARRAY OF FACTORIALS
C                      NPAR   - NUMBER OF PAREMETERS = DEGREE + 1
C                      INTERP - NUMBER OF INTERIOR INTERPOLATION POINTS
C                               IN THE NORMAL INTERVAL
C                      IBREAK - COUNTER ON BREAK POINTS
C                      BREAK  - SWITCH FOR BREAK POINT IN TOP INTERVAL
C                               0     = NO BREAK PRESENT
C                               LEFT  = BREAK AT XLEFT(NSTACK)
C                               RIGHT = BREAK AT XRIGHT(NSTACK)
C                               BOTH  = BREAK AT BOTH ENDS
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C             COMDIF CONTAINS VARIABLES USED ONLY BY ADCOMP AND FRIENDS.
C                      NINTRP - NUMBER OF INTERIOR INTERPOLATION POINTS
C                               FOR THE CURRENT INTERVAL
C                      XINTRP - INTERIOR INTERPOLATION POINTS
C                      FINTRP - F VALUES AT XINTRP POINTS
C                      LEFTX  - MULTIPLICITY OF INTERPOLATION AT XLEFT
C                               = NO. OF DERIVATIVES MATCHED AT XLEFT
C                      FLEFT  - VALUES OF F AND ITS DERIVATIVES AT XLEFT
C                      RIGHTX - MULTIPLICITY OF INTERPOLATION AT XRIGHT
C                      FRIGHT - VALUES OF F AND DERIVATIVES AT XRIGHT
C                      DDTEMP - THE ARRAY OF DIVIDED DIFFERENCES
C                      XDD    - THE X VALUES FOR DDTEMP WITH PROPER
C                               MULTIPLICITIES OF XLEFT AND XRIGHT
C
C------------------------ MAIN CONTROL PROGRAM -------------------------
C
C            CHECK THE INPUT AND INITIALIZE ALL THE PARAMETERS
C
      CALL ADSET(XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR)
      IF (IERR.NE.0) RETURN
C
C                  LOOP OVER PROCESSING OF INTERVALS
C
   10 CALL ADTAKE(IERR)
      IF (IERR.NE.0) RETURN
      CALL ADCOMP(F)
C
C                   CHECK FOR DISCARDING INTERVALS
C
      CALL ADCHK
C
C            PUT NEW INTERVALS ON STACK OR DISCARD, UPDATE STATUS
C
      CALL ADPUT(XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR)
      IF (IERR.NE.0) RETURN
C
C                    TEST FOR NORMAL TERMINATION
C
      IF (NSTACK.EQ.0) RETURN
C
C                CHECK ON THE NUMBER OF KNOTS GENERATED
C
      IF (KNOTS.LT.MAXKNT) GO TO 10
      IERR = 1
      RETURN
      END
      SUBROUTINE ADSET(XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR)
C
C        ===============================================================
C
C **  THIS PROGRAM CHECKS THE INPUT DATA AND INITIALIZES THE COMPUTATION
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION XKNOTS(KDIMEN), COEFS(KMAX,NDIMEN)
      DOUBLE PRECISION AKMAX, EPS, EPS0, KM1, RATIO, ZERO, ONE, TWO,
     * THREE, C100
      DOUBLE PRECISION DPMPAR
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
      DATA EPS0/1.D-30/
      DATA ZERO,ONE,TWO,THREE,C100/0.D0,1.D0,2.D0,3.D0,100.D0/
      DATA KLEFT, KRIGHT, KBOTH /1, 2, 3/
C
      EPS = DPMPAR(1)
      BUFFER = C100*DMAX1(EPS,EPS0)
C
C         PUT DATA STATEMENT ITEMS INTO COMMON VARIABLES
C
      LEFT = KLEFT
      RIGHT = KRIGHT
      BOTH = KBOTH
C
C -------- SET CURRENT VALUES OF LIMITS ON DIMENSIONS ------------------
C
      KNTDIM = KDIMEN
      NPARDM = NDIMEN
      MAXKNT = KNTDIM
      MAXSTK = 50
      MAXPAR = MIN0(20,NPARDM)
      MAXAUX = 20
C
C -------- CHECK INPUT DATA --------------------------------------------
C
      IERR = 0
      IF (A.GE.B .OR. ACCUR.LE.ZERO) GO TO 200
      IF (DEGREE.GE.MAXPAR .OR. 2*SMOOTH.GE.DEGREE) GO TO 200
      AKMAX = KMAX
      RATIO = (B-A)/(DABS(A)+DABS(B))
      IF (RATIO.LE.TWO*BUFFER*AKMAX) GO TO 210
      IF (CHARF.LT.(B-A)/AKMAX) GO TO 220
      IF (NORM.GE.ZERO .AND. (NORM-ONE)*(NORM-TWO)*(NORM-THREE).NE.ZERO)
     *         GO TO 200
      IF (EDIST*(EDIST-1)*(EDIST-2).NE.0) GO TO 200
      IF (NBREAK.LT.0 .OR. NBREAK.GT.MAXAUX) GO TO 200
      IF (NBREAK.EQ.0) GO TO 150
C
C         CHECK THE BREAK POINT DATA, MONOTONICITY AND DEGREE
C
      J = 1
      IF (XBREAK(1).LT.A .OR. XBREAK(NBREAK).GT.B) GO TO 230
      IF (NBREAK.EQ.1) GO TO 110
      DO 100 J=2,NBREAK
        IF (XBREAK(J-1).GE.XBREAK(J)) GO TO 230
  100 CONTINUE
  110 LIMSM = (DEGREE-1)/2
      DO 120 J=1,NBREAK
        IF (DBREAK(J).LT.0 .OR. DBREAK(J).GT.LIMSM) GO TO 240
  120 CONTINUE
C
C -------- INITIALIZATION OF VARIABLES ---------------------------------
C
C             ACTIVE INTERVAL STACK
C
  150 NSTACK = 1
      XLEFT(1) = A
      XRIGHT(1) = B
C
C             TERMINATION AND ERROR VALUES
C
      ERROR = ZERO
      DSCTOL = ACCUR**DABS(NORM)
      IF (EDIST.EQ.0) DSCTOL = DSCTOL/(B-A)
      IF (NORM.EQ.THREE) DSCTOL = ACCUR
C
C             MISCELLANEOUS VARIABLES AND POINTERS
C
      IBREAK = 1
      KNOTS = 1
      INTERP = DEGREE + 2 - 2*SMOOTH
      XKNOTS(1) = A
      NPAR = DEGREE + 1
C
C             COMPUTE ARRAY OF NPAR FACTORIALS
C
      FACTOR(1) = ONE
      FACTOR(2) = ONE
      DO 170 K=3,NPAR
        KM1 = K-1
        FACTOR(K) = KM1*FACTOR(K-1)
  170 CONTINUE
      RETURN
C
C -------- ERROR RETURN ------------------------------------------------
C
  200 IERR = -1
      RETURN
C
C         A AND B ARE TOO CLOSE
C
  210 IERR = -2
      RETURN
C
C         CHARF IS TOO SMALL
C
  220 IERR = -3
      RETURN
C
C         BREAK POINTS ARE NOT MONOTONIC
C
  230 IERR = -4
      RETURN
C
C         BAD VALUE IN DERIVATIVE BREAKS
C
  240 IERR = -5
      RETURN
      END
      SUBROUTINE ADTAKE(IERR)
C
C        ===============================================================
C
C **  THIS PROGRAM TAKES AN ACTIVE INTERVAL OFF THE TOP OF THE STACK
C     IT ALSO DOES MOST OF THE WORK OF LOCATING AND HANDLING
C     BREAK POINTS
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION DX, RATIO
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
C         CHECK FOR BREAK POINT
      BREAK = 0
      IF (NBREAK.EQ.0 .OR. IBREAK.GT.NBREAK) GO TO 20
      IF (XBREAK(IBREAK).GT.XRIGHT(NSTACK)) GO TO 20
C
C               SET CONTROL VARIABLE BREAK, CHECK FOR LOCATION
      IF (XBREAK(IBREAK).GT.XLEFT(NSTACK)) GO TO 10
      BREAK = LEFT
      IF (IBREAK.EQ.NBREAK) GO TO 20
C             CHECK FOR SECOND BREAK POINT IN THIS INTERVAL
      IF (XBREAK(IBREAK+1).GE.XRIGHT(NSTACK)) GO TO 20
C                 NEXT BREAK IS INSIDE INTERVAL, SPLIT TOP INTERVAL
      BREAK = BOTH
C                  CHECK EXCEEDING STACK LIMIT. IF SO, STOP
      IF (NSTACK.EQ.MAXSTK) GO TO 30
C                     DONT SPLIT VERY SMALL INTERVALS, STOP INSTEAD
      DX = XBREAK(IBREAK+1) - XLEFT(NSTACK)
      RATIO = DX/(DABS(A)+DABS(B))
      IF (RATIO.LE.BUFFER) GO TO 30
      NSTACK = NSTACK + 1
      XLEFT(NSTACK) = XLEFT(NSTACK-1)
      XRIGHT(NSTACK) = XBREAK(IBREAK+1)
      XLEFT(NSTACK-1) = XRIGHT(NSTACK)
      GO TO 20
C
   10 BREAK = RIGHT
C                 CHECK TO SEE IF BREAK IS ALREADY AT RIGHT END POINT
      IF (XBREAK(IBREAK).GE.XRIGHT(NSTACK)) GO TO 20
C                 THE BREAK IS INSIDE INTERVAL, SPLIT TOP INTERVAL
C                  CHECK EXCEEDING STACK LIMIT. IF SO, STOP
      IF (NSTACK.EQ.MAXSTK) GO TO 30
C                     DONT SPLIT VERY SMALL INTERVALS, STOP INSTEAD
      DX = XBREAK(IBREAK) - XLEFT(NSTACK)
      RATIO = DX/(DABS(A)+DABS(B))
      IF (RATIO.LE.BUFFER) GO TO 30
      NSTACK = NSTACK + 1
      XLEFT(NSTACK) = XLEFT(NSTACK-1)
      XRIGHT(NSTACK) = XBREAK(IBREAK)
      XLEFT(NSTACK-1) = XRIGHT(NSTACK)
   20 CONTINUE
      RETURN
C
C        A BREAK POINT IS IN THE INTERIOR OF THE TOP SUBINTERVAL OF
C        THE STACK.  THE SUBINTERVAL CANNOT BE PARTITIONED EITHER
C        BECAUSE THE STACK IS FULL, OR BECAUSE PARTITIONING LEADS TO
C        TOO SMALL AN INTERVAL.
C
   30 IERR = 2
      RETURN
      END
      SUBROUTINE ADCOMP(F)
C
C        ===============================================================
C
C **  THIS PROGRAM COMPUTES THE PIECEWISE POLYNOMIAL APPROXIMATION ON
C     THE CURRENT INTERVAL. IT ALSO ESTIMATES THE ERROR
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION ABSC, AJ, DX, FDERVL, FDERVR, FDUMB, R, WGTS
      DIMENSION ABSC(4), WGTS(4), FDERVL(9), FDERVR(9), FDUMB(9)
      DOUBLE PRECISION ERRINT, F, POLYDD
      EXTERNAL F, POLYDD
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
      EQUIVALENCE (FLEFT(2),FDERVL(1)), (FRIGHT(2),FDERVR(1))
      DATA R/1.5D0/
C
C     THIRTY DIGIT VALUES FOR THE GAUSS INTEGRATION CONSTANTS
C                    .861136311594052575223946488893D0
C                    .339981043584856264802665759103D0
C                    .347854845137453857373063949222D0
C                    .652145154862546142626936050778D0
C
C     ***** THE ABSISSAE AND WEIGHTS ARE GIVEN BELOW TO 30 DIGITS.
C           THE PARAMETER EPS0 IN ADSET SPECIFIES THE ACCURACY OF
C           THESE CONSTANTS. IF THE ACCURACY IS CHANGED TO K DECIMAL
C           DIGITS THEN SET EPS0 = 10**(-K).
C
      DATA ABSC(1) /-.861136311594052575223946488893D0 /
      DATA ABSC(2) /-.339981043584856264802665759103D0 /
      DATA ABSC(3) / .339981043584856264802665759103D0 /
      DATA ABSC(4) / .861136311594052575223946488893D0 /
      DATA WGTS(1) / .347854845137453857373063949222D0 /
      DATA WGTS(2) / .652145154862546142626936050778D0 /
      DATA WGTS(3) / .652145154862546142626936050778D0 /
      DATA WGTS(4) / .347854845137453857373063949222D0 /
C
C             COMPUTE INTERPOLATION INFORMATION
      NINTRP = DEGREE - 2*SMOOTH - 1
C
C          INCREASE NUMBER OF INTERPOLATION POINTS IF BREAK POINTS ARE
C          SPECIFIED WITH FEWER DERIVATIVES THAN SMOOTH
      IF (BREAK.EQ.LEFT .OR. BREAK.EQ.RIGHT) NINTRP = NINTRP + SMOOTH -
     * DBREAK(IBREAK)
      IF (BREAK.EQ.BOTH) NINTRP = NINTRP + 2*SMOOTH - DBREAK(IBREAK) -
     * DBREAK(IBREAK+1)
      IF (NINTRP.EQ.0) GO TO 20
C
C             GENERATE EQUAL SPACED INTERPOLATION POINTS
      AJ = NINTRP+1
      DX = (XRIGHT(NSTACK)-XLEFT(NSTACK))/AJ
      DO 10 J=1,NINTRP
        AJ = J
        XINTRP(J) = XLEFT(NSTACK) + AJ*DX
   10 CONTINUE
C
C             GET LEFT AND RIGHT F-VALUES, PUT F-VALUE IN FIRST ELEMENT
C             OF ARRAYS FLEFT AND FRIGHT.  GET DERIVATIVES BACK AS
C             OTHER ELEMENTS VIA THE SUBARRAYS FDERVL AND FDERVR.
   20 FLEFT(1) = F(XLEFT(NSTACK),FDERVL)
      FRIGHT(1) = F(XRIGHT(NSTACK),FDERVR)
      LEFTX = SMOOTH + 1
      RIGHTX = LEFTX
C            GET F-VALUES AT OTHER INTERPOLATION POINTS, IF ANY
      IF (NINTRP.EQ.0) GO TO 40
      DO 30 J=1,NINTRP
        FINTRP(J) = F(XINTRP(J),FDUMB)
   30 CONTINUE
C
C          CHECK FOR BREAK POINTS, MODIFY VALUES IF NECESSARY
   40 CONTINUE
      IF (BREAK.NE.LEFT) GO TO 50
      LEFTX = DBREAK(IBREAK) + 1
      FLEFT(LEFTX) = BRIGHT(IBREAK)
   50 IF (BREAK.NE.RIGHT) GO TO 60
      RIGHTX = DBREAK(IBREAK) + 1
      FRIGHT(RIGHTX) = BLEFT(IBREAK)
   60 IF (BREAK.NE.BOTH) GO TO 70
      LEFTX = DBREAK(IBREAK) + 1
      RIGHTX = DBREAK(IBREAK+1) + 1
      FLEFT(LEFTX) = BRIGHT(IBREAK)
      FRIGHT(RIGHTX) = BLEFT(IBREAK+1)
   70 CONTINUE
C
C           COMPUTE DIVIDED DIFFERENCES, NEWTON FORM OF POLYNOMIAL
      CALL NEWTON(LEFTX, RIGHTX, NINTRP)
C
C         COMPUTE NORM OF ERROR OF THIS APPROMIMATION USING FOUR PTS
C         ADD 50 PERCENT FUDGE FACTOR
      ERRORI = ERRINT(F,POLYDD,XLEFT(NSTACK),XRIGHT(NSTACK),ABSC,WGTS)
      ERRORI = R*ERRORI
      RETURN
      END
      DOUBLE PRECISION FUNCTION ERRINT(F, FIT, AAA, BBB, POINTS, WEIGHT)
C
C        ===============================================================
C
C **  THIS FUNCTION DOES A FOUR POINT INTEGRATION RULE FOR THE
C     ABSOLUTE VALUE OF THE DIFFERENCE OF TWO FUNCTIONS( F AND FIT )
C                   ABS( F(X) - FIT(X) )**NORM
C     THE INTEGRATION USES THE POINTS AND WEIGHTS GIVEN AND SCALED
C     FROM (-1,1) TO (AAA,BBB)
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION AAA, ABMID, BA, BBB, FDUMB, FIT, P, PJ, POINTS,
     * WEIGHT, ER, F1, F2, TWO, THREE
      DIMENSION FDUMB(9), POINTS(*), WEIGHT(*)
      DOUBLE PRECISION F
      EXTERNAL F, FIT
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
      DATA TWO,THREE/2.0D0,3.0D0/
C
C         COMPUTE MIDPOINT = ABMID AND HALF LENGTH = BA OF INTERVAL
      ABMID = (AAA+BBB)/TWO
      BA = (BBB-AAA)/TWO
      PJ = ABMID + BA*POINTS(1)
C
C         TEST FOR TCHEBYCHEFF (MINIMAX) NORM WHICH USES SPECIAL CODE
      IF (NORM.EQ.THREE) GO TO 20
C
C         HAVE GENERAL LP NORM OR LEAST SQUARES OR LEAST DEVIATIONS
      P = DABS(NORM)
C              INITIALIZE THE QUADRATURE RULE
      ERRINT = DABS(F(PJ,FDUMB)-FIT(PJ))**P*WEIGHT(1)
C              LOOP THROUGH REMAINING POINTS
      DO 10 J=2,4
        PJ = ABMID + BA*POINTS(J)
        F1 = F(PJ,FDUMB)
        F2 = FIT(PJ)
        ER = DABS(F1-F2)**P
        ERRINT = ERRINT + DABS(F(PJ,FDUMB)-FIT(PJ))**P*WEIGHT(J)
   10 CONTINUE
      ERRINT = ERRINT*BA
      GO TO 40
C
C         TCHEBYCHEFF NORM
   20 CONTINUE
C             FIND MAX ERROR ON POINTS
C               INITIALIZE
      ERRINT = DABS(F(PJ,FDUMB)-FIT(PJ))
C              LOOP THROUGH THE REMAINING POINTS
      DO 30 J=2,4
        PJ = ABMID + BA*POINTS(J)
        ERRINT = DMAX1(ERRINT,DABS(F(PJ,FDUMB)-FIT(PJ)))
   30 CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE NEWTON(NL, NR, NI)
C
C        ===============================================================
C
C **  THIS PROGRAM COMPUTES THE DIVIDED DIFFERENCES ARRAY AS FOLLOWS
C         NL COALESCED POINTS ON LEFT   - DERIV VALUES IN FLEFT
C         NR COALESCED POINTS ON RIGHT  -   -      -    - FRIGHT
C         NI DISTINCT  POINTS INBETWEEN - FNCTN    -    - FINTRP
C
C     THE POINTS ARE ORDERED XL = XLEFT (NSTACK)
C                            XR = XRIGHT(NSTACK)
C                            XINTRP ARRAY
C
C         LAYOUT OF THE DDTEMP DIVIDED DIFFERENCE ARRAY
C
C     NL=6    LLLLLL****II
C     NR=4    LLLLL****II     L = FIRST TRIANGLE
C     NI=2    LLLL****II
C             LLL****II       R = SECOND TRIANGLE
C             LL****II
C             L****II         * = FILL BETWEEN TRIANGLES
C             RRRRII
C             RRRII           I = COMPLETION FOR INTERPOLATION POINTS
C             RRII
C             RII       IDIF = HORIZONTAL COORD. = DIFFERENCE ORDER
C             II        IPT  = VERTICAL COORD. ASSOCIATED WITH POINTS
C             I
C
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION DIFFF, DIFFX
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
C                 MAIN CALCULATION OF DIVIDED DIFFERENCES
C         DEFINE A FEW SHORT CONSTANTS
      NL1 = NL - 1
      NL2 = NL + 1
      NR1 = NR - 1
      NR2 = NR + 1
      NRL = NR + NL
C
C         PUT X-VALUES IN A SINGLE ARRAY WITH NDDX = NL+NR+NI POINTS
      DO 10 NDDX=1,NL
        XDD(NDDX) = XLEFT(NSTACK)
   10 CONTINUE
      NDDX = NL
      DO 20 K=1,NR
        NDDX = NDDX + 1
        XDD(NDDX) = XRIGHT(NSTACK)
   20 CONTINUE
C            CHECK IF THERE ARE ANY INTERPOLATION POINTS TO ADD TO XDD
      IF (NI.EQ.0) GO TO 40
      DO 30 K=1,NI
        NDDX = NDDX + 1
        XDD(NDDX) = XINTRP(K)
   30 CONTINUE
C
C           FILL BORDER OF FIRST TRIANGLE - SIZE NL.
   40 CONTINUE
C         TOP BORDER
      DO 50 IDIF=1,NL
        DDTEMP(IDIF,1) = FLEFT(IDIF)/FACTOR(IDIF)
   50 CONTINUE
      IF (NL1.EQ.0) GO TO 70
C                   BOTTOM BORDER
      DO 60 IDIF=1,NL1
        IPT = NL2 - IDIF
        DDTEMP(IDIF,IPT) = DDTEMP(IDIF,1)
   60 CONTINUE
C
C          FILL BORDER OF SECOND TRIANGLE - SIZE NR
   70 CONTINUE
C         TOP BORDER
      DO 80 IDIF=1,NR
        DDTEMP(IDIF,NL2) = FRIGHT(IDIF)/FACTOR(IDIF)
   80 CONTINUE
      IF (NRL.EQ.NL2) GO TO 100
C                   BOTTOM BORDER
      DO 90 IDIF=1,NR1
        IPT = NRL + 1 - IDIF
        DDTEMP(IDIF,IPT) = DDTEMP(IDIF,NL2)
   90 CONTINUE
C
C           FILL PARALLOGRAM BETWEEN THE TWO TRIANGLES JUST FILLED
C          FILL ENTRIES PARALLEL TO BOTTOM OF FIRST TRIANGLE
  100 CONTINUE
C
C         LOOP STEPPING ALONG TOP SIDE OF SECOND TRIANGLE
      DO 120 J=2,NR2
        IDIF = J
C             LOOP STEPPING PARALLEL TO BOTTOM SIDE OF FIRST TRIANGLE
        DO 110 K=2,NL2
          IPT = NL + 2 - K
          DIFFF = DDTEMP(IDIF-1,IPT+1) - DDTEMP(IDIF-1,IPT)
          IPT2 = IPT - 1 + IDIF
          DIFFX = XDD(IPT2) - XDD(IPT)
          DDTEMP(IDIF,IPT) = DIFFF/DIFFX
          IDIF = IDIF + 1
  110   CONTINUE
  120 CONTINUE
C
C         FILL IN BOTTOM DIAGONALS FOR INTERPOLATION POINTS, IF ANY
      IF (NI.EQ.0) GO TO 150
C         LOOP THROUGH THE INTERPOLATATION POINTS
      DO 140 J=1,NI
        IDIF = 2
        NRLJ = NRL + J
        DDTEMP(1,NRLJ) = FINTRP(J)
C         LOOP THROUGH THE DIFFERENCES (IDIF INDEX)
        NRLJ1 = NRLJ - 1
        DO 130 K=1,NRLJ1
          IPT = NRLJ - K
          DIFFF = DDTEMP(IDIF-1,IPT+1) - DDTEMP(IDIF-1,IPT)
          DIFFX = XDD(NRLJ) - XDD(IPT)
          DDTEMP(IDIF,IPT) = DIFFF/DIFFX
          IDIF = IDIF + 1
  130   CONTINUE
  140 CONTINUE
  150 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION POLYDD(X)
C
C        ===============================================================
C
C **  THIS FUNCTION EVALUATES THE CURRENT POLYNOMIAL PIECE REPRESENTED
C     BY THE DIVIDED DIFFERENCES DDTEMP ON THE POINT SET XDD.
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION X
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
      POLYDD = DDTEMP(DEGREE+1,1)
      DO 10 K=1,DEGREE
        J = DEGREE + 1 - K
        POLYDD = DDTEMP(J,1) + (X-XDD(J))*POLYDD
   10 CONTINUE
      RETURN
      END
      SUBROUTINE ADCHK
C
C        ===============================================================
C
C **  THIS PROGRAM CHECKS FOR DISCARDING INTERVAL, APPLIES VARIOUS
C     TESTS ABOUT DISCARDING INVOLVING EDIST AND CHARF.
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION AKNOTS, DTEST, DX, THREE, FIVE
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
      DATA THREE,FIVE/3.0D0,5.0D0/
C
      DISCRD = .FALSE.
      DX = XRIGHT(NSTACK) - XLEFT(NSTACK)
      IF (DX.GT.CHARF) RETURN
C
C         COMPUTE DTEST FOR THE LOCAL ERROR CRITERION
C
      IF (NORM.EQ.THREE) GO TO 30
      IF (EDIST-1) 10,20,30
   10 DTEST = DX*DSCTOL
      GO TO 40
C         FOR THE APPROXIMATE FIXED ERROR DISTRIBUTION TYPE WE ESTIMATE
C         THE FINAL NUMBER OF KNOTS BY( LIMITING IT A LITTLE )
C             (NSTACK+KNOTS+2)((B-A)/(XRIGHT-A))
   20 AKNOTS = NSTACK+KNOTS+2
      DTEST = DSCTOL/(AKNOTS*DMIN1((B-A)/(XRIGHT(NSTACK)-A),FIVE))
      GO TO 40
   30 DTEST = DSCTOL
C
C             CHECK FOR DISCARD OF INTERVAL
C
   40 IF (ERRORI.LE.DTEST) DISCRD = .TRUE.
      RETURN
      END
      SUBROUTINE ADPUT(XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR)
C
C        ===============================================================
C **  THIS PROGRAM PUTS INTERVALS ON THE STACK OR DISCARDS THEM.
C     WHEN AN INTERVAL IS DISCARDED A NEW KNOT IS FOUND. THEN THIS
C     PROGRAM UPDATES THE ERROR ESTIMATE, THE XKNOT ARRAY, TRANSFORMS
C     THE POLYNOMIAL TO THE POWER FORM AND PUT THE COEFFICIENTS INTO
C     THE ARRAY COEFS.  IT ALSO CHECKS FOR PASSING BREAK POINTS
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION XKNOTS(KDIMEN), COEFS(KMAX,NDIMEN)
      DOUBLE PRECISION DX, HALF, ONE, POWERS, P, RATIO, THREE
      DIMENSION POWERS(20)
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
      DATA HALF,ONE,THREE/.5D0,1.D0,3.D0/
C
C            CHECK FOR DISCARDING THE INTERVAL
      IF (DISCRD) GO TO 30
C
C         SUBDIVIDE INTERVAL AND PLACE ON STACK
      IF (NSTACK.LT.MAXSTK) GO TO 10
C             FATAL ERROR, EXCEEDED ACTIVE STACK SIZE
      IERR = 4
      DX = XRIGHT(NSTACK)-XLEFT(NSTACK)
      IF (DX.GT.CHARF) IERR = 3
      RETURN
C
   10 DX = (XRIGHT(NSTACK)-XLEFT(NSTACK))*HALF
C              CHECK FOR SMALL INTERVALS
      RATIO = DX/(DABS(A)+DABS(B))
      IF (RATIO.GT.BUFFER) GO TO 20
      IERR = 4
      RETURN
C
   20 NSTACK = NSTACK + 1
      XLEFT(NSTACK) = XLEFT(NSTACK-1)
      XLEFT(NSTACK-1) = XRIGHT(NSTACK-1) - DX
      XRIGHT(NSTACK) = XLEFT(NSTACK-1)
      RETURN
C
C            DISCARD INTERVAL, UPDATE GLOBAL ERROR, XKNOTS AND COEFS
   30 P = DABS(NORM)
      IF (NORM.EQ.THREE) ERROR = DMAX1(ERROR,ERRORI)
      IF (NORM.NE.THREE) ERROR = (ERROR**P+ERRORI)**(ONE/P)
C
C              CHECK FOR PASSING BREAK POINTS
      IF (BREAK.EQ.LEFT .OR. BREAK.EQ.BOTH) IBREAK = IBREAK + 1
C
C             TRANSFORM REPRESENTATION OF POLYNOMIAL FROM DIVIDED
C             DIFFERENCES TO POWERS OF X WITH ORIGIN AT XKNOTS (KNOTS)
      CALL ADTRAN(DDTEMP, POWERS)
C
C             PUT COEFS INTO THE MAIN ARRAY
      DO 40 K=1,NPAR
        COEFS(KNOTS,K) = POWERS(K)
   40 CONTINUE
C            PUT THE NEW KNOTS IN XKNOTS
      KNOTS = KNOTS + 1
      XKNOTS(KNOTS) = XRIGHT(NSTACK)
      NSTACK = NSTACK - 1
      RETURN
      END
      SUBROUTINE ADTRAN(D, POWERS)
C
C        ===============================================================
C
C **  THIS PROGRAM CONVERTS POLYNOMIAL REPRESENTATION FROM DIVIDED
C     DIFFERENCE TO POWER FORM.  THERE ARE COALESCED POINTS ON EACH
C     END OF THE INTERVAL (XL,XR) = (XLEFT(NSTACK),XRIGHT(NSTACK)).
C     THE NUMBER COALESCED AT EACH END IS LEFTX AND RIGHTX.
C     AND THERE ARE NINTRP OTHER PTS XINTRP(K)  INBETWEEN THEM.
C     SEE SUBROUTINE NEWTON FOR MORE DETAILS
C
      DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP,
     * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM,
     * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER
      DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20)
      DIMENSION XLEFT(50), XRIGHT(50)
      DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10),
     * FRIGHT(10), XDD(20), XINTRP(18)
      INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH
      LOGICAL DISCRD
      DOUBLE PRECISION D, POWERS, SHIFT, XL, XR, XTEMP
      DIMENSION D(20,*), POWERS(*), XTEMP(20)
C
      COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT,
     * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM
      COMMON /RESULZ/ ERROR, KNOTS
      COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH,
     * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK,
     * NPAR, NSTACK, RIGHT, DISCRD, BUFFER
      COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP,
     * LEFTX, NINTRP, RIGHTX
C
C         SET SOME SHORT LOCAL VARIABLE NAMES
C
      XL = XLEFT(NSTACK)
      XR = XRIGHT(NSTACK)
      NL = LEFTX
      NR = RIGHTX
      NI = NINTRP
      NRL = NR + NL
      NRI = NR + NI
      NRI1 = NRI - 1
      NRLI = NRL + NI
C
C         STARTING REPRESENTATION IS (ASSUMING XL = 0 )
C
C    D(1) +D(2)X +D(3)X**2 + --- +D(NL)X**(NL-1)
C   +(X**NL)*( D(NL+1)(+D(NL+2)(X-XR)**2 + --- +D(NL+NR)*(X-XR)**(NR-1)
C        *((X-XR)**NR)*(D(NL+NR+1) + D(NL+NR+2)*(X-XINTRP(1))
C                      +D(NL+NR+3)*(X-XINTRP(1))(X-XINTRP(2)) + ---))
C
C         STRATEGY IS TO FIRST CONVERT THE PART FROM THE INTERP. PTS.
C         TO POLY IN (X-XR).  THIS POLY THEN HAS ORIGIN SHIFTED TO XL.
C
C     THE CONVERSION OF THE INTERP PART IS DONE EXPLICITLY FOR DEGREE
C     TWO OR LESS AND DONE BY SYNTHETIC DIVISION FOR HIGHER DEGREES
C
C   D1 + D2(X-X1) +D3(X**2-(X1+X2)X +X1*X2)
C
C     THE RESULTING COEFFICIENTS ARE PUT IN THE ARRAY POWERS
C
      IF (NI.EQ.0) GO TO 100
C
C             BUILD UP THE POLYNOMIAL FOR THE INTERPOLATION POINTS
C
C         USE SPECIAL FORMULAS FOR NI LESS THAN 3
      IF (NI.EQ.1) GO TO 10
      IF (NI.EQ.2) GO TO 20
      GO TO 30
   10 POWERS(1) = D(NRL+1,1)
      GO TO 80
   20 POWERS(1) = D(NRL+1,1) + (XR-XINTRP(1))*D(NRL+2,1)
      POWERS(2) = D(NRL+2,1)
      GO TO 80
C
C         CONVERSION BY REPEATED SYNTHETIC DIVISION
   30 NI1 = NI - 1
C         INITIALIZE THE POWERS AND XTEMP ARRAYS
      DO 40 K=1,NI
        XTEMP(K) = XINTRP(K)
        NRLK = NRL + K
        POWERS(K) = D(NRLK,1)
   40 CONTINUE
C
C         DO THE REPEATED SYNTHETIC DIVISION TO REPLACE THE XTEMP
C         = XINTRP POINTS OF THE NEWTON EXPANSION BY THE XR POINTS
      DO 70 K=1,NI1
C              POWERS(NI) IS FIXED AND SET ABOVE
        DO 50 II=1,NI1
          I = NI - II
          POWERS(I) = POWERS(I) + (XR-XTEMP(I))*POWERS(I+1)
   50   CONTINUE
C              SHIFT THE NEWTON EXPANSION PTS. UP, PUT IN ONE MORE XR
        DO 60 II=1,NI1
          I = NI - II
          XTEMP(I+1) = XTEMP(I)
   60   CONTINUE
        XTEMP(1) = XR
   70 CONTINUE
   80 CONTINUE
C             SHIFT THE COEFFICIENTS TO THE TOP OF THE POWERS ARRAY
      DO 90 K=1,NI
        L = NI + 1 - K
        LTOP = L + NRL
        POWERS(LTOP) = POWERS(L)
   90 CONTINUE
C
C             HAVE THE INTERPOLATION PT. COEFS. IN THE ARRAY POWERS
  100 CONTINUE
C             PUT THE REMAINING DIVIDED DIFFS INTO THE POWERS ARRAY
      DO 110 J=1,NRL
        POWERS(J) = D(J,1)
  110 CONTINUE
C
C         TRANSFORM THE ORIGIN OF THE POLYNOMIAL FROM XR TO XL
C         WE USE REPEATED SYNTHETIC DIVISION
      IF (NRI.EQ.1) GO TO 140
      SHIFT = XR - XL
      KHI = NRI1
C             LOOP THROUGH THE COEFFICIENTS
      DO 130 J=2,NRI
C                   SYNTHETIC DIVISION LOOP
        DO 120 K=1,KHI
          KOEF = NRLI - K
          POWERS(KOEF) = POWERS(KOEF) - SHIFT*POWERS(KOEF+1)
  120   CONTINUE
        KHI = KHI - 1
  130 CONTINUE
  140 CONTINUE
C     THE COEFFICIENTS ARE NOW OF THE POWER FORM WITH ORIGIN XL
      RETURN
      END
      SUBROUTINE CPSC (F, Z, N, IC, TOL, R, RS, ERR)
C
C  EVALUATION OF COMPLEX POWER SERIES COEFFICIENTS OR DERIVATIVES.
C
C  *** INPUT PARAMETERS ***
C    F   COMPLEX FUNCTION, OF WHICH THE COEFFICIENTS OR DERIVATIVES
C        ARE SOUGHT. THIS FUNCTION MUST BE DECLARED EXTERNAL IN THE
C        CALLING PROGRAM.
C    Z   COMPLEX POINT AROUND WHICH F IS TO BE EXPANDED OR AT WHICH
C        DERIVATIVES ARE TO BE EVALUATED.
C    N   INTEGER, NUMBER OF COEFFICIENTS OR DERIVATIVES WANTED.
C        N MUST BE GE 1 AND LE 51.
C    IC  SELECTS BETWEEN POWER SERIES COEFFICIENTS AND DERIVATIVES.
C        IC .EQ. 0   ROUTINE RETURNS POWER SERIES COEFFICIENTS IN RS.
C        IC .NE. 0   ROUTINE RETURNS DERIVATIVES IN RS.
C    TOL ESTIMATED RELATIVE ACCURACY OF F. IT IS ASSUMED THAT TOL
C        IS NONNEGATIVE. IF TOL = 0 THEN F IS ASSUMED TO BE CORRECT
C        TO MACHINE ACCURACY.
C
C  *** INPUT AND OUTPUT PARAMETER ***
C    R   INITIAL RADIUS USED IN SEARCH FOR OPTIMAL RADIUS. THE RESULTING
C        RADIUS IS LEFT IN R. THE PROVIDED GUESS MAY BE IN ERROR WITH AT
C        MOST A FACTOR OF 3.E4 .
C
C  *** OUTPUT PARAMETERS ***
C    RS  COMPLEX ARRAY RS(N) CONTAINING THE N FIRST
C        COEFFICIENTS (CORRESPONDING TO THE POWERS 0 TO N-1) OR DERIVA-
C        TIVES (ORDERS 0 TO N-1).
C    ERR REAL ARRAY ERR(N) CONTAINING ABSOLUTE ERROR ESTIMATES FOR THE
C        NUMBERS IN RS.
C
      DIMENSION IP(32),A(64),RS(N),ERR(N),RT(51,3),FV(6),
     *  IW(7),SC(4),RV(3),C(4),FC(3)
      COMPLEX F,A,V,RS,RT,FV,U,W,T,Z,RV,RQ,S,XK,MULT,CO
C
C  LIST OF THE VARIABLES INITIALIZED IN THE DATA STATEMENT BELOW.
C   IW   2**( 0 , 1 , 2 , 3 , 4 , 5 , 6 ) .
C   IP   PERMUTATION CONSTANTS FOR THE FFT.
C   RV   CONSTANTS FOR THE LAURENT SERIES TEST.
C
      DATA IW(1),IW(2),IW(3),IW(4),IW(5),IW(6),IW(7)/1,2,4,8,16,32,64/
      DATA IP( 1),IP( 2),IP( 3),IP( 4),IP( 5),IP( 6),IP( 7),IP( 8),
     *     IP( 9),IP(10),IP(11),IP(12),IP(13),IP(14),IP(15),IP(16),
     *     IP(17),IP(18),IP(19),IP(20),IP(21),IP(22),IP(23),IP(24),
     *     IP(25),IP(26),IP(27),IP(28),IP(29),IP(30),IP(31),IP(32)/
     *     64,32,48,16,56,24,40,8,60,28,44,12,52,20,36,4,62,30,46,14,
     *     54,22,38,6,58,26,42,10,50,18,34,2/
      DATA RV(1)/(-.4,.3)/, RV(2)/(.7,.2)/, RV(3)/(.02,-.06)/
C
C  STATEMENT FUNCTION FOR MULTIPLICATION OF A COMPLEX NUMBER
C  BY A REAL NUMBER.
C
      MULT(RE,CO) = CMPLX(RE*REAL(CO),RE*AIMAG(CO))
C
C  -------------------
C
C  ****** EPS0 IS A MACHINE DEPENDENT CONSTANT. EPS0 IS THE
C         SMALLEST NUMBER SUCH THAT 1 + EPS0 .GT. 1.
C
                    EPS0 = SPMPAR(1)
C
C  -------------------
C
C  INITIALIZATION.
C
      EPS = AMAX1(EPS0,TOL)
      SC(1) = .125
      C(1) = EPS**(1./28.)
      EP6 = C(1)**6
      PI = 4.0*ATAN(1.0)
      FV(1) = (-1.,0.)
      FV(2) = (0.,-1.)
      R1 = SQRT(0.5)
      RA = 1.0/R1
      FV(3) = CMPLX(R1,-R1)
      DO 10 I = 2,4
        SC(I) = .5*SC(I-1)
        C(I) = SQRT(C(I-1))
        ANG = PI*SC(I-1)
   10   FV(I+2) = CMPLX(COS(ANG),-SIN(ANG))
C
C  START EXECUTION.
C
      IF (N .GT. 51 .OR. N .LT. 1) GO TO 260
      L2 = 1
      LF = 0
      NP = 0
      M = 0
      NR = -1
C
C  FIND IF A FFT OVER 8, 16, 32, OR 64 POINTS SHOULD BE USED.
C
      KL = 1
      IF (N .GT. 6) KL = 2
      IF (N .GT. 12) KL = 3
      IF (N .GT. 25) KL = 4
      KM = KL + 2
      KN = 7 - KM
      IX = IW(KM + 1)
      IS = IW(KN)
   30 V = CMPLX(R,0.0)
C
C  FUNCTION VALUES OF F ARE STORED READY PERMUTATED FOR THE FFT.
C
      DO 40 I = IS,32,IS
        IQ = IP(I)
        V = V*FV(KM)
        A(IQ) = F(Z + V)
   40   A(IQ - 1) = F(Z - V)
      LN = 2
      JN = 1
C
C  THE LOOP  DO 70 ... CONSTITUTES THE FFT.
C
      DO 70 L = 1,KM
        U = (1.,0.)
        W = FV(L)
        DO 60 J = 1,JN
          DO 50 I = J,IX,LN
            IT = I + JN
            T = A(IT)*U
            A(IT) = A(I) - T
   50       A(I) = A(I) + T
   60     U = U*W
        LN = LN + LN
   70   JN = JN + JN
      CX = 0.0
      B = 1.0
C
C  TEST ON HOW FAST THE COEFFICIENTS OBTAINED DECREASE.
C
      DO 80 I = 1,IX
        CT = CABS(A(I))/B
        IF (CT .LT. CX) GO TO 80
        CX = CT
        INR = I
   80   B = B*C(KL)
      IF (M .LE. 1) GO TO 100
C
C  ESTIMATE OF THE ROUNDING ERROR LEVEL FOR THE LAST RADIUS.
C
      ERR(1) = CX*EPS
      DO 90 I = 2,N
   90   ERR(I) = ERR(I-1)/R
  100 SF = SC(KL)
      DO 110 I = 1,IX
        A(I) = MULT(SF,A(I))
  110   SF = SF/R
      L1 = L2
      L2 = 1
      IF (INR .GT. IW(KM)) GO TO 150
      IF (LF .EQ. 1) GO TO 140
C
C  TEST IF THE SERIES IS A TAYLOR OR A LAURENT SERIES.
C
      SR = 0.0
      SP = 0.0
      DO 130 J = 1,3
        RQ = MULT(R,RV(J))
        S = A(IX)
        DO 120 I = 2,IX
          IA = IX + 1 - I
  120     S = S*RQ + A(IA)
        CP = CABS(S)
        IF (CP .GT. SP) SP = CP
        CM = CABS(S - F(Z + RQ))
  130   IF (CM .GT. SR) SR = CM
      IF (SR .GT. 1.E-3*SP) GO TO 150
      LF = 1
  140 L2 = -1
C
C  DETERMINATION OF THE NEXT RADIUS TO BE USED.
C
  150 IF (NR .GE. 0) GO TO 160
        FACT = 2.0
        IF (L2 .EQ. 1) FACT = 0.5
        L1 = L2
        NR = 0
  160 IF (L1 .NE. L2) GO TO 180
        IF (NR .GT. 0) GO TO 170
          NP = NP + 1
          IF (NP-15) 190,190,260
  170   FACT = 1.0/FACT
  180 FACT = 1.0/SQRT(FACT)
      NR = NR + 1
  190 R = R*FACT
      M = NR - KL - 1
      IF (M .LE. 0) GO TO 30
C
C  THE RESULTS FOR THE LAST THREE RADII ARE STORED.
C
      DO 200 I = 1,N
  200   RT(I,M) = A(I)
      IF (M .EQ. 1) GO TO 220
C
C  EXTRAPOLATION.
C
      DO 210 I = 1,N
        XK = RT(I,M-1) - RT(I,M)
  210   RT(I,M-1) = RT(I,M) - MULT(FC(M-1),XK)
      IF (M .EQ. 3) GO TO 230
C
C  CALCULATION OF THE EXTRAPOLATION CONSTANTS.
C
  220 FC(M) = 1.5 + SIGN(.5,FACT-1.)
      IF (M .EQ. 2) FC(M) = FC(M) + RA
      IF (FACT .GT. 1.0) FC(M) = -FC(M)
      GO TO 30
  230 FC(3) = FC(1)*FC(2)/(FC(1) + FC(2) + 1.0)
C
C  FINAL EXTRAPOLATION AND ERROR ESTIMATE.
C
      DO 240 I = 1,N
        XK = RT(I,1) - RT(I,2)
        ERR(I) = ERR(I) + EP6*CABS(XK)
  240   RS(I) = RT(I,2) - MULT(FC(3),XK)
C
C  MULTIPLY POWER SERIES COEFFICIENTS AND ERROR ESTIMATE BY FACTORIALS
C  IF DERIVATIVES WANTED.
C
      IF (IC .EQ. 0) RETURN
      FAC = 0.0
      FACT = 1.0
      DO 250 I = 1,N
        RS(I) = MULT(FACT,RS(I))
        ERR(I) = FACT*ERR(I)
        FAC = FAC + 1.0
  250   FACT = FACT*FAC
      RETURN
C
C  ERROR RETURN.
C
  260 DO 270 I = 1,N
        RS(I) = (0.,0.)
  270   ERR(I) = 1.E10
      RETURN
      END
      SUBROUTINE DCPSC (FUN, X, Y, N, IC, TOL, R, RS1, RS2, ERR)
      DOUBLE PRECISION X, Y, TOL, R, RS1(N), RS2(N), ERR(N)
C
C  EVALUATION OF COMPLEX POWER SERIES COEFFICIENTS OR DERIVATIVES.
C
C  *** INPUT PARAMETERS ***
C    FUN SUBROUTINE WHICH COMPUTES THE COMPLEX FUNCTION F FOR WHICH
C        THE COEFFICIENTS OR DERIVATIVES ARE SOUGHT. WE WRITE
C                   CALL FUN(U1,U2,W1,W2)
C        WHEN W = F(U) IS TO BE COMPUTED FOR THE COMPLEX ARGUMENT U.
C        HERE U1 AND U2 ARE THE REAL AND IMAGINARY PARTS OF U, AND W1
C        AND W2 ARE THE REAL AND IMAGINARY PARTS OF W.  U1,U2,W1,W2
C        HAVE DOUBLE PRECISION VALUES. THE SUBROUTINE FUN MUST BE
C        DECLARED IN THE CALLING PROGRAM TO BE OF TYPE EXTERNAL.
C    X   REAL PART OF THE COMPLEX POINT AROUND WHICH F IS TO BE
C        EXPANDED OR AT WHICH ITS DERIVATIVES ARE TO BE COMPUTED.
C    Y   IMAGINARY PART OF THE COMPLEX POINT AROUND WHICH F IS TO BE
C        EXPANDED OR AT WHICH ITS DERIVATIVES ARE TO BE COMPUTED.
C    N   INTEGER, NUMBER OF COEFFICIENTS OR DERIVATIVES WANTED.
C        N MUST BE GE 1 AND LE 51.
C    IC  SELECTS BETWEEN POWER SERIES COEFFICIENTS AND DERIVATIVES.
C        IC .EQ. 0   ROUTINE RETURNS POWER SERIES COEFFICIENTS IN
C                    RS1 AND RS2.
C        IC .NE. 0   ROUTINE RETURNS DERIVATIVES IN RS1 AND RS2.
C    TOL ESTIMATED RELATIVE ACCURACY OF FUN. IT IS ASSUMED THAT TOL
C        IS NONNEGATIVE. IF TOL = 0 THEN FUN IS ASSUMED TO BE CORRECT
C        TO MACHINE ACCURACY.
C
C  *** INPUT AND OUTPUT PARAMETER ***
C    R   INITIAL RADIUS USED IN SEARCH FOR OPTIMAL RADIUS. THE RESULTING
C        RADIUS IS LEFT IN R. THE PROVIDED GUESS MAY BE IN ERROR WITH AT
C        MOST A FACTOR OF 3.E4 .
C
C  *** OUTPUT PARAMETERS ***
C    RS1 ARRAY RS1(N) CONTAINING THE REAL PARTS OF THE FIRST N COMPLEX
C        COEFFICIENTS (CORRESPONDING TO THE POWERS 0 TO N-1) OR DERIVA-
C        TIVES (ORDERS 0 TO N-1).
C    RS2 ARRAY RS2(N) CONTAINING THE IMAGINARY PARTS OF THE FIRST N
C        COEFFICIENTS (CORRESPONDING TO THE POWERS 0 TO N-1) OR DERIVA-
C        TIVES (ORDERS 0 TO N-1).
C    ERR REAL ARRAY ERR(N) CONTAINING ABSOLUTE ERROR ESTIMATES FOR THE
C        COMPLEX NUMBERS WHOSE REAL AND IMAGINARY PARTS ARE IN RS1,RS2.
C
      INTEGER IP(32), IW(7)
      DOUBLE PRECISION ANG,B,CM,CP,CT,CX,EPS,EPS0,EP6,FAC,FACT,PI,
     *                 RA,R1,S,SF,SP,SR,T,U,V,W
      DOUBLE PRECISION C(4),FC(3),SC(4)
      DOUBLE PRECISION A1(64),A2(64),FV1(6),FV2(6),RT1(51,3),RT2(51,3),
     *                 RV1(3),RV2(3)
      DOUBLE PRECISION DCPABS, DPMPAR
C
C  LIST OF THE VARIABLES INITIALIZED IN THE DATA STATEMENT BELOW.
C   IW   2**( 0 , 1 , 2 , 3 , 4 , 5 , 6 ) .
C   IP   PERMUTATION CONSTANTS FOR THE FFT.
C   RV1  REAL PARTS OF THE CONSTANTS FOR THE LAURENT SERIES TEST.
C   RV2  IMAGINARY PARTS OF THE CONSTANTS FOR THE LAURENT SERIES TEST.
C
      DATA IW(1),IW(2),IW(3),IW(4),IW(5),IW(6),IW(7)/1,2,4,8,16,32,64/
      DATA IP( 1),IP( 2),IP( 3),IP( 4),IP( 5),IP( 6),IP( 7),IP( 8),
     *     IP( 9),IP(10),IP(11),IP(12),IP(13),IP(14),IP(15),IP(16),
     *     IP(17),IP(18),IP(19),IP(20),IP(21),IP(22),IP(23),IP(24),
     *     IP(25),IP(26),IP(27),IP(28),IP(29),IP(30),IP(31),IP(32)/
     *     64,32,48,16,56,24,40,8,60,28,44,12,52,20,36,4,62,30,46,14,
     *     54,22,38,6,58,26,42,10,50,18,34,2/
      DATA RV1(1)/-.4D0/, RV2(1)/.3D0/,
     *     RV1(2)/ .7D0/, RV2(2)/.2D0/,
     *     RV1(3)/.02D0/, RV2(3)/-.06D0/
C
C  -------------------
C
C  ****** EPS0 IS A MACHINE DEPENDENT CONSTANT. EPS0 IS THE
C         SMALLEST NUMBER SUCH THAT 1 + EPS0 .GT. 1.
C
                    EPS0 = DPMPAR(1)
C
C  -------------------
C
C  INITIALIZATION.
C
      EPS = DMAX1(EPS0,TOL)
      SC(1) = .125D0
      C(1) = EPS**(1.D0/28.D0)
      EP6 = C(1)**6
      PI = 4.D0*DATAN(1.D0)
      FV1(1) = -1.D0
      FV2(1) =  0.D0
      FV1(2) =  0.D0
      FV2(2) = -1.D0
      R1 = DSQRT(0.5D0)
      RA = 1.D0/R1
      FV1(3) =  R1
      FV2(3) = -R1
      DO 10 I = 2,4
         SC(I) = 0.5D0*SC(I-1)
         C(I) = DSQRT(C(I-1))
         ANG = PI*SC(I-1)
         FV1(I + 2) =  DCOS(ANG)
   10    FV2(I + 2) = -DSIN(ANG)
C
C  START EXECUTION.
C
      IF (N .GT. 51 .OR. N .LT. 1) GO TO 260
      L2 = 1
      LF = 0
      NP = 0
      M = 0
      NR = -1
C
C  FIND IF A FFT OVER 8, 16, 32, OR 64 POINTS SHOULD BE USED.
C
      KL = 1
      IF (N .GT. 6) KL = 2
      IF (N .GT. 12) KL = 3
      IF (N .GT. 25) KL = 4
      KM = KL + 2
      KN = 7 - KM
      IX = IW(KM + 1)
      IS = IW(KN)
   30 U = R
      V = 0.D0
C
C  FUNCTION VALUES OF F ARE STORED READY PERMUTATED FOR THE FFT.
C
      DO 40 I = IS,32,IS
         IQ = IP(I)
         T = U*FV1(KM) - V*FV2(KM)
         V = U*FV2(KM) + V*FV1(KM)
         U = T
         CALL FUN(X + U, Y + V, A1(IQ), A2(IQ))
         CALL FUN(X - U, Y - V, A1(IQ-1), A2(IQ-1))
   40 CONTINUE
      LN = 2
      JN = 1
C
C  THE LOOP  DO 70 ... CONSTITUTES THE FFT.
C
      DO 70 L = 1,KM
         U = 1.0
         V = 0.0
         DO 60 J = 1,JN
            DO 50 I = J,IX,LN
               IT = I + JN
               S = U*A1(IT) - V*A2(IT)
               T = U*A2(IT) + V*A1(IT)
               A1(IT) = A1(I) - S
               A2(IT) = A2(I) - T
               A1(I) = A1(I) + S
   50          A2(I) = A2(I) + T
            T = U*FV1(L) - V*FV2(L)
            V = U*FV2(L) + V*FV1(L)
   60       U = T
         LN = LN + LN
   70    JN = JN + JN
      CX = 0.D0
      B = 1.D0
C
C  TEST ON HOW FAST THE COEFFICIENTS OBTAINED DECREASE.
C
      DO 80 I = 1,IX
         CT = DCPABS(A1(I),A2(I))/B
         IF (CT .LT. CX) GO TO 80
         CX = CT
         INR = I
   80    B = B*C(KL)
      IF (M .LE. 1) GO TO 100
C
C  ESTIMATE OF THE ROUNDING ERROR LEVEL FOR THE LAST RADIUS.
C
      ERR(1) = CX*EPS
      DO 90 I = 2,N
   90    ERR(I) = ERR(I-1)/R
C
  100 SF = SC(KL)
      DO 110 I = 1,IX
         A1(I) = SF*A1(I)
         A2(I) = SF*A2(I)
  110    SF = SF/R
      L1 = L2
      L2 = 1
      IF (INR .GT. IW(KM)) GO TO 150
      IF (LF .EQ. 1) GO TO 140
C
C  TEST IF THE SERIES IS A TAYLOR OR A LAURENT SERIES.
C
      SR = 0.D0
      SP = 0.D0
      DO 130 J = 1,3
         S = A1(IX)
         T = A2(IX)
         U = R*RV1(J)
         V = R*RV2(J)
         DO 120 I = 2,IX
            IA = IX + 1 - I
            W = (S*U - T*V) + A1(IA)
            T = (S*V + T*U) + A2(IA)
  120       S = W
         CP = DCPABS(S,T)
         IF (CP .GT. SP) SP = CP
         CALL FUN(X + U, Y + V, U, V)
         CM = DCPABS(S - U, T - V)
  130    IF (CM .GT. SR) SR = CM
      IF (SR .GT. 1.D-3*SP) GO TO 150
      LF = 1
  140 L2 = -1
C
C  DETERMINATION OF THE NEXT RADIUS TO BE USED.
C
  150 IF (NR .GE. 0) GO TO 160
         FACT = 2.D0
         IF (L2 .EQ. 1) FACT = 0.5D0
         L1 = L2
         NR = 0
  160 IF (L1 .NE. L2) GO TO 180
         IF (NR .GT. 0) GO TO 170
            NP = NP + 1
            IF (NP-15) 190,190,260
  170    FACT = 1.D0/FACT
  180 FACT = 1.D0/DSQRT(FACT)
      NR = NR + 1
  190 R = R*FACT
      M = NR - KL - 1
      IF (M .LE. 0) GO TO 30
C
C  THE RESULTS FOR THE LAST THREE RADII ARE STORED.
C
      DO 200 I = 1,N
         RT1(I,M) = A1(I)
  200    RT2(I,M) = A2(I)
      IF (M .EQ. 1) GO TO 220
C
C  EXTRAPOLATION.
C
      MM1 = M - 1
      DO 210 I = 1,N
         U = RT1(I,MM1) - RT1(I,M)
         V = RT2(I,MM1) - RT2(I,M)
         RT1(I,MM1) = RT1(I,M) - FC(MM1)*U
  210    RT2(I,MM1) = RT2(I,M) - FC(MM1)*V
      IF (M .EQ. 3) GO TO 230
C
C  CALCULATION OF THE EXTRAPOLATION CONSTANTS.
C
  220 FC(M) = 1.5D0 + DSIGN(0.5D0,FACT-1.D0)
      IF (M .EQ. 2) FC(M) = FC(M) + RA
      IF (FACT .GT. 1.D0) FC(M) = -FC(M)
      GO TO 30
  230 FC(3) = FC(1)*FC(2)/(FC(1) + FC(2) + 1.D0)
C
C  FINAL EXTRAPOLATION AND ERROR ESTIMATE.
C
      DO 240 I = 1,N
         U = RT1(I,1) - RT1(I,2)
         V = RT2(I,1) - RT2(I,2)
         ERR(I) = ERR(I) + EP6*DCPABS(U,V)
         RS1(I) = RT1(I,2) - FC(3)*U
  240    RS2(I) = RT2(I,2) - FC(3)*V
C
C  MULTIPLY POWER SERIES COEFFICIENTS AND ERROR ESTIMATE BY FACTORIALS
C  IF DERIVATIVES WANTED.
C
      IF (IC .EQ. 0) RETURN
      FAC = 0.D0
      FACT = 1.D0
      DO 250 I = 1,N
         RS1(I) = FACT*RS1(I)
         RS2(I) = FACT*RS2(I)
         ERR(I) = FACT*ERR(I)
         FAC = FAC + 1.D0
  250    FACT = FACT*FAC
      RETURN
C
C  ERROR RETURN.
C
  260 DO 270 I = 1,N
         RS1(I) = 0.D0
         RS2(I) = 0.D0
  270    ERR(I) = 1.D10
      RETURN
      END
      FUNCTION TRP(A,N,X,Y)
      DIMENSION X(N),Y(N)
C
      NM1 = N-1
      IF (A.LT.X(2)) GO TO 50
      IF (A.GE.X(NM1)) GO TO 40
      IL = 2
      IR = NM1
C
C     BISECTION SEARCH
C
   10 I = (IL+IR)/2
      IF (I.EQ.IL) GO TO 60
      IF (A-X(I)) 20,60,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     A.LT.X(2) .OR. A.GE.X(N-1)
C
   40 I = NM1
      GO TO 60
   50 I = 1
C
C     EVALUATION
C
   60 R = (A-X(I))/(X(I+1)-X(I))
      TRP = Y(I)+R*(Y(I+1)-Y(I))
      RETURN
      END
      SUBROUTINE LTRP (M,X,Y,N,XI,YI,NI,T,IERR)
C     ******************************************************************
C     LAGRANGE INTERPOLATION
C     ******************************************************************
      DIMENSION X(N),Y(N),XI(NI),YI(NI),T(M)
C
C     CHECK INPUT
C
      IF (M.LT.2) GO TO 130
      IF (M.GT.N) GO TO 131
      IF (NI.LT.1) GO TO 132
      IERR = 0
C
C     INITIALIZATION
C
      MM1 = M-1
      K  = 1
      XX = XI(1)
      ILOLD = 0
C
C     FIND THE SUBINTERVAL WHICH CONTAINS XX. I = 1 IF XX.LT.X(2)
C     AND I = N IF XX.GE.X(N). OTHERWISE X(I).LE.XX.LT.X(I+1).
C
      IF (XX-X(1)) 10,11,20
   10 I = 1
      IL = 1
      IR = M
      GO TO 80
   11 I = 1
      YI(K) = Y(1)
      GO TO 110
C
   20 IF (X(N)-XX) 21,22,23
   21 I = N
      IL = N-M+1
      IR = N
      GO TO 80
   22 I = N
      YI(K) = Y(N)
      GO TO 110
   23 IL = 1
      IR = N
C
C     BISECTION SEARCH
C
   30 I = (IL+IR)/2
      IF (I.EQ.IL) GO TO 50
      IF (XX-X(I)) 31,32,33
   31 IR = I
      GO TO 30
   32 YI(K) = Y(I)
      GO TO 110
   33 IL = I
      GO TO 30
C
C     LINEAR FORWARD SEARCH
C
   40 IF (XX-X(I+1)) 50,41,42
   41 I = I+1
      YI(K) = Y(I)
      GO TO 110
   42 I = I+1
      GO TO 40
C
C     POINT XX LIES IN THE OPEN SUBINTERVAL (X(I),X(I+1)).
C     FIND THE M CLOSEST POINTS X(IL),...,X(IR) TO XX.
C
   50 IF (I.GT.M) GO TO 51
      IL = 1
      NUM = I
      GO TO 60
   51 IL = I-M+1
      NUM = M
C
   60 IPM = I+M
      IF (IPM.LE.N) GO TO 61
      IR = N
      NUM = NUM+N-I
      GO TO 70
   61 IR = IPM
      NUM = NUM+M
C
   70 NUM = NUM-M
      IF (NUM.EQ.0) GO TO 80
      DL = XX-X(IL)
      DR = X(IR)-XX
      DO 72 L=1,NUM
      IF (DL.LE.DR) GO TO 71
      IL = IL+1
      DL = XX-X(IL)
      GO TO 72
   71 IR = IR-1
      DR = X(IR)-XX
   72 CONTINUE
C
C     COMPUTE THE COEFFICIENTS T(1),...,T(M) OF THE BACKWARD
C     NEWTON FORM OF THE INTERPOLATING POLYNOMIAL.
C
   80 IF (IL.EQ.ILOLD) GO TO 100
      ILOLD = IL
      ILM1 = IL-1
      DO 81 J=1,M
      L = ILM1+J
   81 T(J) = Y(L)
C
      DO 91 ISTEP=1,MM1
      JMAX = M-ISTEP
      DO 90 J=1,JMAX
      II = ILM1+J
      L = II+ISTEP
   90 T(J) = (T(J)-T(J+1))/(X(II)-X(L))
   91 CONTINUE
C
C     EVALUATION OF THE INTERPOLATING POLYNOMIAL
C
  100 YI(K) = T(1)
      DO 101 J=2,M
      L = ILM1+J
  101 YI(K) = T(J)+YI(K)*(XX-X(L))
C
C     NEXT POINT
C
  110 IF (K.GE.NI) RETURN
      K = K+1
      XX = XI(K)
      IF (XX-X(1)) 10,11,111
  111 IF (X(N)-XX) 21,22,120
C
  120 IF (XX-XI(K-1)) 121,122,40
  121 IL = 1
      IR = MIN0(I+1,N)
      GO TO 30
  122 YI(K) = YI(K-1)
      GO TO 110
C
C     ERROR RETURN
C
  130 IERR = 1
      RETURN
  131 IERR = 2
      RETURN
  132 IERR = 3
      RETURN
      END
      SUBROUTINE HTRP (N,X,Y,A,T,IERR)
C     ******************************************************************
C     HERMITE INTERPOLATION
C     ******************************************************************
      DIMENSION X(N),Y(N),A(N),T(N)
      IF (N.LE.0) GO TO 30
      IERR = 0
      A(1) = Y(1)
      IF (N.EQ.1) RETURN
      F = 1.0
      R = 0.0
      IEND = 0
      IBEG = 1
C
      DO 22 K=2,N
      IF (X(K)-X(K-1)) 10,20,10
C
   10 F = 1.0
      R = 0.0
      IEND = K-1
      IBEG = K
      T(1) = Y(K)
      DO 11 I=1,IEND
      DIFF = X(I)-X(K)
      IF (DIFF) 11,31,11
   11 T(I+1) = (A(I)-T(I))/DIFF
      GO TO 22
C
   20 R = R+1.0
      F = F*R
      T(1) = Y(K)/F
      IF (IEND.EQ.0) GO TO 22
      DO 21 I=1,IEND
   21 T(I+1) = (T(I+1)-T(I))/(X(I)-X(K))
   22 A(K) = T(IBEG)
      RETURN
C
   30 IERR = 1
      RETURN
   31 IERR = 2
      T(1) = I
      T(2) = K
      RETURN
      END
      SUBROUTINE PCOEFF(ALPHA,N,X,A,C,T)
      REAL X(*),A(N),C(N)
      DOUBLE PRECISION XX,R,T(N)
      IF (N.GT.1) GO TO 10
      C(1) = A(1)
      RETURN
C
   10 XX = ALPHA
      NM1 = N-1
      DO 11 I=1,N
   11 T(I) = A(I)
C
      DO 21 I=1,NM1
      J = N-I
      R = XX-DBLE(X(J))
      DO 20 K=J,NM1
   20 T(K) = T(K)+R*T(K+1)
   21 CONTINUE
C
      DO 30 I=1,N
   30 C(I) = T(I)
      RETURN
      END
      SUBROUTINE PFIT(ND,NP,X,Y,A,RNORM,PHI,PHIX,IERR)
C     ******************************************************************
C     UNWEIGHTED LEAST SQUARES POLYNOMIAL FIT
C     ******************************************************************
      REAL X(NP),Y(NP),A(*),PHI(2,*),PHIX(4,NP)
      REAL LAMBDA
      DOUBLE PRECISION DALPHA,DSUM
C     ---------------------
      IERR=0
      IF (1.LE.ND.AND.ND.LT.NP) GO TO 10
      IERR=1
      RETURN
C
C                      INITIALIZATION
C
   10 ND1=ND+1
      DO 11 K=1,ND1
      A(K)=0.0
      PHI(1,K)=0.0
   11 PHI(2,K)=0.0
C
C                SET Z=A+B*X WHERE ABS(Z).LE.1
C
      XMIN=X(1)
      XMAX=X(1)
      DO 21 K=2,NP
      IF (X(K).GE.XMIN) GO TO 20
      XMIN=X(K)
      GO TO 21
   20 IF (X(K).GT.XMAX) XMAX=X(K)
   21 CONTINUE
      ZB=2.0/(XMAX-XMIN)
      ZA=-XMIN*ZB-1.0
      DO 22 K=1,NP
   22 PHIX(3,K)=ZA+ZB*X(K)
C
C           COMPUTE THE CLOSEST POLYNOMIAL OF DEGREE 0
C
      LAMBDA=NP
      PHI(1,1)=1.0/SQRT(LAMBDA)
      DALPHA=0.D0
      DSUM=0.D0
      DO 30 K=1,NP
      PHIX(1,K)=PHI(1,1)
      DALPHA=DALPHA+DBLE(PHIX(3,K))
   30 DSUM=DSUM+DBLE(Y(K))
      ALPHA=SNGL(DALPHA)/LAMBDA
      A(1)=SNGL(DSUM)/LAMBDA
      DO 31 K=1,NP
   31 PHIX(4,K)=A(1)
C
      LA=2
      LB=1
      DO 90 M=1,ND
      MP1=M+1
C
C          GENERATE LAMBDA(M)*PHI(M) AND EVALUATE IT AT Z
C
      IF (M.NE.1) GO TO 50
      PHI(2,1)=-ALPHA*PHI(1,1)
      PHI(2,2)=PHI(1,1)
      DO 40 K=1,NP
   40 PHIX(2,K)=(PHIX(3,K)-ALPHA)*PHI(1,1)
      GO TO 60
C
   50 C=0.0
      DO 51 K=1,M
      PHI(LA,K)=DBLE(C)-DBLE(ALPHA*PHI(LB,K))-DBLE(LAMBDA*PHI(LA,K))
   51 C=PHI(LB,K)
      PHI(LA,MP1)=C
      DO 52 K=1,NP
   52 PHIX(LA,K)=(PHIX(3,K)-ALPHA)*PHIX(LB,K)-LAMBDA*PHIX(LA,K)
C
C                COMPUTE ALPHA(M) AND LAMBDA(M)
C
   60 DALPHA=0.D0
      DSUM=0.D0
      DO 61 K=1,NP
      C=PHIX(LA,K)*PHIX(LA,K)
      DALPHA=DALPHA+DBLE(C*PHIX(3,K))
   61 DSUM=DSUM+DBLE(C)
      LAMBDA=DSUM
      ALPHA=SNGL(DALPHA)/LAMBDA
      LAMBDA=SQRT(LAMBDA)
C
C              GENERATE PHI(M) AND EVALUATE IT AT Z
C
      DO 70 K=1,MP1
   70 PHI(LA,K)=PHI(LA,K)/LAMBDA
      DO 71 K=1,NP
   71 PHIX(LA,K)=PHIX(LA,K)/LAMBDA
C
C        COMPUTE THE CLOSEST POLYNOMIAL OF DEGREE M OR LESS
C                     AND EVALUATE IT AT Z
C
      DSUM=0.D0
      DO 80 K=1,NP
   80 DSUM=DSUM+DBLE((Y(K)-PHIX(4,K))*PHIX(LA,K))
      C=DSUM
      DO 81 K=1,MP1
   81 A(K)=A(K)+C*PHI(LA,K)
      DO 82 K=1,NP
   82 PHIX(4,K)=PHIX(4,K)+C*PHIX(LA,K)
C
      LS=LA
      LA=LB
   90 LB=LS
C
C                        COMPUTE RNORM
C
      DSUM=0.D0
      DO 95 K=1,NP
   95 DSUM=DSUM+DBLE((Y(K)-PHIX(4,K))**2)
      RNORM=SQRT(SNGL(DSUM))
C
C        CONVERT THE CLOSEST POLYNOMIAL FROM A POLYNOMIAL
C                  IN Z TO A POLYNOMIAL IN X
C
      A(1)=A(1)+ZA*A(2)
      A(2)=ZB*A(2)
      IF (ND.EQ.1) RETURN
      PHI(1,1)=ZA
      PHI(1,2)=ZB
      DO 102 M=2,ND
      MP1=M+1
      C=0.0
      DO 100 K=1,M
      TEMP=PHI(1,K)*ZB
      PHI(1,K)=PHI(1,K)*ZA+C
  100 C=TEMP
      PHI(1,MP1)=C
      DO 101 K=1,M
  101 A(K)=A(K)+A(MP1)*PHI(1,K)
  102 A(MP1)=A(MP1)*PHI(1,MP1)
      RETURN
      END
      SUBROUTINE WPFIT(ND,NP,X,Y,W,A,RNORM,PHI,PHIX,IERR)
C     ******************************************************************
C     WEIGHTED LEAST SQUARES POLYNOMIAL FIT
C     ******************************************************************
      REAL X(NP),Y(NP),W(NP),A(*),PHI(2,*),PHIX(4,NP)
      REAL LAMBDA
      DOUBLE PRECISION DALPHA,DSUM
C     ---------------------
C
C                      ERROR CHECKING
C
      IF (ND.LT.1.OR.NP.LT.2) GO TO 200
      NW=0
      DSUM=0.D0
      DO 13 K=1,NP
      IF (W(K)) 202,13,10
   10 NW=NW+1
      DSUM=DSUM+DBLE(W(K))
      IF (NW.GT.1) GO TO 11
      XMIN=X(K)
      XMAX=X(K)
      GO TO 13
   11 IF (X(K).GE.XMIN) GO TO 12
      XMIN=X(K)
      GO TO 13
   12 IF (X(K).GT.XMAX) XMAX=X(K)
   13 CONTINUE
      IF (ND.GE.NW) GO TO 200
C
C                      INITIALIZATION
C
      IERR=0
      ND1=ND+1
      DO 20 K=1,ND1
      A(K)=0.0
      PHI(1,K)=0.0
   20 PHI(2,K)=0.0
C
C                SET Z=A+B*X WHERE ABS(Z).LE.1
C
      ZB=2.0/(XMAX-XMIN)
      ZA=-XMIN*ZB-1.0
      DO 25 K=1,NP
   25 PHIX(3,K)=ZA+ZB*X(K)
C
C           COMPUTE THE CLOSEST POLYNOMIAL OF DEGREE 0
C
      LAMBDA=DSUM
      PHI(1,1)=1.0/SQRT(LAMBDA)
      DALPHA=0.D0
      DSUM=0.D0
      DO 30 K=1,NP
      PHIX(1,K)=PHI(1,1)
      DALPHA=DALPHA+DBLE(W(K)*PHIX(3,K))
   30 DSUM=DSUM+DBLE(W(K)*Y(K))
      ALPHA=SNGL(DALPHA)/LAMBDA
      A(1)=SNGL(DSUM)/LAMBDA
      DO 31 K=1,NP
   31 PHIX(4,K)=A(1)
C
      LA=2
      LB=1
      DO 90 M=1,ND
      MP1=M+1
C
C          GENERATE LAMBDA(M)*PHI(M) AND EVALUATE IT AT Z
C
      IF (M.NE.1) GO TO 50
      PHI(2,1)=-ALPHA*PHI(1,1)
      PHI(2,2)=PHI(1,1)
      DO 40 K=1,NP
   40 PHIX(2,K)=(PHIX(3,K)-ALPHA)*PHI(1,1)
      GO TO 60
C
   50 C=0.0
      DO 51 K=1,M
      PHI(LA,K)=DBLE(C)-DBLE(ALPHA*PHI(LB,K))-DBLE(LAMBDA*PHI(LA,K))
   51 C=PHI(LB,K)
      PHI(LA,MP1)=C
      DO 52 K=1,NP
   52 PHIX(LA,K)=(PHIX(3,K)-ALPHA)*PHIX(LB,K)-LAMBDA*PHIX(LA,K)
C
C                COMPUTE ALPHA(M) AND LAMBDA(M)
C
   60 DALPHA=0.D0
      DSUM=0.D0
      DO 61 K=1,NP
      C=W(K)*PHIX(LA,K)*PHIX(LA,K)
      DALPHA=DALPHA+DBLE(C*PHIX(3,K))
   61 DSUM=DSUM+DBLE(C)
      LAMBDA=DSUM
      ALPHA=SNGL(DALPHA)/LAMBDA
      LAMBDA=SQRT(LAMBDA)
C
C              GENERATE PHI(M) AND EVALUATE IT AT Z
C
      DO 70 K=1,MP1
   70 PHI(LA,K)=PHI(LA,K)/LAMBDA
      DO 71 K=1,NP
   71 PHIX(LA,K)=PHIX(LA,K)/LAMBDA
C
C        COMPUTE THE CLOSEST POLYNOMIAL OF DEGREE M OR LESS
C                     AND EVALUATE IT AT Z
C
      DSUM=0.D0
      DO 80 K=1,NP
   80 DSUM=DSUM+DBLE(W(K)*(Y(K)-PHIX(4,K))*PHIX(LA,K))
      C=DSUM
      DO 81 K=1,MP1
   81 A(K)=A(K)+C*PHI(LA,K)
      DO 82 K=1,NP
   82 PHIX(4,K)=PHIX(4,K)+C*PHIX(LA,K)
C
      LS=LA
      LA=LB
   90 LB=LS
C
C                        COMPUTE RNORM
C
      DSUM=0.D0
      DO 95 K=1,NP
   95 DSUM=DSUM+DBLE(W(K)*(Y(K)-PHIX(4,K))**2)
      RNORM=SQRT(SNGL(DSUM))
C
C        CONVERT THE CLOSEST POLYNOMIAL FROM A POLYNOMIAL
C                  IN Z TO A POLYNOMIAL IN X
C
      A(1)=A(1)+ZA*A(2)
      A(2)=ZB*A(2)
      IF (ND.EQ.1) RETURN
      PHI(1,1)=ZA
      PHI(1,2)=ZB
      DO 102 M=2,ND
      MP1=M+1
      C=0.0
      DO 100 K=1,M
      TEMP=PHI(1,K)*ZB
      PHI(1,K)=PHI(1,K)*ZA+C
  100 C=TEMP
      PHI(1,MP1)=C
      DO 101 K=1,M
  101 A(K)=A(K)+A(MP1)*PHI(1,K)
  102 A(MP1)=A(MP1)*PHI(1,MP1)
      RETURN
C
C                        ERROR RETURN
C
  200 IERR=1
      RETURN
  202 IERR=3
      RETURN
      END
      SUBROUTINE CBSPL (X, Y, A, B, C, N, IBEG, IEND, ALPHA, BETA, IERR)
C-----------------------------------------------------------------------
C                   CUBIC SPLINE INTERPOLATION
C-----------------------------------------------------------------------
      REAL X(N), Y(N), A(N), B(N), C(N)
C
      IF (N .LT. 3) GO TO 200

C     A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(I) OF
C     F AT X(I), I=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS
C     ELIMINATION, WITH S(I) ENDING UP IN A(I) FOR ALL I. A, B, C
C     ARE USED INITIALLY FOR WORK SPACES.
C
      DO 10 M = 2,N
         B(M) = X(M) - X(M-1)
         IF (B(M) .LE. 0.0) GO TO 210
         C(M) = (Y(M) - Y(M-1))/B(M)
   10 CONTINUE
      IERR = 0
C
C     CONSTRUCT THE FIRST EQUATION FROM THE BOUNDARY CONDITION, OF
C     THE FORM
C
C             C(1)*S(1) + B(1)*S(2) = A(1)
C
      IF (IBEG - 1) 20,30,40
C
C     NO CONDITION AT LEFT END.
C
   20 C(1) = B(3)
      B(1) = X(3) - X(1)
      A(1) = ((B(2) + 2.0*B(1))*B(3)*C(2) + B(2)*B(2)*C(3))/B(1)
      GO TO 50
C
C     SLOPE PRESCRIBED AT LEFT END.
C
   30 C(1) = 1.0
      B(1) = 0.0
      A(1) = ALPHA
      GO TO 50
C
C     SECOND DERIVATIVE PRESCRIBED AT LEFT END.
C
   40 C(1) = 2.0
      B(1) = 1.0
      A(1) = 3.0*C(2) - 0.5*ALPHA*B(2)
C
C     FOR THE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
C     CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE
C     M-TH EQUATION READS  C(M)*S(M) + B(M)*S(M+1) = A(M).
C
   50 NM1 = N - 1
      DO 51 M = 2,NM1
         T = -B(M+1)/C(M-1)
         A(M) = T*A(M-1) + 3.0*(B(M)*C(M+1) + B(M+1)*C(M))
         C(M) = T*B(M-1) + 2.0*(B(M) + B(M+1))
   51 CONTINUE
C
C     IF THE SLOPE AT THE RIGHT END IS GIVEN, THEN SET A(N) TO THE
C     SLOPE AND GO TO BACK SUBSTITUTION. OTHERWISE, CONSTRUCT THE
C     LAST EQUATION FROM THE SECOND BOUNDARY CONDITION, OF THE FORM
C
C                R*S(N-1) + C(N)*S(N) = A(N)
C
      IF (IEND - 1) 60,80,90
   60 IF (N .EQ. 3 .AND. IBEG .EQ. 0) GO TO 70
C
C     NO CONDITION AT THE RIGHT END. EITHER  N .GE. 4  OR
C     THERE IS A CONDITION AT THE LEFT END.
C
      R = X(N) - X(N-2)
      DEL  = (Y(NM1) - Y(N-2))/B(NM1)
      A(N) = ((B(N) + 2.0*R)*B(NM1)*C(N) + B(N)*B(N)*DEL)/R
      C(N) = B(NM1)
      GO TO 100
C
C     NO CONDITIONS AT THE END POINTS AND N = 3. IN THIS CASE,
C     THE SECOND BOUNDARY CONDITION DOES NOT PROVIDE US WITH A
C     NEW EQUATION. FOR CONVENIENCE, WE USE THE FOLLOWING...
C
   70 A(N) = 2.0*C(N)
      C(N) = 1.0
      R = 1.0
      GO TO 100
C
C     SLOPE PRESCRIBED AT RIGHT END.
C
   80 A(N) = BETA
      GO TO 110
C
C     SECOND DERIVATIVE PRESCRIBED AT RIGHT END.
C
   90 A(N) = 3.0*C(N) + 0.5*BETA*B(N)
      C(N) = 2.0
      R = 1.0
C
C     COMPLETE FORWARD PASS OF GAUSS ELIMINATION.
C
  100 T = -R/C(NM1)
      A(N) = (T*A(NM1) + A(N))/(T*B(NM1) + C(N))
C
C     CARRY OUT BACK SUBSTITUTION.
C
  110 DO 120 I = 1,NM1
         J = N - I
         A(J) = (A(J) - B(J)*A(J+1))/C(J)
  120 CONTINUE
C
C     GENERATE THE CUBIC COEFFICIENTS B(I) AND C(I).
C
      DO 130 I = 1,NM1
         H = B(I+1)
         DEL = (Y(I+1) - Y(I))/H
         T = A(I) + A(I+1) - 2.0*DEL
         B(I) = (DEL - A(I) - T)/H
         C(I) = (T/H)/H
  130 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = 1
      RETURN
  210 IERR = 2
      RETURN
      END
      SUBROUTINE SPLIFT (X,Y,YP,YPP,N,W,IERR,ISX,A1,B1,AN,BN)
C
C     WRITTEN BY RONDALL E. JONES
C        SANDIA LABORATORIES
C        ALBUQUERQUE, NEW MEXICO  87115
C        JANUARY 1976
C
C     ABSTRACT
C         SPLIFT FITS AN INTERPOLATING CUBIC SPLINE TO THE N DATA POINTS
C         GIVEN IN X AND Y AND RETURNS THE FIRST AND SECOND DERIVATIVES
C         IN YP AND YPP.
C
C     DESCRIPTION OF ARGUMENTS
C
C       --INPUT--
C
C         X    - ARRAY OF ABSCISSAS OF DATA (IN INCREASING ORDER)
C         Y    - ARRAY OF ORDINATES OF DATA
C         N    - THE NUMBER OF DATA POINTS.  THE ARRAYS X, Y, YP, AND
C                YPP MUST BE DIMENSIONED AT LEAST N.  (N .GE. 4)
C         ISX  - MUST BE ZERO ON THE INITIAL CALL TO SPLIFT.
C                IF A SPLINE IS TO BE FITTED TO A SECOND SET OF DATA
C                THAT HAS THE SAME SET OF ABSCISSAS AS A PREVIOUS SET,
C                AND IF THE CONTENTS OF W HAVE NOT BEEN CHANGED SINCE
C                THAT PREVIOUS FIT WAS COMPUTED, THEN ISX MAY BE
C                SET TO ONE FOR FASTER EXECUTION.
C         A1,B1,AN,BN - SPECIFY THE END CONDITIONS FOR THE SPLINE WHICH
C                ARE EXPRESSED AS CONSTRAINTS ON THE SECOND DERIVATIVE
C                OF THE SPLINE AT THE END POINTS (SEE YPP).
C                THE END CONDITION CONSTRAINTS ARE
C                        YPP(1) = A1*YPP(2) + B1
C                AND
C                        YPP(N) = AN*YPP(N-1) + BN
C                WHERE
C                        ABS(A1).LT. 1.0  AND  ABS(AN).LT. 1.0.
C
C                THE SMOOTHEST SPLINE (I.E., LEAST INTEGRAL OF SQUARE
C                OF SECOND DERIVATIVE) IS OBTAINED BY A1=B1=AN=BN=0.
C                IN THIS CASE THERE IS AN INFLECTION AT X(1) AND X(N).
C                IF THE DATA IS TO BE EXTRAPOLATED (SAY, BY USING SPLINT
C                TO EVALUATE THE SPLINE OUTSIDE THE RANGE X(1) TO X(N)),
C                THEN TAKING A1=AN=0.5 AND B1=BN=0 MAY YIELD BETTER
C                RESULTS.  IN THIS CASE THERE IS AN INFLECTION
C                AT X(1) - (X(2)-X(1)) AND AT X(N) + (X(N)-X(N-1)).
C                IN THE MORE GENERAL CASE OF A1=AN=A  AND B1=BN=0,
C                THERE IS AN INFLECTION AT X(1) - (X(2)-X(1))*A/(1.0-A)
C                AND AT X(N) + (X(N)-X(N-1))*A/(1.0-A).
C
C                A SPLINE THAT HAS A GIVEN FIRST DERIVATIVE YP1 AT X(1)
C                AND YPN AT Y(N) MAY BE DEFINED BY USING THE
C                FOLLOWING CONDITIONS.
C
C                A1=-0.5
C
C                B1= 3.0*((Y(2)-Y(1))/(X(2)-X(1))-YP1)/(X(2)-X(1))
C
C                AN=-0.5
C
C                BN=-3.0*((Y(N)-Y(N-1))/(X(N)-X(N-1))-YPN)/(X(N)-X(N-1))
C
C       --OUTPUT--
C
C         YP   - ARRAY OF FIRST DERIVATIVES OF SPLINE (AT THE X(I))
C         YPP  - ARRAY OF SECOND DERIVATIVES OF SPLINE (AT THE X(I))
C         IERR - A STATUS CODE
C              --NORMAL CODE
C                 0 MEANS THAT THE REQUESTED SPLINE WAS COMPUTED.
C              --ABNORMAL CODES
C                 1 MEANS THAT ABS(A1) OR ABS(AN) WAS .GE. 1.
C                 2 MEANS THAT N, THE NUMBER OF POINTS, WAS .LT. 4.
C                 3 MEANS THE ABSCISSAS WERE NOT STRICTLY INCREASING.
C
C       --WORK--
C
C         W    - ARRAY OF WORKING STORAGE DIMENSIONED AT LEAST 3N.
C
      REAL X(N), Y(N), YP(N), YPP(N), W(N,3)
C
      IF (ABS(A1) .GE. 1.0 .OR. ABS(AN) .GE. 1.0) GO TO 100
      IF (N .LT. 4) GO TO 200
      NM1 = N - 1
      NM2 = N - 2
      IF (ISX .GT. 0) GO TO 40
      DO 10 I = 2,N
         IF (X(I) .LE. X(I-1)) GO TO 300
   10 CONTINUE
C
C     DEFINE THE TRIDIAGONAL MATRIX
C
      W(1,3) = X(2) - X(1)
      DO 20 I = 2,NM1
         W(I,2) = W(I-1,3)
         W(I,3) = X(I+1) - X(I)
         W(I,1) = 2.0*(W(I,2) + W(I,3))
   20 CONTINUE
      W(1,1) = 4.0
      W(1,3) =-4.0*A1
      W(N,1) = 4.0
      W(N,2) =-4.0*AN
C
C     LU DECOMPOSITION
C
      DO 30 I = 2,N
         W(I-1,3) = W(I-1,3)/W(I-1,1)
         W(I,1)   = W(I,1) - W(I,2)*W(I-1,3)
   30 CONTINUE
C
C     DEFINE *CONSTANT* VECTOR
C
   40 YPP(1) = 4.0*B1
      DOLD = (Y(2) - Y(1))/W(2,2)
      DO 50 I = 2,NM2
         DNEW   = (Y(I+1) - Y(I))/W(I+1,2)
         YPP(I) = 6.0*(DNEW - DOLD)
         YP(I)  = DOLD
         DOLD   = DNEW
   50 CONTINUE
      DNEW = (Y(N) - Y(NM1))/(X(N) - X(NM1))
      YPP(NM1) = 6.0*(DNEW - DOLD)
      YPP(N) = 4.0*BN
      YP(NM1)= DOLD
      YP(N)  = DNEW
C
C     FORWARD SUBSTITUTION
C
      YPP(1) = YPP(1)/W(1,1)
      DO 60 I = 2,N
         YPP(I) = (YPP(I) - W(I,2)*YPP(I-1))/W(I,1)
   60 CONTINUE
C
C     BACKWARD SUBSTITUTION
C
      DO 70 J = 1,NM1
         I = N - J
         YPP(I) = YPP(I) - W(I,3)*YPP(I+1)
   70 CONTINUE
C
C     COMPUTE FIRST DERIVATIVES
C
      H = X(2) - X(1)
      YP(1) = (Y(2) - Y(1))/H - H*(2.0*YPP(1) + YPP(2))/6.0
      DO 80 I = 2,NM1
         YP(I) = YP(I) + W(I,2)*(YPP(I-1) + 2.0*YPP(I))/6.0
   80 CONTINUE
      YP(N) = YP(N) + (X(N) - X(NM1))*(YPP(NM1) + 2.0*YPP(N))/6.0
      IERR = 0
      RETURN
C
  100 IERR = 1
      RETURN
  200 IERR = 2
      RETURN
  300 IERR = 3
      RETURN
      END
      SUBROUTINE SPFIT (X, Y, WGT, M, BREAK, L, Z, A, B, C, WK, IERR)
C-----------------------------------------------------------------------
C            WEIGHTED LEAST SQUARES CUBIC SPLINE FITTING
C-----------------------------------------------------------------------
      REAL X(M), Y(M), WGT(M), BREAK(L)
      REAL Z(*), A(*), B(*), C(*), WK(*)
      REAL TEMP(20)
C---------------------
C     REAL Z(L-1), A(L-1), B(L-1), C(L-1), WK(7*L + 18)
C---------------------
      IF (L .LT. 2) GO TO 100
      N = L + 2
C
C                DEFINE THE KNOTS FOR THE B-SPLINES
C
      WK(1) = BREAK(1)
      WK(2) = BREAK(1)
      WK(3) = BREAK(1)
      WK(4) = BREAK(1)
      DO 10 J = 2,L
         IF (BREAK(J - 1) .GE. BREAK(J)) GO TO 110
         WK(J + 3) = BREAK(J)
   10 CONTINUE
      WK(L + 4) = BREAK(L)
      WK(L + 5) = BREAK(L)
      WK(L + 6) = BREAK(L)
C
C     OBTAIN THE B-SPLINE COEFFICIENTS OF THE LEAST SQUARES FIT
C
      LA = N + 5
      LW = LA + N
      LQ = LW + N
      CALL BSLSQ (X, Y, WGT, M, WK(1), N, 4, WK(LA),
     *            WK(LW), WK(LQ), IERR)
      IF (IERR .LT. 0) GO TO 120
      IERR = 0
C
C     OBTAIN THE COEFFICIENTS OF THE FIT IN TAYLOR SERIES FORM
C
      CALL BSPP (WK(1), WK(LA), N, 4, BREAK,
     *             WK(LQ), LM1, TEMP)
      K = LQ
      DO 20 J = 1,LM1
         Z(J) = WK(K)
         A(J) = WK(K + 1)
         B(J) = WK(K + 2)
         C(J) = WK(K + 3)
         K = K + 4
   20 CONTINUE
      RETURN
C
C                       ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
      END
      SUBROUTINE CSPFIT (X, Y, M, BREAK, L, XCON, CON, NDER, NC,
     *                   Z, A, B, C, WK, IWK, IERR)
C-----------------------------------------------------------------------
C                LEAST SQUARES CUBIC SPLINE FITTING WITH
C                  EQUALITY AND INEQUALITY CONSTRAINTS
C-----------------------------------------------------------------------
      REAL X(M), Y(M), BREAK(L)
      REAL XCON(*), CON(*)
      REAL Z(*), A(*), B(*), C(*), WK(*)
      INTEGER NDER(*), IWK(*)
C
      REAL TEMP(20)
C---------------------
C     XCON, CON, NDER ARE ARRAYS OF DIMENSION MAX(1,NC).
C     Z, A, B, C ARE ARRAYS OF DIMENSION L - 1.
C     WK AND IWK ARE ARRAYS OF DIMENSION IWK(1) AND IWK(2)
C        RESPECTIVELY. IT IS REQUIRED THAT IWK(2) .GE. 2
C        AND IWK(1) .GE. 7(L + 7) FOR ALL NC. IF NC .GE. 1
C        THEN MORE STORAGE WILL BE NEEDED.
C---------------------
      IF (L .LT. 2) GO TO 100
      N = L + 2
C
C                DEFINE THE KNOTS FOR THE B-SPLINES
C
      WK(1) = BREAK(1)
      WK(2) = BREAK(1)
      WK(3) = BREAK(1)
      WK(4) = BREAK(1)
      DO 10 J = 2,L
         IF (BREAK(J - 1) .GE. BREAK(J)) GO TO 110
         WK(J + 3) = BREAK(J)
   10 CONTINUE
      WK(L + 4) = BREAK(L)
      WK(L + 5) = BREAK(L)
      WK(L + 6) = BREAK(L)
C
C     OBTAIN THE B-SPLINE COEFFICIENTS OF THE LEAST SQUARES FIT
C
      K = 7*N + 35
      IF (IWK(1) .LT. K) GO TO 120
      LA = N + 5
      LW = LA + N
      IERR = 0
C
      K = LW - 1
      IWK(1) = IWK(1) - K
      CALL BFIT (WK(1), N, 4, X, Y, M, XCON, CON, NDER, NC, IERR,
     *           WK(LA), R, WK(LW), IWK)
      IWK(1) = IWK(1) + K
      IF (IERR .LT. 0 .OR. IERR .EQ. 2) RETURN
C
C     OBTAIN THE COEFFICIENTS OF THE FIT IN TAYLOR SERIES FORM
C
      CALL BSPP (WK(1), WK(LA), N, 4, BREAK,
     *             WK(LW), LM1, TEMP)
      K = LW
      DO 20 J = 1,LM1
         Z(J) = WK(K)
         A(J) = WK(K + 1)
         B(J) = WK(K + 2)
         C(J) = WK(K + 3)
         K = K + 4
   20 CONTINUE
      RETURN
C
C                       ERROR RETURN
C
  100 IERR = -1
      RETURN
C
  110 IERR = -3
      RETURN
C
  120 IERR = -6
      IWK(1) = K
      RETURN
      END
      SUBROUTINE SCOMP (X,Y,A,B,C,N,XI,YI,NI,IERR)
C
C     ABSTRACT
C
C         SCOMP EVALUATES A CUBIC SPLINE AT THE ABSCISSAS IN XI.
C         IT IS ASSUMED THAT THE COEFFICIENTS OF THE POLYNOMIALS
C         WHICH FORM THE SPLINE ARE PROVIDED.
C
C     DESCRIPTION OF ARGUMENTS
C
C       --INPUT--
C
C         X   - ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER)
C               THAT DEFINE THE SPLINE.
C         Y   - ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE.
C         A,B,C ARRAYS THAT CONTAIN THE COEFFICIENTS OF THE POLYNOMIALS
C               WHICH FORM THE SPLINE. IF I = 1,...,N  THEN THE SPLINE
C               HAS THE VALUE
C                    Y(I) + A(I)*DX + B(I)*DX**2 + C(I)*DX**3
C               FOR X(I) .LE. XX .LE. X(I+1).  HERE DX = XX-X(I).
C         N   - THE NUMBER OF POLYNOMIALS THAT DEFINE THE SPLINE.
C               THE ARRAYS X, Y, A, B, C  MUST BE DIMENSIONED AT
C               LEAST N.  N MUST BE GREATER THAN OR EQUAL TO 1.
C         XI  - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER)
C               AT WHICH THE SPLINE IS TO BE EVALUATED.
C         NI  - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE
C               EVALUATED.  IF NI IS GREATER THAN 1 THEN XI AND YI
C               MUST BE ARRAYS OF DIMENSION NI OR LARGER.
C               IT IS ASSUMED THAT NI IS GREATER THAN OR EQUAL TO 1.
C
C       --OUTPUT--
C
C         YI  - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI.
C         IERR- STATUS CODE
C               0  THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI.
C               1  INPUT ERROR - NI IS NOT POSITIVE.
C
      REAL X(N), Y(N), A(N), B(N), C(N), XI(NI), YI(NI)
C
C     CHECK INPUT
C
      IF (NI .GT. 0) GO TO 1
         IERR = 1
         RETURN
    1 IERR = 0
C
C     K IS INDEX ON VALUE OF XI BEING WORKED ON.  XX IS THAT VALUE.
C     I IS CURRENT INDEX INTO X ARRAY.
C
      K  = 1
      XX = XI(1)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(N)) GO TO 80
      IL = 1
      IR = N
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 100
      IF (XX - X(I)) 20,100,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   50 IF (XX .LT. X(I+1)) GO TO 100
      I = I + 1
      GO TO 50
C
C     XX IS GREATER THAN X(N) OR LESS THAN X(1)
C
   80 I = N
      GO TO 100
   90 I = 1
C
C     EVALUATION
C
  100 DX = XX - X(I)
      YI(K) = Y(I) + DX*(A(I) + DX*(B(I) + DX*C(I)))
C
C     NEXT POINT
C
      IF (K .GE. NI) RETURN
      K = K + 1
      XX = XI(K)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(N)) GO TO 80
      IF (XX - XI(K-1)) 110,100,50
  110 IL = 1
      IR = MIN0(I+1,N)
      GO TO 10
      END
      SUBROUTINE SCOMP1 (X,Y,YP,N,XI,YI,NI,IERR)
C
C     ABSTRACT
C
C         SCOMP1 EVALUATES A CUBIC SPLINE AT THE ABSCISSAS IN XI.
C         IT IS ASSUMED THAT THE FIRST DERIVATIVES AT THE NODES
C         HAVE BEEN PROVIDED.
C
C     DESCRIPTION OF ARGUMENTS
C
C       --INPUT--
C
C         X   - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE THE
C               SPLINE.
C         Y   - ARRAY OF ORDINATES THAT DEFINE THE SPLINE.
C         YP  - ARRAY OF FIRST DERIVATIVES THAT DEFINE THE SPLINE.
C         N   - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE.
C               THE ARRAYS X, Y, AND YP MUST BE DIMENSIONED AT LEAST N.
C               N MUST BE GREATER THAN OR EQUAL TO 2.
C         XI  - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER)
C               AT WHICH THE SPLINE IS TO BE EVALUATED.
C         NI  - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE
C               EVALUATED.  IF NI IS GREATER THAN 1 THEN XI AND YI
C               MUST BE ARRAYS OF DIMENSION NI OR LARGER.
C               IT IS ASSUMED THAT NI IS GREATER THAN OR EQUAL TO 1.
C
C       --OUTPUT--
C
C         YI  - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI.
C         IERR- STATUS CODE
C               0  THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI.
C               1  INPUT ERROR - NI IS NOT POSITIVE.
C
      REAL X(N), Y(N), YP(N), XI(NI), YI(NI)
C
C     CHECK INPUT
C
      IF (NI .GT. 0) GO TO 1
         IERR = 1
         RETURN
    1 IERR = 0
      NM1 = N - 1
C
C     K IS INDEX ON VALUE OF XI BEING WORKED ON.  XX IS THAT VALUE.
C     I IS CURRENT INDEX INTO X ARRAY.
C
      K  = 1
      XX = XI(1)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(NM1)) GO TO 80
      IL = 1
      IR = NM1
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 100
      IF (XX - X(I)) 20,100,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   50 IF (XX .LT. X(I+1)) GO TO 100
      I = I + 1
      GO TO 50
C
C     XX IS GREATER THAN X(N) OR LESS THAN X(1)
C
   80 I = NM1
      GO TO 100
   90 I = 1
C
C     EVALUATION
C
  100 H = X(I+1) - X(I)
      D = (Y(I+1) - Y(I))/H
      A = YP(I) + YP(I+1)
      B = (-A - YP(I) + 3.0*D)/H
      C = (A - D - D)/(H*H)
      DX = XX - X(I)
      YI(K) = Y(I) + DX*(YP(I) + DX*(B + DX*C))
C
C     NEXT POINT
C
      IF (K .GE. NI) RETURN
      K = K + 1
      XX = XI(K)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(NM1)) GO TO 80
      IF (XX - XI(K-1)) 110,100,50
  110 IL = 1
      IR = MIN0(I+1,NM1)
      GO TO 10
      END
      SUBROUTINE SCOMP2 (X,Y,YPP,N,XI,YI,NI,IERR)
C
C     ABSTRACT
C
C         SCOMP2 EVALUATES A CUBIC SPLINE AT THE ABSCISSAS IN XI.
C         IT IS ASSUMED THAT THE SECOND DERIVATIVES AT THE NODES
C         HAVE BEEN PROVIDED.
C
C     DESCRIPTION OF ARGUMENTS
C
C       --INPUT--
C
C         X   - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE THE
C               SPLINE.
C         Y   - ARRAY OF ORDINATES THAT DEFINE THE SPLINE.
C         YPP - ARRAY OF SECOND DERIVATIVES THAT DEFINE THE SPLINE.
C         N   - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE.
C               THE ARRAYS X, Y, AND YPP MUST BE DIMENSIONED AT LEAST N.
C               N MUST BE GREATER THAN OR EQUAL TO 2.
C         XI  - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER)
C               AT WHICH THE SPLINE IS TO BE EVALUATED.
C         NI  - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE
C               EVALUATED.  IF NI IS GREATER THAN 1 THEN XI AND YI
C               MUST BE ARRAYS OF DIMENSION NI OR LARGER.
C               IT IS ASSUMED THAT NI IS GREATER THAN OR EQUAL TO 1.
C
C       --OUTPUT--
C
C         YI  - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI.
C         IERR- STATUS CODE
C               0  THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI.
C               1  INPUT ERROR - NI IS NOT POSITIVE.
C
      REAL X(N), Y(N), YPP(N), XI(NI), YI(NI)
C
C     CHECK INPUT
C
      IF (NI .GT. 0) GO TO 1
         IERR = 1
         RETURN
    1 IERR = 0
      NM1 = N - 1
C
C     K IS INDEX ON VALUE OF XI BEING WORKED ON.  XX IS THAT VALUE.
C     I IS CURRENT INDEX INTO X ARRAY.
C
      K  = 1
      XX = XI(1)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(NM1)) GO TO 80
      IL = 1
      IR = NM1
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 100
      IF (XX - X(I)) 20,100,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   50 IF (XX .LT. X(I+1)) GO TO 100
      I = I + 1
      GO TO 50
C
C     XX IS GREATER THAN X(N) OR LESS THAN X(1)
C
   80 I = NM1
      GO TO 100
   90 I = 1
C
C     EVALUATION
C
  100 H  = X(I+1) - X(I)
      H2 = H*H
      XR = (X(I+1) - XX)/H
      XR2 = XR*XR
      XR3 = XR*XR2
      XL = (XX - X(I))/H
      XL2 = XL*XL
      XL3 = XL*XL2
      YI(K) = Y(I)*XR + Y(I+1)*XL
     *       - H2*(YPP(I)*(XR-XR3) + YPP(I+1)*(XL-XL3))/6.0
C
C     NEXT POINT
C
      IF (K .GE. NI) RETURN
      K = K + 1
      XX = XI(K)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(NM1)) GO TO 80
      IF (XX - XI(K-1)) 110,100,50
  110 IL = 1
      IR = MIN0(I+1,NM1)
      GO TO 10
      END
      SUBROUTINE SEVAL (X,Y,A,B,C,N,XI,YI,YPI,YPPI,NI,IERR)
C
C     ABSTRACT
C
C         SEVAL EVALUATES A CUBIC SPLINE AND ITS FIRST AND SECOND
C         DERIVATIVES AT THE ABSCISSAS IN XI.  IT IS ASSUMED THAT
C         THE COEFFICIENTS OF THE POLYNOMIALS WHICH FORM THE SPLINE
C         ARE PROVIDED.
C
C     DESCRIPTION OF ARGUMENTS
C
C       --INPUT--
C
C         X   - ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER)
C               THAT DEFINE THE SPLINE.
C         Y   - ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE.
C         A,B,C ARRAYS THAT CONTAIN THE COEFFICIENTS OF THE POLYNOMIALS
C               WHICH FORM THE SPLINE. IF I = 1,...,N  THEN THE SPLINE
C               HAS THE VALUE
C                    Y(I) + A(I)*DX + B(I)*DX**2 + C(I)*DX**3
C               FOR X(I) .LE. XX .LE. X(I+1).  HERE DX = XX-X(I).
C         N   - THE NUMBER OF POLYNOMIALS THAT DEFINE THE SPLINE.
C               THE ARRAYS X, Y, A, B, C  MUST BE DIMENSIONED AT
C               LEAST N.  N MUST BE GREATER THAN OR EQUAL TO 1.
C         XI  - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER)
C               AT WHICH THE SPLINE IS TO BE EVALUATED.
C         NI  - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE
C               EVALUATED.  IF NI IS GREATER THAN 1, THEN XI, YI, YPI,
C               AND YPPI MUST BE ARRAYS DIMENSIONED AT LEAST NI.
C               NI MUST BE GREATER THAN OR EQUAL TO 1.
C
C       --OUTPUT--
C
C         YI  - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI.
C         YPI - ARRAY OF VALUES OF THE FIRST DERIVATIVE OF SPLINE AT XI.
C         YPPI- ARRAY OF VALUES OF SECOND DERIVATIVES OF SPLINE AT XI.
C         IERR- STATUS CODE
C               0  THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI.
C               1  INPUT ERROR - NI IS NOT POSITIVE.
C
      REAL X(N),Y(N),A(N),B(N),C(N),XI(NI),YI(NI),YPI(NI),YPPI(NI)
C
C     CHECK INPUT
C
      IF (NI .GT. 0) GO TO 1
         IERR = 1
         RETURN
    1 IERR = 0
C
C     K IS INDEX ON VALUE OF XI BEING WORKED ON.  XX IS THAT VALUE.
C     I IS CURRENT INDEX INTO X ARRAY.
C
      K  = 1
      XX = XI(1)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(N)) GO TO 80
      IL = 1
      IR = N
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 100
      IF (XX - X(I)) 20,100,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   50 IF (XX .LT. X(I+1)) GO TO 100
      I = I + 1
      GO TO 50
C
C     XX IS GREATER THAN X(N) OR LESS THAN X(1)
C
   80 I = N
      GO TO 100
   90 I = 1
C
C     EVALUATION
C
  100 DX = XX - X(I)
      YI(K) = Y(I) + DX*(A(I) + DX*(B(I) + DX*C(I)))
      BI = B(I) + B(I)
      CI = 3.0*C(I)
      YPI(K) = A(I) + DX*(BI + DX*CI)
      YPPI(K) = BI + DX*(CI + CI)
C
C     NEXT POINT
C
      IF (K .GE. NI) RETURN
      K = K + 1
      XX = XI(K)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(N)) GO TO 80
      IF (XX - XI(K-1)) 110,100,50
  110 IL = 1
      IR = MIN0(I+1,N)
      GO TO 10
      END
      SUBROUTINE SEVAL1 (X,Y,YP,N,XI,YI,YPI,YPPI,NI,IERR)
C
C     ABSTRACT
C
C         SEVAL1 EVALUATES A CUBIC SPLINE AND ITS FIRST AND SECOND
C         DERIVATIVES AT THE ABSCISSAS IN XI.  IT IS ASSUMED THAT
C         THE FIRST DERIVATIVES AT THE NODES HAVE BEEN PROVIDED.
C
C     DESCRIPTION OF ARGUMENTS
C
C       --INPUT--
C
C         X   - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE THE
C               SPLINE.
C         Y   - ARRAY OF ORDINATES THAT DEFINE THE SPLINE.
C         YP  - ARRAY OF FIRST DERIVATIVES THAT DEFINE THE SPLINE.
C         N   - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE.
C               THE ARRAYS X, Y, AND YP MUST BE DIMENSIONED AT LEAST N.
C               N MUST BE GREATER THAN OR EQUAL TO 2.
C         XI  - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER)
C               AT WHICH THE SPLINE IS TO BE EVALUATED.
C         NI  - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE
C               EVALUATED.  IF NI IS GREATER THAN 1, THEN XI, YI, YPI,
C               AND YPPI MUST BE ARRAYS DIMENSIONED AT LEAST NI.
C               NI MUST BE GREATER THAN OR EQUAL TO 1.
C
C       --OUTPUT--
C
C         YI  - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI.
C         YPI - ARRAY OF VALUES OF THE FIRST DERIVATIVE OF SPLINE AT XI.
C         YPPI- ARRAY OF VALUES OF SECOND DERIVATIVES OF SPLINE AT XI.
C         IERR- STATUS CODE
C               0  THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI.
C               1  INPUT ERROR - NI IS NOT POSITIVE.
C
      REAL X(N),Y(N),YP(N),XI(NI),YI(NI),YPI(NI),YPPI(NI)
C
C     CHECK INPUT
C
      IF (NI .GT. 0) GO TO 1
         IERR = 1
         RETURN
    1 IERR = 0
      NM1 = N - 1
C
C     K IS INDEX ON VALUE OF XI BEING WORKED ON.  XX IS THAT VALUE.
C     I IS CURRENT INDEX INTO X ARRAY.
C
      K  = 1
      XX = XI(1)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(NM1)) GO TO 80
      IL = 1
      IR = NM1
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 100
      IF (XX - X(I)) 20,100,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   50 IF (XX .LT. X(I+1)) GO TO 100
      I = I + 1
      GO TO 50
C
C     XX IS GREATER THAN X(N) OR LESS THAN X(1)
C
   80 I = NM1
      GO TO 100
   90 I = 1
C
C     EVALUATION
C
  100 H = X(I+1) - X(I)
      D = (Y(I+1) - Y(I))/H
      A = YP(I) + YP(I+1)
      B = (-A - YP(I) + 3.0*D)/H
      C = (A - D - D)/(H*H)
      DX = XX - X(I)
      YI(K) = Y(I) + DX*(YP(I) + DX*(B + DX*C))
      B = B + B
      C = 3.0*C
      YPI(K) = YP(I) + DX*(B + DX*C)
      YPPI(K) = B + DX*(C + C)
C
C     NEXT POINT
C
      IF (K .GE. NI) RETURN
      K = K + 1
      XX = XI(K)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(NM1)) GO TO 80
      IF (XX - XI(K-1)) 110,100,50
  110 IL = 1
      IR = MIN0(I+1,NM1)
      GO TO 10
      END
      SUBROUTINE SEVAL2 (X,Y,YPP,N,XI,YI,YPI,YPPI,NI,IERR)
C
C     ABSTRACT
C
C         SEVAL2 EVALUATES A CUBIC SPLINE AND ITS FIRST AND SECOND
C         DERIVATIVES AT THE ABSCISSAS IN XI.  IT IS ASSUMED THAT
C         THE SECOND DERIVATIVES AT THE NODES HAVE BEEN PROVIDED.
C
C     DESCRIPTION OF ARGUMENTS
C
C       --INPUT--
C
C         X   - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE THE
C               SPLINE.
C         Y   - ARRAY OF ORDINATES THAT DEFINE THE SPLINE.
C         YPP - ARRAY OF SECOND DERIVATIVES THAT DEFINE THE SPLINE.
C         N   - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE.
C               THE ARRAYS X, Y, AND YPP MUST BE DIMENSIONED AT LEAST N.
C               N MUST BE GREATER THAN OR EQUAL TO 2.
C         XI  - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER)
C               AT WHICH THE SPLINE IS TO BE EVALUATED.
C         NI  - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE
C               EVALUATED.  IF NI IS GREATER THAN 1, THEN XI, YI, YPI,
C               AND YPPI MUST BE ARRAYS DIMENSIONED AT LEAST NI.
C               NI MUST BE GREATER THAN OR EQUAL TO 1.
C
C       --OUTPUT--
C
C         YI  - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI.
C         YPI - ARRAY OF VALUES OF THE FIRST DERIVATIVE OF SPLINE AT XI.
C         YPPI- ARRAY OF VALUES OF SECOND DERIVATIVES OF SPLINE AT XI.
C         IERR- STATUS CODE
C               0  THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI.
C               1  INPUT ERROR - NI IS NOT POSITIVE.
C
      REAL X(N),Y(N),YPP(N),XI(NI),YI(NI),YPI(NI),YPPI(NI)
C
C     CHECK INPUT
C
      IF (NI .GT. 0) GO TO 1
         IERR = 1
         RETURN
    1 IERR = 0
      NM1 = N - 1
C
C     K IS INDEX ON VALUE OF XI BEING WORKED ON.  XX IS THAT VALUE.
C     I IS CURRENT INDEX INTO X ARRAY.
C
      K  = 1
      XX = XI(1)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(NM1)) GO TO 80
      IL = 1
      IR = NM1
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 100
      IF (XX - X(I)) 20,100,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   50 IF (XX .LT. X(I+1)) GO TO 100
      I = I + 1
      GO TO 50
C
C     XX IS GREATER THAN X(N) OR LESS THAN X(1)
C
   80 I = NM1
      GO TO 100
   90 I = 1
C
C     EVALUATION
C
  100 H  = X(I+1) - X(I)
      H2 = H*H
      XR = (X(I+1) - XX)/H
      XR2 = XR*XR
      XR3 = XR*XR2
      XL = (XX - X(I))/H
      XL2 = XL*XL
      XL3 = XL*XL2
      YI(K) = Y(I)*XR + Y(I+1)*XL
     1       - H2*(YPP(I)*(XR-XR3) + YPP(I+1)*(XL-XL3))/6.0
      YPI(K) = (Y(I+1)-Y(I))/H
     1        + H*(YPP(I)*(1.0-3.0*XR2) - YPP(I+1)*(1.0-3.0*XL2))/6.0
      YPPI(K) = YPP(I)*XR + YPP(I+1)*XL
C
C     NEXT POINT
C
      IF (K .GE. NI) RETURN
      K = K + 1
      XX = XI(K)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(NM1)) GO TO 80
      IF (XX - XI(K-1)) 110,100,50
  110 IL = 1
      IR = MIN0(I+1,NM1)
      GO TO 10
      END
      REAL FUNCTION CSINT (X, Y, A, B, C, N, ALPHA, BETA)
C-----------------------------------------------------------------------
C
C                    INTEGRATING A CUBIC SPLINE
C
C                         --------------
C
C     X      ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER)
C            THAT DEFINE THE SPLINE.
C
C     Y      ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE.
C
C     A,B,C  ARRAYS THAT CONTAIN THE COEFFICIENTS OF THE POLYNOMIALS
C            WHICH FORM THE SPLINE. IF I = 1,...,N  THEN THE SPLINE
C            HAS THE VALUE
C                    Y(I) + A(I)*DX + B(I)*DX**2 + C(I)*DX**3
C            FOR X(I) .LE. XX .LE. X(I+1). HERE DX = XX - X(I).
C
C     N      THE NUMBER OF POLYNOMIALS THAT DEFINE THE SPLINE.
C            THE ARRAYS X, Y, A, B, C  MUST BE DIMENSIONED AT
C            LEAST N.  N MUST BE GREATER THAN OR EQUAL TO 1.
C
C     ALPHA  LOWER LIMIT OF THE INTEGRAL.
C
C     BETA   UPPER LIMIT OF THE INTEGRAL. BETA MAY BE LESS THAN
C            OR GREATER THAN ALPHA.
C
C-----------------------------------------------------------------------
      REAL X(N), Y(N), A(N), B(N), C(N)
C
      CSINT = 0.0
      H = BETA - ALPHA
      IF (H .EQ. 0.0) RETURN
      IF (H .GT. 0.0) GO TO 10
         A0 = BETA
         B0 = ALPHA
         GO TO 20
   10 A0 = ALPHA
      B0 = BETA
C
C     LOCATE THE INTERVALS CONTAINING A0 AND B0
C
   20 IF (N .EQ. 1) GO TO 50
      IF (A0 .GE. X(N)) GO TO 50
      K = INTRVL (A0, X, N)
      L = INTRVL (B0, X, N)
      IF (B0 .GE. X(N)) L = N
      IF (K .EQ. L) GO TO 51
C
C     INTEGRATE FROM A0 TO X(K + 1)
C
      KP1 = K + 1
      H = X(KP1) - X(K)
      D = A0 - X(K)
      R = H + D
      H2 = H*H
      D2 = D*D
      S = H2 + D2
      SUM = Y(K) + 0.5*A(K)*R + B(K)*(S + H*D)/3.0
     *           + 0.25*C(K)*R*S
      SUM = (X(KP1) - A0)*SUM
C
C     INTEGRATE OVER THE INTERIOR INTERVALS
C
      IF (KP1 .EQ. L) GO TO 40
      LM1 = L - 1
      DO 30 I = KP1,LM1
         H = X(I + 1) - X(I)
         S = (((0.25*C(I)*H + B(I)/3.0)*H + 0.5*A(I))*H + Y(I))*H
         SUM = SUM + S
   30 CONTINUE
C
C     INTEGRATE FROM X(L) TO B0
C
   40 H = B0 - X(L)
      S = (((0.25*C(L)*H + B(L)/3.0)*H + 0.5*A(L))*H + Y(L))*H
      CSINT = SUM + S
      IF (ALPHA .GT. BETA) CSINT = -CSINT
      RETURN
C
C     CASE WHEN A0 AND B0 ARE IN THE SAME INTERVAL
C
   50 K = N
   51 H = B0 - X(K)
      D = A0 - X(K)
      R = H + D
      H2 = H*H
      D2 = D*D
      S = H2 + D2
      SUM = Y(K) + 0.5*A(K)*R + B(K)*(S + H*D)/3.0
     *           + 0.25*C(K)*R*S
      CSINT = (BETA - ALPHA)*SUM
      RETURN
      END
      REAL FUNCTION CSINT1 (X, Y, YP, N, A, B)
C-----------------------------------------------------------------------
C
C                    INTEGRATING A CUBIC SPLINE
C
C                         --------------
C
C     X    ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER)
C          THAT DEFINE THE SPLINE.
C
C     Y    ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE.
C
C     YP   ARRAY OF THE FIRST DERIVATIVES THAT DEFINE THE SPLINE.
C
C     N    THE NUMBER OF KNOTS OF THE SPLINE. THE ARRAYS X, Y,
C          AND YP MUST HAVE DIMENSION AT LEAST N WHERE N .GE. 2.
C
C     A    LOWER LIMIT OF THE INTEGRAL.
C
C     B    UPPER LIMIT OF THE INTEGRAL. B MAY BE LESS THAN
C          OR GREATER THAN A.
C
C-----------------------------------------------------------------------
      REAL X(N), Y(N), YP(N)
C
      CSINT1 = 0.0
      H = B - A
      IF (H .EQ. 0.0) RETURN
      IF (H .GT. 0.0) GO TO 10
         A0 = B
         B0 = A
         GO TO 20
   10 A0 = A
      B0 = B
C
C     LOCATE THE INTERVALS CONTAINING A0 AND B0
C
   20 K = INTRVL (A0, X, N)
      L = INTRVL (B0, X, N)
      IF (K .EQ. L) GO TO 50
C
C     INTEGRATE FROM A0 TO X(K + 1)
C
      KP1 = K + 1
      H = X(KP1) - X(K)
      D = (Y(KP1) - Y(K))/H
      R = YP(K) + YP(KP1)
      BI = (-R - YP(K) + 3.0*D)/H
      CI = (R - D - D)/(H*H)
C
      D = A0 - X(K)
      R = H + D
      H2 = H*H
      D2 = D*D
      S = H2 + D2
      SUM = Y(K) + 0.5*YP(K)*R + BI*(S + H*D)/3.0
     *           + 0.25*CI*R*S
      SUM = (X(KP1) - A0)*SUM
C
C     INTEGRATE OVER THE INTERIOR INTERVALS
C
      IF (KP1 .EQ. L) GO TO 40
      LM1 = L - 1
      DO 30 I = KP1,LM1
         IP1 = I + 1
         H = X(IP1) - X(I)
         D = (Y(IP1) - Y(I))/H
         R = YP(I) + YP(IP1)
         BI = (-R - YP(I) + 3.0*D)/H
         CI = (R - D - D)/(H*H)
         S = (((0.25*CI*H + BI/3.0)*H + 0.5*YP(I))*H + Y(I))*H
         SUM = SUM + S
   30 CONTINUE
C
C     INTEGRATE FROM X(L) TO B0
C
   40 LP1 = L + 1
      H = X(LP1) - X(L)
      D = (Y(LP1) - Y(L))/H
      R = YP(L) + YP(LP1)
      BI = (-R - YP(L) + 3.0*D)/H
      CI = (R - D - D)/(H*H)
      H = B0 - X(L)
      S = (((0.25*CI*H + BI/3.0)*H + 0.5*YP(L))*H + Y(L))*H
      CSINT1 = SUM + S
      IF (A .GT. B) CSINT1 = -CSINT1
      RETURN
C
C     CASE WHEN A0 AND B0 ARE IN THE SAME INTERVAL
C
   50 KP1 = K + 1
      H = X(KP1) - X(K)
      D = (Y(KP1) - Y(K))/H
      R = YP(K) + YP(KP1)
      BI = (-R - YP(K) + 3.0*D)/H
      CI = (R - D - D)/(H*H)
C
      H = B0 - X(K)
      D = A0 - X(K)
      R = H + D
      H2 = H*H
      D2 = D*D
      S = H2 + D2
      SUM = Y(K) + 0.5*YP(K)*R + BI*(S + H*D)/3.0
     *           + 0.25*CI*R*S
      CSINT1 = (B - A)*SUM
      RETURN
      END
      REAL FUNCTION CSINT2 (X, Y, YPP, N, A, B)
C-----------------------------------------------------------------------
C
C                    INTEGRATING A CUBIC SPLINE
C
C                         --------------
C
C     X    ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER)
C          THAT DEFINE THE SPLINE.
C
C     Y    ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE.
C
C     YPP  ARRAY OF THE SECOND DERIVATIVES THAT DEFINE THE SPLINE.
C
C     N    THE NUMBER OF KNOTS OF THE SPLINE. THE ARRAYS X, Y,
C          AND YPP MUST HAVE DIMENSION AT LEAST N WHERE N .GE. 2.
C
C     A    LOWER LIMIT OF THE INTEGRAL.
C
C     B    UPPER LIMIT OF THE INTEGRAL. B MAY BE LESS THAN
C          OR GREATER THAN A.
C
C-----------------------------------------------------------------------
      REAL X(N), Y(N), YPP(N)
C
      CSINT2 = 0.0
      H = B - A
      IF (H .EQ. 0.0) RETURN
      IF (H .GT. 0.0) GO TO 10
         A0 = B
         B0 = A
         GO TO 20
   10 A0 = A
      B0 = B
C
C     LOCATE THE INTERVALS CONTAINING A0 AND B0
C
   20 K = INTRVL (A0, X, N)
      L = INTRVL (B0, X, N)
      IF (K .EQ. L) GO TO 50
C
C     INTEGRATE FROM A0 TO X(K + 1)
C
      KP1 = K + 1
      H = X(KP1) - X(K)
      D = (X(KP1) - A0)/H
      R = Y(K)*D + Y(KP1)*(2.0 - D)
      S = YPP(K)*(2.0 - D*D) + YPP(KP1)*(2.0 - D)**2
      SUM = H*D*(0.5*R - H*H*D*S/24.0)
C
C
C     INTEGRATE OVER THE INTERIOR INTERVALS
C
      IF (KP1 .EQ. L) GO TO 40
      LM1 = L - 1
      DO 30 I = KP1,LM1
         IP1 = I + 1
         H = X(IP1) - X(I)
         R = Y(I) + Y(IP1)
         S = YPP(I) + YPP(IP1)
         SUM = SUM + H*(0.5*R - H*H*S/24.0)
   30 CONTINUE
C
C     INTEGRATE FROM X(L) TO B0
C
   40 LP1 = L + 1
      H = X(LP1) - X(L)
      D = (B0 - X(L))/H
      R = Y(L)*(2.0 - D) + Y(LP1)*D
      S = YPP(L)*(2.0 - D)**2 + YPP(LP1)*(2.0 - D*D)
      CSINT2 = SUM + H*D*(0.5*R - H*H*D*S/24.0)
      IF (A .GT. B) CSINT2 = -CSINT2
      RETURN
C
C     CASE WHEN A0 AND B0 ARE IN THE SAME INTERVAL
C
   50 KP1 = K + 1
      H = X(KP1) - X(K)
      DMA = (A - X(K))/H
      DMB = (B - X(K))/H
      DPA = (X(KP1) - A)/H
      DPB = (X(KP1) - B)/H
      R = (DPA + DPB)*Y(K) + (DMA + DMB)*Y(KP1)
      S = YPP(K) * (DPA + DPB)*(DMA*(2.0 - DMA) + DMB*(2.0 - DMB)) +
     *    YPP(KP1)*(DMA + DMB)*(DPA*(2.0 - DPA) + DPB*(2.0 - DPB))
      CSINT2 = (B - A)*(0.5*R - H*H*S/24.0)
      RETURN
      END
      SUBROUTINE PDSPL (X, Y, A, B, C, N, T, IERR)
C-----------------------------------------------------------------------
C                PERIODIC CUBIC SPLINE INTERPOLATION
C-----------------------------------------------------------------------
      REAL X(N), Y(*), A(*), B(*), C(*), T(*)
C----------------------
C     REAL X(N), Y(N-1), A(N-1), B(N-1), C(N-1), T(N-2)
C----------------------
      IF (N .LT. 3) GO TO 100
      NM1 = N - 1
      NM2 = N - 2
      NM3 = N - 3
C
C     A STRICTLY DIAGONALLY DOMINANT SET OF EQUATIONS FOR THE
C     SLOPES S(I) OF THE SPLINE AT X(I) (I = 1,...,N-1) IS
C     GENERATED AND SOLVED BY GAUSS ELIMINATION. THE FIRST OF
C     THESE EQUATIONS IS OBTAINED FROM THE REQUIREMENT THAT
C     THE SPLINE BE PERIODIC. THIS EQUATION HAS THE FORM ...
C
C        A(1)*S(1) + B(1)*S(2) + C(1)*S(N-1) = T(1)
C
      B(1) = X(N) - X(NM1)
      H = X(2) - X(1)
      IF (H .LE. 0.0 .OR. B(1) .LE. 0.0) GO TO 110
      DEL = (Y(1) - Y(NM1))/B(1)
      DELI = (Y(2) - Y(1))/H
C
      C(1) = H
      A(1) = 2.0*(H + B(1))
      T(1) = 3.0*(H*DEL + B(1)*DELI)
      IF (N .EQ. 3) GO TO 20
C
C     FOR THE KNOTS X(I) (I = 2,...N-2) GENERATE THE CORRESPOND-
C     ING EQUATIONS AND CARRY OUT THE PIVOT REDUCTION OF GAUSS
C     ELIMINATION. THEN THE I-TH EQUATION HAS THE FORM ...
C
C        A(I)*S(I) + B(I)*S(I+1) + C(I)*S(N-1) = T(I)
C
      DO 10 I = 2,NM2
         B(I) = H
         H = X(I+1) - X(I)
         IF (H .LE. 0.0) GO TO 110
C
         E = H/A(I-1)
         C(I) = - E*C(I-1)
         A(I) = 2.0*(B(I) + H) - E*B(I-1)
C
         DEL0 = DELI
         DELI = (Y(I+1) - Y(I))/H
         T(I) = 3.0*(H*DEL0 + B(I)*DELI) - E*T(I-1)
   10 CONTINUE
C
   20 IERR = 0
      B(NM1) = H
C
C     SINCE IT IS REQUIRED THAT THE SPLINE BE PERIODIC, THE
C     EQUATION FOR THE KNOT X(N-1) HAS THE FORM ...
C
C        ALPHA*S(1) + B(1)*S(N-2) + DELTA*S(N-1) = R
C
C     APPLYING THE PIVOTS TO THIS EQUATION, ONE OBTAINS AFTER
C     EACH PIVOT OPERATION THE MODIFIED EQUATION ...
C
C        ALPHA*S(I+1) + B(1)*S(N-2) + DELTA*S(N-1) = R
C
C     THUS, WHEN THIS PIVOT REDUCTION IS COMPLETE, THE (N-1)-ST
C     EQUATION TO BE SOLVED HAS THE FORM ...
C
C        (ALPHA + B(1))*S(N-2) + DELTA*S(N-1) = R
C
      ALPHA = H
      DELTA = 2.0*(H + B(1))
      R = 3.0*(B(1)*DELI + H*DEL)
      IF (N .EQ. 3) GO TO 40
C
      DO 30 I = 1,NM3
         E = ALPHA/A(I)
         ALPHA = - E*B(I)
         DELTA = DELTA - E*C(I)
         R = R - E*T(I)
   30 CONTINUE
C
C     SOLVE THE LAST TWO EQUATIONS FOR S(N-1) AND S(N-2), AND
C     STORE THESE SLOPES IN A.
C
   40 E = (ALPHA + B(1))/A(NM2)
      W = B(NM2) + C(NM2)
      S = (R - E*T(NM2))/(DELTA - E*W)
      A(NM1) = S
      A(NM2) = (T(NM2) - W*S)/A(NM2)
      IF (N .EQ. 3) GO TO 60
C
C     BACK SUBSTITUTION TO OBTAIN THE REMAINING SLOPES S(I).
C     THESE SLOPES ARE STORED IN A.
C
      SI = A(NM2)
      DO 50 J = 3,NM1
         I = N - J
         SI = (T(I) - B(I)*SI - C(I)*S)/A(I)
         A(I) = SI
   50 CONTINUE
C
C     GENERATE THE CUBIC COEFFICIENTS B(I) AND C(I)
C
   60 H = B(1)
      DO 61 I = 1,NM2
         HI = B(I + 1)
         DELI = (Y(I+1) - Y(I))/HI
         W = A(I) + A(I+1) - 2.0*DELI
         B(I) = (DELI - A(I) - W)/HI
         C(I) = (W/HI)/HI
   61 CONTINUE
      W = A(1) + A(NM1) - 2.0*DEL
      B(NM1) = (DEL - A(NM1) - W)/H
      C(NM1) = (W/H)/H
      RETURN
C
C     ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE PDFIT (X, Y, M, BREAK, L, Z, A, B, C, WK, IWK, IERR)
C-----------------------------------------------------------------------
C            LEAST SQUARES PERIODIC CUBIC SPLINE FITTING
C-----------------------------------------------------------------------
      REAL X(M), Y(M), BREAK(L)
      REAL Z(*), A(*), B(*), C(*), WK(*)
      INTEGER IWK(*)
C--------------------
C     REAL Z(L-1), A(L-1), B(L-1), C(L-1)
C     REAL WK((L + 6)*(L + 15) + 10)
C     INTEGER IWK(2*L + 6)
C--------------------
      REAL TEMP(20)
      REAL CON(3), XCON(3)
      INTEGER NDER(3)
C--------------------
      DATA NDER(1) /3/, NDER(2) /7/, NDER(3) /11/
C--------------------
      IF (M .LE. 0 .OR. L .LT. 2) GO TO 100
      N = L + 2
C
C                DEFINE THE NODES FOR THE B-SPLINES
C
      WK(1) = BREAK(1)
      WK(2) = BREAK(1)
      WK(3) = BREAK(1)
      WK(4) = BREAK(1)
      DO 10 J = 2,L
         IF (BREAK(J - 1) .GE. BREAK(J)) GO TO 110
         WK(J + 3) = BREAK(J)
   10 CONTINUE
      WK(L + 4) = BREAK(L)
      WK(L + 5) = BREAK(L)
      WK(L + 6) = BREAK(L)
C
C                DEFINE THE PERIODICITY CONSTRAINTS
C
      CON(1) = BREAK(1)
      CON(2) = BREAK(1)
      CON(3) = BREAK(1)
      XCON(1) = BREAK(L)
      XCON(2) = BREAK(L)
      XCON(3) = BREAK(L)
C
C     OBTAIN THE B-SPLINE COEFFICIENTS OF THE PERIODIC SPLINE
C
      IERR = 0
      LA = N + 5
      LW = LA + N
      IWK(1) = IWK(1) - (L + L + 8)
      CALL BFIT (WK(1), N, 4, X, Y, M, XCON, CON, NDER, 3, IERR,
     *           WK(LA), R, WK(LW), IWK)
      IWK(1) = IWK(1) + (L + L + 8)
      IF (IERR .NE. 0) GO TO 30
C
C     OBTAIN THE COEFFICIENTS OF THE SPLINE IN TAYLOR SERIES FORM
C
      CALL BSPP (WK(1), WK(LA), N, 4, BREAK, WK(LW), LM1, TEMP)
      K = LW
      DO 20 J = 1,LM1
         Z(J) = WK(K)
         A(J) = WK(K + 1)
         B(J) = WK(K + 2)
         C(J) = WK(K + 3)
         K = K + 4
   20 CONTINUE
      RETURN
C
C                THE COEFFICIENTS WERE NOT OBTAINED
C
   30 IF (IERR .EQ. -4) GO TO 120
      IF (IERR .EQ. -6) GO TO 130
      IF (IERR .EQ. -7) GO TO 140
      IERR = 1
      RETURN
C
C                           ERROR RETURN
C
  100 IERR = 2
      RETURN
  110 IERR = 3
      RETURN
  120 IERR = 4
      RETURN
  130 IERR = 5
      RETURN
  140 IERR = 6
      RETURN
      END
      SUBROUTINE PSCMP (X, Y, A, B, C, N, XI, YI, M, IERR)
C-----------------------------------------------------------------------
C              EVALUATION OF A PERIODIC CUBIC SPLINE
C-----------------------------------------------------------------------
      REAL X(N), Y(*), A(*), B(*), C(*), XI(M), YI(M)
C----------------------
C     REAL X(N), Y(N-1), A(N-1), B(N-1), C(N-1), XI(M), YI(M)
C----------------------
      IF (N .GE. 3 .AND. M .GE. 1) GO TO 1
         IERR = 1
         RETURN
    1 IERR = 0
      X1 = X(1)
      H = X(N) - X1
C
C     REDUCTION OF XI(K) TO XX WHERE X(1) .LE. XX .LT. X(N)
C
      K = 1
      T = (XI(1) - X1)/H
      J = T
      T0 = T - J
      IF (T0 .LT. 0.0) T0 = 1.0 + T0
      XX = X1 + T0*H
      IF (XX .GE. X(N)) GO TO 120
      IL = 1
      IR = N
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 90
      IF (XX - X(I)) 20,90,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   40 IF (XX .LT. X(I+1)) GO TO 90
      I = I + 1
      GO TO 40
C
C     COMPUTATION WHEN X(I) .LE. XX .LT. X(I+1)
C
   90 DX = XX - X(I)
      YI(K) = ((C(I)*DX + B(I))*DX + A(I))*DX + Y(I)
C
C     NEXT POINT
C
  100 IF (K .GE. M) RETURN
      XOLD = XX
      K = K + 1
      T = (XI(K) - X1)/H
      J = T
      T0 = T - J
      IF (T0 .LT. 0.0) T0 = 1.0 + T0
      XX = X1 + T0*H
      IF (XX .GE. X(N)) GO TO 120
      IF (XX - XOLD) 110,90,40
C
  110 IL = 1
      IR = MIN0(I+1,N)
      GO TO 10
C
C     CASE WHEN ROUNDOFF PRODUCES A VALUE FOR XX WHERE
C     XX .GE. X(N). THIS CASE MAY NEVER OCCUR.
C
  120 I = 1
      XX = X1
      YI(K) = Y(1)
      GO TO 100
      END
      SUBROUTINE PSEVL (X, Y, A, B, C, N, XI, YI, YPI, YPPI, M, IERR)
C-----------------------------------------------------------------------
C     EVALUATION AND DIFFERENTIATION OF A PERIODIC CUBIC SPLINE
C-----------------------------------------------------------------------
      REAL X(N), Y(*), A(*), B(*), C(*), XI(M), YI(M), YPI(M), YPPI(M)
C----------------------
C     REAL X(N), Y(N-1), A(N-1), B(N-1), C(N-1), XI(M), YI(M), YPI(M),
C    *     YPPI(M)
C----------------------
      IF (N .GE. 3 .AND. M .GE. 1) GO TO 1
         IERR = 1
         RETURN
    1 IERR = 0
      X1 = X(1)
      H = X(N) - X1
C
C     REDUCTION OF XI(K) TO XX WHERE X(1) .LE. XX .LT. X(N)
C
      K = 1
      T = (XI(1) - X1)/H
      J = T
      T0 = T - J
      IF (T0 .LT. 0.0) T0 = 1.0 + T0
      XX = X1 + T0*H
      IF (XX .GE. X(N)) GO TO 120
      IL = 1
      IR = N
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 90
      IF (XX - X(I)) 20,90,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   40 IF (XX .LT. X(I+1)) GO TO 90
      I = I + 1
      GO TO 40
C
C     COMPUTATION WHEN X(I) .LE. XX .LT. X(I+1)
C
   90 DX = XX - X(I)
      YI(K) = ((C(I)*DX + B(I))*DX + A(I))*DX + Y(I)
      BI2 = B(I) + B(I)
      CI3 = 3.0*C(I)
      YPI(K) = (CI3*DX + BI2)*DX + A(I)
      YPPI(K) = BI2 + (CI3 + CI3)*DX
C
C     NEXT POINT
C
  100 IF (K .GE. M) RETURN
      XOLD = XX
      K = K + 1
      T = (XI(K) - X1)/H
      J = T
      T0 = T - J
      IF (T0 .LT. 0.0) T0 = 1.0 + T0
      XX = X1 + T0*H
      IF (XX .GE. X(N)) GO TO 120
      IF (XX - XOLD) 110,90,40
C
  110 IL = 1
      IR = MIN0(I+1,N)
      GO TO 10
C
C     CASE WHEN ROUNDOFF PRODUCES A VALUE FOR XX WHERE
C     XX .GE. X(N). THIS CASE MAY NEVER OCCUR.
C
  120 I = 1
      XX = X1
      YI(K) = Y(1)
      YPI(K) = A(1)
      YPPI(K) = B(1) + B(1)
      GO TO 100
      END
      SUBROUTINE CSLOOP (M, N, X, KX, T, DX, KDX, WK, IERR)
C-----------------------------------------------------------------------
C               CLOSED CURVE CUBIC SPLINE FITTING
C                    IN N-DIMENSIONAL SPACE
C-----------------------------------------------------------------------
C     WRITTEN BY
C        ALFRED H. MORRIS
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C----------------------
      REAL X(KX,N), T(M), DX(KDX,N), WK(*)
C----------------------
C     M = THE NUMBER OF N-DIMENSIONAL POINTS GIVEN IN X
C     WK IS AN ARRAY OF DIMENSION 4*(M-1)
C----------------------
      IF (MIN0(M, N) .LT. 2) GO TO 10
C
      MM1 = M - 1
      IE = 1
      IA = MM1
      IB = IA + MM1
      IC = IB + M
      CALL CSLOP1 (M, N, X, KX, T, DX, KDX, WK(IA), WK(IB),
     *                    WK(IC), WK(IE), IERR)
      RETURN
C
C     ERROR RETURN
C
   10 IERR = 1
      RETURN
      END
      SUBROUTINE CSLOP1 (M, N, X, KX, T, DX, KDX, A, B, C, E, IERR)
C-----------------------------------------------------------------------
C               CLOSED CURVE CUBIC SPLINE FITTING
C                    IN N-DIMENSIONAL SPACE
C-----------------------------------------------------------------------
      REAL X(KX,N), T(M), DX(KDX,N), A(*), B(M), C(*), E(*)
C----------------------
C     REAL A(M-1), C(M-1), E(K)  (K = MAX0(1,M-2))
C     THE E ARRAY IS NOT USED WHEN M = 2.
C----------------------
      MM1 = M - 1
      MM2 = M - 2
C
C     DEFINITION OF THE KNOTS T(I) (I = 1,...,M). ALSO T(M+1) = 1.
C     THIS LAST KNOT IS NOT STORED.
C
      T(1) = 0.0
      DO 11 I = 2,M
         IM1 = I - 1
         DO 10 J = 1,N
            DX(I,J) = X(I,J) - X(IM1,J)
   10    CONTINUE
         T(I) = T(IM1) + SNRM2(N,DX(I,1),KDX)
         R = T(I) - T(IM1)
         IF (R .EQ. 0.0) GO TO 200
   11 CONTINUE
C
      DO 20 J = 1,N
         DX(1,J) = X(1,J) - X(M,J)
   20 CONTINUE
      SUM = T(M) + SNRM2(N,DX(1,1),KDX)
      R = SUM - T(M)
      IF (R .EQ. 0.0) GO TO 210
C
      DO 30 I = 2,M
         T(I) = T(I)/SUM
   30 CONTINUE
      IERR = 0
C
C     FOR J = 1,...,N, A DIAGONALLY DOMINANT SET OF EQUATIONS
C     FOR THE SLOPES S(I,J) OF THE J-TH PERIODIC SPLINE AT T(I)
C     (I = 1,...,M) IS GENERATED AND SOLVED BY GAUSS ELIMINATION.
C     THE FIRST EQUATION IS OBTAINED FROM THE REQUIREMENT THAT
C     THE SPLINE BE PERIODIC. THIS EQUATION HAS THE FORM ...
C
C        A(1)*S(1,J) + B(1)*S(2,J) + C(1)*S(M,J) = DX(1,J)
C
      H = T(2)
      HM = 1.0 - T(M)
      C(1) = H
      B(1) = HM
      A(1) = 2.0*(H + HM)
      B(2) = H
C
      DO 40 J = 1,N
         DELM = DX(1,J)/HM
         DEL1 = DX(2,J)/H
         DX(1,J) = 3.0*(H*DELM + HM*DEL1)
         DX(2,J) = DEL1
   40 CONTINUE
      IF (M .EQ. 2) GO TO 70
C
C     FOR THE KNOTS T(I) (I = 2,...M-1), GENERATE THE CORRESPOND-
C     ING EQUATIONS AND CARRY OUT THE PIVOT REDUCTION OF GAUSS
C     ELIMINATION. THEN THE I-TH EQUATION HAS THE FORM ...
C
C        A(I)*S(I,J) + B(I)*S(I+1,J) + C(I)*S(M,J) = DX(I,J)
C
      DO 50 I = 2,MM1
         IM1 = I - 1
         B(I) = H
         H = T(I+1) - T(I)
         E(IM1) = H/A(IM1)
         C(I) = - E(IM1)*C(IM1)
         A(I) = 2.0*(B(I) + H) - E(IM1)*B(IM1)
   50 CONTINUE
      B(M) = H
C
      DO 61 J = 1,N
         DELI = DX(2,J)
         DO 60 I = 2,MM1
            H = B(I+1)
            DEL0 = DELI
            DELI = DX(I+1,J)/H
            DX(I,J) = 3.0*(H*DEL0 + B(I)*DELI) - E(I-1)*DX(I-1,J)
   60    CONTINUE
         DX(M,J) = DELI
   61 CONTINUE
C
C     SINCE IT IS REQUIRED THAT THE SPLINE BE PERIODIC, THE
C     EQUATION FOR THE KNOT T(M) HAS THE FORM ...
C
C        ALPHA*S(1,J) + HM*S(M-1,J) + ETA*S(M,J) = DX(M,J)
C
C     APPLYING THE PIVOTS TO THIS EQUATION, ONE OBTAINS AFTER
C     EACH PIVOT OPERATION THE MODIFIED EQUATION ...
C
C        ALPHA*S(I+1,J) + HM*S(M-1,J) + ETA*S(M,J) = DX(M,J)
C
C     THUS, WHEN THIS PIVOT REDUCTION IS COMPLETE, THE M-TH
C     EQUATION TO BE SOLVED HAS THE FORM ...
C
C        (ALPHA + HM)*S(M-1,J) + ETA*S(M,J) = DX(M,J)
C
   70 ALPHA = H
      ETA = 2.0*(H + HM)
      DO 71 J = 1,N
         DEL  = DX(M,J)
         DELM = (X(1,J) - X(M,J))/HM
         DX(M,J) = 3.0*(HM*DEL + H*DELM)
   71 CONTINUE
      IF (M .EQ. 2) GO TO 90
C
      DO 81 I = 1,MM2
         P = ALPHA/A(I)
         ALPHA = - P*B(I)
         ETA = ETA - P*C(I)
         DO 80 J = 1,N
            DX(M,J) = DX(M,J) - P*DX(I,J)
   80    CONTINUE
   81 CONTINUE
C
C     SOLVE THE LAST TWO EQUATIONS FOR S(M,J) AND S(M-1,J),
C     AND STORE THESE SLOPES IN DX.
C
   90 P = (ALPHA + HM)/A(MM1)
      TAU = B(MM1) + C(MM1)
      DO 91 J = 1,N
         SM = (DX(M,J) - P*DX(MM1,J))/(ETA - P*TAU)
         DX(M,J) = SM
         DX(MM1,J) = (DX(MM1,J) - TAU*SM)/A(MM1)
   91 CONTINUE
      IF (M .EQ. 2) RETURN
C
C     BACK SUBSTITUTION TO OBTAIN THE REMAINING SLOPES S(I,J).
C     THESE SLOPES ARE STORED IN DX.
C
      DO 101 J = 1,N
         SM = DX(M,J)
         SI = DX(MM1,J)
         I = MM1
         DO 100 L = 3,M
            I = I - 1
            SI = (DX(I,J) - B(I)*SI - C(I)*SM)/A(I)
            DX(I,J) = SI
  100    CONTINUE
  101 CONTINUE
      RETURN
C
C     ERROR RETURN
C
  200 IERR = 2
      RETURN
  210 IERR = 3
      RETURN
      END
      SUBROUTINE LOPCMP (M, N, T, X, KX, DX, KDX, L, TI, Z, KZ)
C-----------------------------------------------------------------------
C            EVALUATION OF A CUBIC SPLINE CLOSED CURVE
C                     IN N-DIMENSIONAL SPACE
C-----------------------------------------------------------------------
      REAL T(M), X(KX,N), DX(KDX,N), TI(L), Z(KZ, N)
C
C     REDUCTION OF TI(K) TO T0 WHERE 0 .LE. T0 .LT. 1
C
      K = 1
      J = TI(1)
      T0 = TI(1) - J
      IF (T0 .LT. 0.0) T0 = 1.0 + T0
      IF (T0 .GE. T(M)) GO TO 60
      IL = 1
      IR = M
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 50
      IF (T0 - T(I)) 20,50,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   40 IF (T0 .LT. T(I+1)) GO TO 50
      I = I + 1
      GO TO 40
C
C     COMPUTATION WHEN T(I) .LE. T0 .LT. T(I+1)
C
   50 H = T(I+1) - T(I)
      DT = T0 - T(I)
      DO 51 J = 1,N
         A = DX(I,J)
         D = (X(I+1,J) - X(I,J))/H
         W = A + DX(I+1,J)
         B = (-W - A + 3.0*D)/H
         C = ((W - D - D)/H)/H
         Z(K,J) = X(I,J) + DT*(A + DT*(B + DT*C))
   51 CONTINUE
      GO TO 100
C
C     COMPUTATION WHEN T0 .GE. T(M)
C
   60 I = M
      H = 1.0 - T(M)
      DT = T0 - T(M)
      DO 61 J = 1,N
         A = DX(M,J)
         D = (X(1,J) - X(M,J))/H
         W = A + DX(1,J)
         B = (-W - A + 3.0*D)/H
         C = ((W - D - D)/H)/H
         Z(K,J) = X(M,J) + DT*(A + DT*(B + DT*C))
   61 CONTINUE
C
C     NEXT POINT
C
  100 IF (K .GE. L) RETURN
      TOLD = T0
      K = K + 1
      J = TI(K)
      T0 = TI(K) - J
      IF (T0 .LT. 0.0) T0 = 1.0 + T0
      IF (T0 .GE. T(M)) GO TO 60
      IF (T0 - TOLD) 110,50,40
C
  110 IL = 1
      IR = MIN0(I+1,M)
      GO TO 10
      END
      SUBROUTINE LOPDF (M, N, T, X, KX, DX, KDX, TI, Z, DZ, DDZ)
C-----------------------------------------------------------------------
C          EVALUATION AND DIFFERENTIATION OF A CUBIC SPLINE
C                CLOSED CURVE IN N-DIMENSIONAL SPACE
C-----------------------------------------------------------------------
      REAL T(M), X(KX,N), DX(KDX,N), Z(N), DZ(N), DDZ(N)
C
C     REDUCTION OF TI TO T0 WHERE 0 .LE. T0 .LT. 1
C
      J = TI
      T0 = TI - J
      IF (T0 .LT. 0.0) T0 = 1.0 + T0
      IF (T0 .GE. T(M)) GO TO 50
      IL = 1
      IR = M
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 40
      IF (T0 - T(I)) 20,40,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     COMPUTATION WHEN T(I) .LE. T0 .LT. T(I+1)
C
   40 H = T(I+1) - T(I)
      DT = T0 - T(I)
      DO 41 J = 1,N
         A = DX(I,J)
         D = (X(I+1,J) - X(I,J))/H
         W = A + DX(I+1,J)
         B = (-W - A + 3.0*D)/H
         C = ((W - D - D)/H)/H
         Z(J) = X(I,J) + DT*(A + DT*(B + DT*C))
         B = B + B
         C = 3.0*C
         DZ(J) = A + DT*(B + C*DT)
         DDZ(J) = B + (C + C)*DT
   41 CONTINUE
      RETURN
C
C     COMPUTATION WHEN T0 .GE. T(M)
C
   50 H = 1.0 - T(M)
      DT = T0 - T(M)
      DO 51 J = 1,N
         A = DX(M,J)
         D = (X(1,J) - X(M,J))/H
         W = A + DX(1,J)
         B = (-W - A + 3.0*D)/H
         C = ((W - D - D)/H)/H
         Z(J) = X(M,J) + DT*(A + DT*(B + DT*C))
         B = B + B
         C = 3.0*C
         DZ(J) = A + DT*(B + C*DT)
         DDZ(J) = B + (C + C)*DT
   51 CONTINUE
      RETURN
      END
      SUBROUTINE CURV1 (N,X,Y,SLP1,SLPN,ISLPSW,YP,TEMP,
     *                  SIGMA,IERR)
C
      INTEGER N,ISLPSW,IERR
      REAL X(N),Y(N),SLP1,SLPN,YP(N),TEMP(N),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO
C COMPUTE AN INTERPOLATORY SPLINE UNDER TENSION THROUGH
C A SEQUENCE OF FUNCTIONAL VALUES. THE SLOPES AT THE TWO
C ENDS OF THE CURVE MAY BE SPECIFIED OR OMITTED.  FOR ACTUAL
C COMPUTATION OF POINTS ON THE CURVE IT IS NECESSARY TO CALL
C THE FUNCTION CURV2.
C
C ON INPUT--
C
C   N IS THE NUMBER OF VALUES TO BE INTERPOLATED (N.GE.2).
C
C   X IS AN ARRAY OF THE N INCREASING ABSCISSAE OF THE
C   FUNCTIONAL VALUES.
C
C   Y IS AN ARRAY OF THE N ORDINATES OF THE VALUES, (I. E.
C   Y(K) IS THE FUNCTIONAL VALUE CORRESPONDING TO X(K) ).
C
C   SLP1 AND SLPN CONTAIN THE DESIRED VALUES FOR THE FIRST
C   DERIVATIVE OF THE CURVE AT X(1) AND X(N), RESPECTIVELY.
C   THE USER MAY OMIT VALUES FOR EITHER OR BOTH OF THESE
C   PARAMETERS AND SIGNAL THIS WITH ISLPSW.
C
C   ISLPSW CONTAINS A SWITCH INDICATING WHICH SLOPE DATA
C   SHOULD BE USED AND WHICH SHOULD BE ESTIMATED BY THIS
C   SUBROUTINE,
C          = 0 IF SLP1 AND SLPN ARE TO BE USED,
C          = 1 IF SLP1 IS TO BE USED BUT NOT SLPN,
C          = 2 IF SLPN IS TO BE USED BUT NOT SLP1,
C          = 3 IF BOTH SLP1 AND SLPN ARE TO BE ESTIMATED
C              INTERNALLY.
C
C   YP IS AN ARRAY OF LENGTH AT LEAST N.
C
C   TEMP IS AN ARRAY OF LENGTH AT LEAST N WHICH IS USED FOR
C   SCRATCH STORAGE.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES
C   THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO
C   (E.G. .001) THE RESULTING CURVE IS APPROXIMATELY A
C   CUBIC SPLINE. IF ABS(SIGMA) IS LARGE (E.G. 50.) THE
C   RESULTING CURVE IS NEARLY A POLYGONAL LINE. IF SIGMA
C   EQUALS ZERO A CUBIC SPLINE RESULTS.  A STANDARD VALUE
C   FOR SIGMA IS APPROXIMATELY 1. IN ABSOLUTE VALUE.
C
C ON OUTPUT--
C
C   YP CONTAINS THE VALUES OF THE SECOND DERIVATIVE OF THE
C   CURVE AT THE GIVEN NODES.
C
C   IERR CONTAINS AN ERROR FLAG,
C        = 0 FOR NORMAL RETURN,
C        = 1 IF N IS LESS THAN 2,
C        = 2 IF X-VALUES ARE NOT STRICTLY INCREASING.
C
C AND
C
C   N, X, Y, SLP1, SLPN, ISLPSW AND SIGMA ARE UNALTERED.
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULES CEEZ, TERMS,
C AND SNHCSH.
C
C-----------------------------------------------------------
C
      NM1 = N-1
      NP1 = N+1
      IERR = 0
      IF (N .LE. 1) GO TO 8
      IF (X(N) .LE. X(1)) GO TO 9
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1))
C
C APPROXIMATE END SLOPES
C
      IF (ISLPSW .GE. 2) GO TO 1
      SLPP1 = SLP1
      GO TO 2
    1 DELX1 = X(2)-X(1)
      DELX2 = DELX1+DELX1
      IF (N .GT. 2) DELX2 = X(3)-X(1)
      IF (DELX1 .LE. 0. .OR. DELX2 .LE. DELX1) GO TO 9
      CALL CEEZ (DELX1,DELX2,SIGMAP,C1,C2,C3,N)
      SLPP1 = C1*Y(1)+C2*Y(2)
      IF (N .GT. 2) SLPP1 = SLPP1+C3*Y(3)
    2 IF (ISLPSW .EQ. 1 .OR. ISLPSW .EQ. 3) GO TO 3
      SLPPN = SLPN
      GO TO 4
    3 DELXN = X(N)-X(NM1)
      DELXNM = DELXN+DELXN
      IF (N .GT. 2) DELXNM = X(N)-X(N-2)
      IF (DELXN .LE. 0. .OR. DELXNM .LE. DELXN) GO TO 9
      CALL CEEZ (-DELXN,-DELXNM,SIGMAP,C1,C2,C3,N)
      SLPPN = C1*Y(N)+C2*Y(NM1)
      IF (N .GT. 2) SLPPN = SLPPN+C3*Y(N-2)
C
C SET UP RIGHT HAND SIDE AND TRIDIAGONAL SYSTEM FOR YP AND
C PERFORM FORWARD ELIMINATION
C
    4 DELX1 = X(2)-X(1)
      IF (DELX1 .LE. 0.) GO TO 9
      DX1 = (Y(2)-Y(1))/DELX1
      CALL TERMS (DIAG1,SDIAG1,SIGMAP,DELX1)
      YP(1) = (DX1-SLPP1)/DIAG1
      TEMP(1) = SDIAG1/DIAG1
      IF (N .EQ. 2) GO TO 6
      DO 5 I = 2,NM1
        DELX2 = X(I+1)-X(I)
        IF (DELX2 .LE. 0.) GO TO 9
        DX2 = (Y(I+1)-Y(I))/DELX2
        CALL TERMS (DIAG2,SDIAG2,SIGMAP,DELX2)
        DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1)
        YP(I) = (DX2-DX1-SDIAG1*YP(I-1))/DIAG
        TEMP(I) = SDIAG2/DIAG
        DX1 = DX2
        DIAG1 = DIAG2
    5   SDIAG1 = SDIAG2
    6 DIAG = DIAG1-SDIAG1*TEMP(NM1)
      YP(N) = (SLPPN-DX1-SDIAG1*YP(NM1))/DIAG
C
C PERFORM BACK SUBSTITUTION
C
      DO 7 I = 2,N
        IBAK = NP1-I
    7   YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1)
      RETURN
C
C TOO FEW POINTS
C
    8 IERR = 1
      RETURN
C
C X-VALUES NOT STRICTLY INCREASING
C
    9 IERR = 2
      RETURN
      END
      FUNCTION CURV2 (T,N,X,Y,YP,SIGMA)
C
      INTEGER N
      REAL T,X(N),Y(N),YP(N),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS FUNCTION INTERPOLATES A CURVE AT A GIVEN POINT
C USING A SPLINE UNDER TENSION. THE SUBROUTINE CURV1 SHOULD
C BE CALLED EARLIER TO DETERMINE CERTAIN NECESSARY
C PARAMETERS.
C
C ON INPUT--
C
C   T CONTAINS A REAL VALUE TO BE MAPPED ONTO THE INTERPO-
C   LATING CURVE.
C
C   N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED TO
C   DETERMINE THE CURVE.
C
C   X AND Y ARE ARRAYS CONTAINING THE ABSCISSAE AND
C   ORDINATES, RESPECTIVELY, OF THE SPECIFIED POINTS.
C
C   YP IS AN ARRAY OF SECOND DERIVATIVE VALUES OF THE CURVE
C   AT THE NODES.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS N, X, Y, YP, AND SIGMA SHOULD BE INPUT
C UNALTERED FROM THE OUTPUT OF CURV1.
C
C ON OUTPUT--
C
C   CURV2 CONTAINS THE INTERPOLATED VALUE.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS FUNCTION REFERENCES PACKAGE MODULES INTRVL AND
C SNHCSH.
C
C-----------------------------------------------------------
C
C DETERMINE INTERVAL
C
      IM1 = INTRVL(T,X,N)
      I = IM1+1
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1))
C
C SET UP AND PERFORM INTERPOLATION
C
      DEL1 = T-X(IM1)
      DEL2 = X(I)-T
      DELS = X(I)-X(IM1)
      SUM = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS
      IF (SIGMAP .NE. 0.) GO TO 1
      CURV2 = SUM-DEL1*DEL2*(YP(I)*(DEL1+DELS)+YP(IM1)*
     *        (DEL2+DELS))/(6.*DELS)
      RETURN
    1 DELP1 = SIGMAP*(DEL1+DELS)/2.
      DELP2 = SIGMAP*(DEL2+DELS)/2.
      CALL SNHCSH (SINHM1,DUMMY,SIGMAP*DEL1,-1)
      CALL SNHCSH (SINHM2,DUMMY,SIGMAP*DEL2,-1)
      CALL SNHCSH (SINHMS,DUMMY,SIGMAP*DELS,-1)
      CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1)
      CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1)
      CALL SNHCSH (DUMMY,COSHP1,DELP1,1)
      CALL SNHCSH (DUMMY,COSHP2,DELP2,1)
      CURV2 = SUM+(YP(I)*(SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*
     *        SINHP2+SIGMAP*COSHP1*DEL2))+YP(IM1)*(SINHM2*
     *        DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+SIGMAP*
     *        COSHP2*DEL1)))/(SIGMAP*SIGMAP*DELS*(SINHMS+
     *        SIGMAP*DELS))
      RETURN
      END
      FUNCTION CURVD (T,N,X,Y,YP,SIGMA)
C
      INTEGER N
      REAL T,X(N),Y(N),YP(N),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS FUNCTION DIFFERENTIATES A CURVE AT A GIVEN POINT
C USING A SPLINE UNDER TENSION. THE SUBROUTINE CURV1 SHOULD
C BE CALLED EARLIER TO DETERMINE CERTAIN NECESSARY
C PARAMETERS.
C
C ON INPUT--
C
C   T CONTAINS A REAL VALUE AT WHICH THE DERIVATIVE IS TO BE
C   DETERMINED.
C
C   N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED TO
C   DETERMINE THE CURVE.
C
C   X AND Y ARE ARRAYS CONTAINING THE ABSCISSAE AND
C   ORDINATES, RESPECTIVELY, OF THE SPECIFIED POINTS.
C
C   YP IS AN ARRAY OF SECOND DERIVATIVE VALUES OF THE CURVE
C   AT THE NODES.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS N, X, Y, YP, AND SIGMA SHOULD BE INPUT
C UNALTERED FROM THE OUTPUT OF CURV1.
C
C ON OUTPUT--
C
C   CURVD CONTAINS THE DERIVATIVE VALUE.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS FUNCTION REFERENCES PACKAGE MODULES INTRVL AND
C SNHCSH.
C
C-----------------------------------------------------------
C
C DETERMINE INTERVAL
C
      IM1 = INTRVL(T,X,N)
      I = IM1+1
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1))
C
C SET UP AND PERFORM DIFFERENTIATION
C
      DEL1 = T-X(IM1)
      DEL2 = X(I)-T
      DELS = X(I)-X(IM1)
      SUM = (Y(I)-Y(IM1))/DELS
      IF (SIGMAP .NE. 0.) GO TO 1
      CURVD = SUM+(YP(I)*(2.*DEL1*DEL1-DEL2*(DEL1+DELS))-
     *             YP(IM1)*(2.*DEL2*DEL2-DEL1*(DEL2+DELS)))
     *             /(6.*DELS)
      RETURN
    1 CALL SNHCSH (DUMMY,COSHM1,SIGMAP*DEL1,1)
      CALL SNHCSH (DUMMY,COSHM2,SIGMAP*DEL2,1)
      CALL SNHCSH (SINHMS,DUMMY,SIGMAP*DELS,-1)
      CURVD = SUM+(YP(I)*(DELS*SIGMAP*COSHM1-SINHMS)-
     *        YP(IM1)*(DELS*SIGMAP*COSHM2-SINHMS))/
     *        (SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS))
      RETURN
      END
      FUNCTION CURVI (XL,XU,N,X,Y,YP,SIGMA)
C
      INTEGER N
      REAL XL,XU,X(N),Y(N),YP(N),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS FUNCTION INTEGRATES A CURVE SPECIFIED BY A SPLINE
C UNDER TENSION BETWEEN TWO GIVEN LIMITS. THE SUBROUTINE
C CURV1 SHOULD BE CALLED EARLIER TO DETERMINE NECESSARY
C PARAMETERS.
C
C ON INPUT--
C
C   XL AND XU CONTAIN THE LOWER AND UPPER LIMITS OF INTE-
C   GRATION, RESPECTIVELY. (XL NEED NOT BE LESS THAN OR
C   EQUAL TO XU, CURVI (XL,XU,...) .EQ. -CURVI (XU,XL,...) ).
C
C   N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED TO
C   DETERMINE THE CURVE.
C
C   X AND Y ARE ARRAYS CONTAINING THE ABSCISSAE AND
C   ORDINATES, RESPECTIVELY, OF THE SPECIFIED POINTS.
C
C   YP IS AN ARRAY OF SECOND DERIVATIVE VALUES OF THE CURVE
C   AT THE NODES.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS N, X, Y, YP, AND SIGMA SHOULD BE INPUT
C UNALTERED FROM THE OUTPUT OF CURV1.
C
C ON OUTPUT--
C
C   CURVI CONTAINS THE INTEGRAL VALUE.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS FUNCTION REFERENCES PACKAGE MODULES INTRVL AND
C SNHCSH.
C
C-----------------------------------------------------------
C
C STATEMENT FUNCTION FOR COEFFICIENT ASSOCIATED WITH
C DERIVATIVE TERMS
C
      TERM (CMM1,CMM2,T) = (CMM1-CMM2-SIGMAP*T*SS)/(SIGMAP*
     *                     SIGMAP*SIGMAP*(SS+SIGMAP*DELS))
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1))
C
C DETERMINE ACTUAL UPPER AND LOWER BOUNDS
C
      XXL = XL
      XXU = XU
      SSIGN = 1.
      IF (XL .LT. XU) GO TO 1
      XXL = XU
      XXU = XL
      SSIGN = -1.
      IF (XL .GT. XU) GO TO 1
C
C RETURN ZERO IF XL .EQ. XU
C
      CURVI = 0.
      RETURN
C
C SEARCH FOR PROPER INTERVALS
C
    1 ILM1 = INTRVL (XXL,X,N)
      IL = ILM1+1
      IUM1 = INTRVL (XXU,X,N)
      IU = IUM1+1
      IF (IL .EQ. IU) GO TO 8
C
C INTEGRATE FROM XXL TO X(IL)
C
      SUM = 0.
      IF (XXL .EQ. X(IL)) GO TO 3
      DEL1 = XXL-X(ILM1)
      DEL2 = X(IL)-XXL
      DELS = X(IL)-X(ILM1)
      T1 = (DEL1+DELS)*DEL2/(2.*DELS)
      T2 = DEL2*DEL2/(2.*DELS)
      SUM = T1*Y(IL)+T2*Y(ILM1)
      IF (SIGMA .EQ. 0.) GO TO 2
      CALL SNHCSH (DUMMY,C1,SIGMAP*DEL1,2)
      CALL SNHCSH (DUMMY,C2,SIGMAP*DEL2,2)
      CALL SNHCSH (SS,CS,SIGMAP*DELS,3)
      SUM = SUM+TERM(CS,C1,T1)*YP(IL)
     *         +TERM(C2,0.,T2)*YP(ILM1)
      GO TO 3
    2 SUM = SUM-T1*T1*DELS*YP(IL)/6.
     *         -T2*(DEL1*(DEL2+DELS)+DELS*DELS)*YP(ILM1)/12.
C
C INTEGRATE OVER INTERIOR INTERVALS
C
    3 IF (IU-IL .EQ. 1) GO TO 6
      ILP1 = IL+1
      DO 5 I = ILP1,IUM1
        DELS = X(I)-X(I-1)
        SUM = SUM+(Y(I)+Y(I-1))*DELS/2.
        IF (SIGMA .EQ. 0.) GO TO 4
        CALL SNHCSH (SS,CS,SIGMAP*DELS,3)
        SUM = SUM+(YP(I)+YP(I-1))*(CS-SS*SIGMAP*DELS/2.)/
     *            (SIGMAP*SIGMAP*SIGMAP*(SS+SIGMAP*DELS))
        GO TO 5
    4   SUM = SUM-(YP(I)+YP(I-1))*DELS*DELS*DELS/24.
    5   CONTINUE
C
C INTEGRATE FROM X(IU-1) TO XXU
C
    6 IF (XXU .EQ. X(IUM1)) GO TO 10
      DEL1 = XXU-X(IUM1)
      DEL2 = X(IU)-XXU
      DELS = X(IU)-X(IUM1)
      T1 = DEL1*DEL1/(2.*DELS)
      T2 = (DEL2+DELS)*DEL1/(2.*DELS)
      SUM = SUM+T1*Y(IU)+T2*Y(IUM1)
      IF (SIGMA .EQ. 0.) GO TO 7
      CALL SNHCSH (DUMMY,C1,SIGMAP*DEL1,2)
      CALL SNHCSH (DUMMY,C2,SIGMAP*DEL2,2)
      CALL SNHCSH (SS,CS,SIGMAP*DELS,3)
      SUM = SUM+TERM(C1,0.,T1)*YP(IU)
     *         +TERM(CS,C2,T2)*YP(IUM1)
      GO TO 10
    7 SUM = SUM-T1*(DEL2*(DEL1+DELS)+DELS*DELS)*YP(IU)/12.
     *         -T2*T2*DELS*YP(IUM1)/6.
      GO TO 10
C
C INTEGRATE FROM XXL TO XXU
C
    8 DELU1 = XXU-X(IUM1)
      DELU2 = X(IU)-XXU
      DELL1 = XXL-X(IUM1)
      DELL2 = X(IU)-XXL
      DELS = X(IU)-X(IUM1)
      DELI = XXU-XXL
      T1 = (DELU1+DELL1)*DELI/(2.*DELS)
      T2 = (DELU2+DELL2)*DELI/(2.*DELS)
      SUM = T1*Y(IU)+T2*Y(IUM1)
      IF (SIGMA .EQ. 0.) GO TO 9
      CALL SNHCSH (DUMMY,CU1,SIGMAP*DELU1,2)
      CALL SNHCSH (DUMMY,CU2,SIGMAP*DELU2,2)
      CALL SNHCSH (DUMMY,CL1,SIGMAP*DELL1,2)
      CALL SNHCSH (DUMMY,CL2,SIGMAP*DELL2,2)
      CALL SNHCSH (SS,DUMMY,SIGMAP*DELS,-1)
      SUM = SUM+TERM(CU1,CL1,T1)*YP(IU)
     *         +TERM(CL2,CU2,T2)*YP(IUM1)
      GO TO 10
    9 SUM = SUM-T1*(DELU2*(DELS+DELU1)+DELL2*(DELS+DELL1))*
     *             YP(IU)/12.
     *         -T2*(DELL1*(DELS+DELL2)+DELU1*(DELS+DELU2))*
     *             YP(IUM1)/12.
C
C CORRECT SIGN AND RETURN
C
   10 CURVI = SSIGN*SUM
      RETURN
      END
      SUBROUTINE KURV1 (N,X,Y,SLP1,SLPN,ISLPSW,XP,YP,TEMP,S,
     *                  SIGMA,IERR)
C
      INTEGER N,ISLPSW,IERR
      REAL X(N),Y(N),SLP1,SLPN,XP(N),YP(N),TEMP(N),S(N),
     *     SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO
C COMPUTE A SPLINE UNDER TENSION FORMING A CURVE IN THE
C PLANE AND PASSING THROUGH A SEQUENCE OF PAIRS (X(1),Y(1)),
C ...,(X(N),Y(N)). FOR ACTUAL COMPUTATION OF POINTS ON THE
C CURVE IT IS NECESSARY TO CALL THE SUBROUTINE KURV2.
C
C ON INPUT--
C
C   N IS THE NUMBER OF POINTS TO BE INTERPOLATED (N.GE.2).
C
C   X IS AN ARRAY CONTAINING THE N X-COORDINATES OF THE
C   POINTS.
C
C   Y IS AN ARRAY CONTAINING THE N Y-COORDINATES OF THE
C   POINTS. (ADJACENT X-Y PAIRS MUST BE DISTINCT, I. E.
C   EITHER X(I) .NE. X(I+1) OR Y(I) .NE. Y(I+1), FOR
C   I = 1,...,N-1.)
C
C   SLP1 AND SLPN CONTAIN THE DESIRED VALUES FOR THE ANGLES
C   (IN RADIANS) OF THE SLOPE AT (X(1),Y(1)) AND (X(N),Y(N))
C   RESPECTIVELY. THE ANGLES ARE MEASURED COUNTER-CLOCK-
C   WISE FROM THE X-AXIS AND THE POSITIVE SENSE OF THE CURVE
C   IS ASSUMED TO BE THAT MOVING FROM POINT 1 TO POINT N.
C   THE USER MAY OMIT VALUES FOR EITHER OR BOTH OF THESE
C   PARAMETERS AND SIGNAL THIS WITH ISLPSW.
C
C   ISLPSW CONTAINS A SWITCH INDICATING WHICH SLOPE DATA
C   SHOULD BE USED AND WHICH SHOULD BE ESTIMATED BY THIS
C   SUBROUTINE,
C          = 0 IF SLP1 AND SLPN ARE TO BE USED,
C          = 1 IF SLP1 IS TO BE USED BUT NOT SLPN,
C          = 2 IF SLPN IS TO BE USED BUT NOT SLP1,
C          = 3 IF BOTH SLP1 AND SLPN ARE TO BE ESTIMATED
C              INTERNALLY.
C
C   XP AND YP ARE ARRAYS OF LENGTH AT LEAST N.
C
C   TEMP IS AN ARRAY OF LENGTH AT LEAST N WHICH IS USED
C   FOR SCRATCH STORAGE.
C
C   S IS AN ARRAY OF LENGTH AT LEAST N.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES
C   THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO
C   (E.G. .001) THE RESULTING CURVE IS APPROXIMATELY A CUBIC
C   SPLINE. IF ABS(SIGMA) IS LARGE (E. G. 50.) THE RESULTING
C   CURVE IS NEARLY A POLYGONAL LINE. IF SIGMA EQUALS ZERO A
C   CUBIC SPLINE RESULTS. A STANDARD VALUE FOR SIGMA IS
C   APPROXIMATELY 1. IN ABSOLUTE VALUE.
C
C ON OUTPUT--
C
C   XP AND YP CONTAIN INFORMATION ABOUT THE CURVATURE OF THE
C   CURVE AT THE GIVEN NODES.
C
C   S CONTAINS THE POLYGONAL ARCLENGTHS OF THE CURVE.
C
C   IERR CONTAINS AN ERROR FLAG,
C        = 0 FOR NORMAL RETURN,
C        = 1 IF N IS LESS THAN 2,
C        = 2 IF ADJACENT COORDINATE PAIRS COINCIDE.
C
C AND
C
C   N, X, Y, SLP1, SLPN, ISLPSW, AND SIGMA ARE UNALTERED.
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULES CEEZ, TERMS,
C AND SNHCSH.
C
C-----------------------------------------------------------
C
      NM1 = N-1
      NP1 = N+1
      IERR = 0
      IF (N .LE. 1) GO TO 11
C
C DETERMINE POLYGONAL ARCLENGTHS
C
      S(1) = 0.
      DO 1 I = 2,N
        IM1 = I-1
    1   S(I) = S(IM1)+SQRT((X(I)-X(IM1))**2+
     *         (Y(I)-Y(IM1))**2)
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S(N)
C
C APPROXIMATE END SLOPES
C
      IF (ISLPSW .GE. 2) GO TO 2
      SLPP1X = COS(SLP1)
      SLPP1Y = SIN(SLP1)
      GO TO 4
    2 DELS1 = S(2)-S(1)
      DELS2 = DELS1+DELS1
      IF (N .GT. 2) DELS2 = S(3)-S(1)
      IF (DELS1 .EQ. 0. .OR. DELS2 .EQ. 0.) GO TO 12
      CALL CEEZ (DELS1,DELS2,SIGMAP,C1,C2,C3,N)
      SX = C1*X(1)+C2*X(2)
      SY = C1*Y(1)+C2*Y(2)
      IF (N .EQ. 2) GO TO 3
      SX = SX+C3*X(3)
      SY = SY+C3*Y(3)
    3 DELT = SQRT(SX*SX+SY*SY)
      SLPP1X = SX/DELT
      SLPP1Y = SY/DELT
    4 IF (ISLPSW .EQ. 1 .OR. ISLPSW .EQ. 3) GO TO 5
      SLPPNX = COS(SLPN)
      SLPPNY = SIN(SLPN)
      GO TO 7
    5 DELSN = S(N)-S(NM1)
      DELSNM = DELSN+DELSN
      IF (N .GT. 2) DELSNM = S(N)-S(N-2)
      IF (DELSN .EQ. 0. .OR. DELSNM .EQ. 0.) GO TO 12
      CALL CEEZ (-DELSN,-DELSNM,SIGMAP,C1,C2,C3,N)
      SX = C1*X(N)+C2*X(NM1)
      SY = C1*Y(N)+C2*Y(NM1)
      IF (N .EQ. 2) GO TO 6
      SX = SX+C3*X(N-2)
      SY = SY+C3*Y(N-2)
    6 DELT = SQRT(SX*SX+SY*SY)
      SLPPNX = SX/DELT
      SLPPNY = SY/DELT
C
C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR XP AND
C YP AND PERFORM FORWARD ELIMINATION
C
    7 DX1 = (X(2)-X(1))/S(2)
      DY1 = (Y(2)-Y(1))/S(2)
      CALL TERMS (DIAG1,SDIAG1,SIGMAP,S(2))
      XP(1) = (DX1-SLPP1X)/DIAG1
      YP(1) = (DY1-SLPP1Y)/DIAG1
      TEMP(1) = SDIAG1/DIAG1
      IF (N .EQ. 2) GO TO 9
      DO 8 I = 2,NM1
        DELS2 = S(I+1)-S(I)
        IF (DELS2 .EQ. 0.) GO TO 12
        DX2 = (X(I+1)-X(I))/DELS2
        DY2 = (Y(I+1)-Y(I))/DELS2
        CALL TERMS (DIAG2,SDIAG2,SIGMAP,DELS2)
        DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1)
        DIAGIN = 1./DIAG
        XP(I) = (DX2-DX1-SDIAG1*XP(I-1))*DIAGIN
        YP(I) = (DY2-DY1-SDIAG1*YP(I-1))*DIAGIN
        TEMP(I) = SDIAG2*DIAGIN
        DX1 = DX2
        DY1 = DY2
        DIAG1 = DIAG2
    8   SDIAG1 = SDIAG2
    9 DIAG = DIAG1-SDIAG1*TEMP(NM1)
      XP(N) = (SLPPNX-DX1-SDIAG1*XP(NM1))/DIAG
      YP(N) = (SLPPNY-DY1-SDIAG1*YP(NM1))/DIAG
C
C PERFORM BACK SUBSTITUTION
C
      DO 10 I = 2,N
        IBAK = NP1-I
        XP(IBAK) = XP(IBAK)-TEMP(IBAK)*XP(IBAK+1)
   10   YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1)
      RETURN
C
C TOO FEW POINTS
C
   11 IERR = 1
      RETURN
C
C COINCIDENT ADJACENT POINTS
C
   12 IERR = 2
      RETURN
      END
      SUBROUTINE KURV2 (T,XS,YS,N,X,Y,XP,YP,S,SIGMA)
C
      INTEGER N
      REAL T,XS,YS,X(N),Y(N),XP(N),YP(N),S(N),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE PERFORMS THE MAPPING OF POINTS IN THE
C INTERVAL (0.,1.) ONTO A CURVE IN THE PLANE. THE SUBROUTINE
C KURV1 SHOULD BE CALLED EARLIER TO DETERMINE CERTAIN
C NECESSARY PARAMETERS. THE RESULTING CURVE HAS A PARAMETRIC
C REPRESENTATION BOTH OF WHOSE COMPONENTS ARE SPLINES UNDER
C TENSION AND FUNCTIONS OF THE POLYGONAL ARCLENGTH
C PARAMETER.
C
C ON INPUT--
C
C   T CONTAINS A REAL VALUE TO BE MAPPED TO A POINT ON THE
C   CURVE. THE INTERVAL (0.,1.) IS MAPPED ONTO THE ENTIRE
C   CURVE, WITH 0. MAPPING TO (X(1),Y(1)) AND 1. MAPPING
C   TO (X(N),Y(N)). VALUES OUTSIDE THIS INTERVAL RESULT IN
C   EXTRAPOLATION.
C
C   N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED
C   TO DETERMINE THE CURVE.
C
C   X AND Y ARE ARRAYS CONTAINING THE X- AND Y-COORDINATES
C   OF THE SPECIFIED POINTS.
C
C   XP AND YP ARE THE ARRAYS OUTPUT FROM KURV1 CONTAINING
C   CURVATURE INFORMATION.
C
C   S IS AN ARRAY CONTAINING THE POLYGONAL ARCLENGTHS OF
C   THE CURVE.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS N, X, Y, XP, YP, S, AND SIGMA SHOULD BE
C INPUT UNALTERED FROM THE OUTPUT OF KURV1.
C
C ON OUTPUT--
C
C   XS AND YS CONTAIN THE X- AND Y-COORDINATES OF THE IMAGE
C   POINT ON THE CURVE.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULES INTRVL AND
C SNHCSH.
C
C-----------------------------------------------------------
C
C DETERMINE INTERVAL
C
      TN = S(N)*T
      IM1 = INTRVL(TN,S,N)
      I = IM1+1
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S(N)
C
C SET UP AND PERFORM INTERPOLATION
C
      DEL1 = TN-S(IM1)
      DEL2 = S(I)-TN
      DELS = S(I)-S(IM1)
      SUMX = (X(I)*DEL1+X(IM1)*DEL2)/DELS
      SUMY = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS
      IF (SIGMAP .NE. 0.) GO TO 1
      D = DEL1*DEL2/(6.*DELS)
      C1 = (DEL1+DELS)*D
      C2 = (DEL2+DELS)*D
      XS = SUMX-XP(I)*C1-XP(IM1)*C2
      YS = SUMY-YP(I)*C1-YP(IM1)*C2
      RETURN
    1 DELP1 = SIGMAP*(DEL1+DELS)/2.
      DELP2 = SIGMAP*(DEL2+DELS)/2.
      CALL SNHCSH(SINHM1,DUMMY,SIGMAP*DEL1,-1)
      CALL SNHCSH(SINHM2,DUMMY,SIGMAP*DEL2,-1)
      CALL SNHCSH(SINHMS,DUMMY,SIGMAP*DELS,-1)
      CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1)
      CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1)
      CALL SNHCSH (DUMMY,COSHP1,DELP1,1)
      CALL SNHCSH (DUMMY,COSHP2,DELP2,1)
      D = SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS)
      C1 = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*SINHP2+SIGMAP*
     *     COSHP1*DEL2))/D
      C2 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+SIGMAP*
     *     COSHP2*DEL1))/D
      XS = SUMX+XP(I)*C1+XP(IM1)*C2
      YS = SUMY+YP(I)*C1+YP(IM1)*C2
      RETURN
      END
      SUBROUTINE KURVP1 (N,X,Y,XP,YP,TEMP,S,SIGMA,IERR)
C
      INTEGER N,IERR
      REAL X(N),Y(N),XP(N),YP(N),TEMP(*),S(N),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO
C COMPUTE A SPLINE UNDER TENSION FORMING A CLOSED CURVE IN
C THE PLANE AND PASSING THROUGH A SEQUENCE OF PAIRS
C (X(1),Y(1)),...,(X(N),Y(N)). FOR ACTUAL COMPUTATION OF
C POINTS ON THE CURVE IT IS NECESSARY TO CALL THE SUBROUTINE
C KURVP2.
C
C ON INPUT--
C
C   N IS THE NUMBER OF POINTS TO BE INTERPOLATED (N.GE.2).
C
C   X IS AN ARRAY CONTAINING THE N X-COORDINATES OF THE
C   POINTS.
C
C   Y IS AN ARRAY CONTAINING THE N Y-COORDINATES OF THE
C   POINTS. (ADJACENT X-Y PAIRS MUST BE DISTINCT, I. E.
C   EITHER X(I) .NE. X(I+1) OR Y(I) .NE. Y(I+1), FOR
C   I = 1,...,N-1.)
C
C   XP AND YP ARE ARRAYS OF LENGTH AT LEAST N.
C
C   TEMP IS AN ARRAY OF LENGTH AT LEAST 2*N WHICH IS USED
C   FOR SCRATCH STORAGE.
C
C   S IS AN ARRAY OF LENGTH AT LEAST N.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES
C   THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO
C   (E.G. .001) THE RESULTING CURVE IS APPROXIMATELY A CUBIC
C   SPLINE. IF ABS(SIGMA) IS LARGE (E. G. 50.) THE RESULTING
C   CURVE IS NEARLY A POLYGONAL LINE. IF SIGMA EQUALS ZERO A
C   CUBIC SPLINE RESULTS. A STANDARD VALUE FOR SIGMA IS
C   APPROXIMATELY 1. IN ABSOLUTE VALUE.
C
C ON OUTPUT--
C
C   XP AND YP CONTAIN INFORMATION ABOUT THE CURVATURE OF THE
C   CURVE AT THE GIVEN NODES.
C
C   S CONTAINS THE POLYGONAL ARCLENGTHS OF THE CURVE.
C
C   IERR CONTAINS AN ERROR FLAG,
C        = 0 FOR NORMAL RETURN,
C        = 1 IF N IS LESS THAN 2,
C        = 2 IF ADJACENT COORDINATE PAIRS COINCIDE.
C
C AND
C
C   N, X, Y, AND SIGMA ARE UNALTERED,
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULES TERMS AND
C SNHCSH.
C
C-----------------------------------------------------------
C
      NM1 = N-1
      NP1 = N+1
      IERR = 0
      IF (N .LE. 1) GO TO 7
C
C DETERMINE POLYGONAL ARCLENGTHS
C
      S(1) = SQRT((X(N)-X(1))**2+(Y(N)-Y(1))**2)
      DO 1 I = 2,N
        IM1 = I-1
    1   S(I) = S(IM1)+SQRT((X(I)-X(IM1))**2+
     *         (Y(I)-Y(IM1))**2)
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N)/S(N)
C
C SET UP RIGHT HAND SIDES OF TRIDIAGONAL (WITH CORNER
C ELEMENTS) LINEAR SYSTEM FOR XP AND YP
C
      DELS1 = S(1)
      IF (DELS1 .EQ. 0.) GO TO 8
      DX1 = (X(1)-X(N))/DELS1
      DY1 = (Y(1)-Y(N))/DELS1
      CALL TERMS(DIAG1,SDIAG1,SIGMAP,DELS1)
      DELS2 = S(2)-S(1)
      IF (DELS2 .EQ. 0.) GO TO 8
      DX2 = (X(2)-X(1))/DELS2
      DY2 = (Y(2)-Y(1))/DELS2
      CALL TERMS(DIAG2,SDIAG2,SIGMAP,DELS2)
      DIAG = DIAG1+DIAG2
      DIAGIN = 1./DIAG
      XP(1) = (DX2-DX1)*DIAGIN
      YP(1) = (DY2-DY1)*DIAGIN
      TEMP(NP1) = -SDIAG1*DIAGIN
      TEMP(1) = SDIAG2*DIAGIN
      DX1 = DX2
      DY1 = DY2
      DIAG1 = DIAG2
      SDIAG1 = SDIAG2
      IF (N .EQ. 2) GO TO 3
      DO 2 I = 2,NM1
        NPI = N+I
        DELS2 = S(I+1)-S(I)
        IF (DELS2 .EQ. 0.) GO TO 8
        DX2 = (X(I+1)-X(I))/DELS2
        DY2 = (Y(I+1)-Y(I))/DELS2
        CALL TERMS(DIAG2,SDIAG2,SIGMAP,DELS2)
        DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1)
        DIAGIN = 1./DIAG
        XP(I) = (DX2-DX1-SDIAG1*XP(I-1))*DIAGIN
        YP(I) = (DY2-DY1-SDIAG1*YP(I-1))*DIAGIN
        TEMP(NPI) = -TEMP(NPI-1)*SDIAG1*DIAGIN
        TEMP(I) = SDIAG2*DIAGIN
        DX1 = DX2
        DY1 = DY2
        DIAG1 = DIAG2
    2   SDIAG1 = SDIAG2
    3 DELS2 = S(1)
      DX2 = (X(1)-X(N))/DELS2
      DY2 = (Y(1)-Y(N))/DELS2
      CALL TERMS(DIAG2,SDIAG2,SIGMAP,DELS2)
      XP(N) = DX2-DX1
      YP(N) = DY2-DY1
      TEMP(NM1) = TEMP(2*N-1)-TEMP(NM1)
      IF (N.EQ.2) GO TO 5
C
C PERFORM FIRST STEP OF BACK SUBSTITUTION
C
      DO 4 I = 3,N
        IBAK = NP1-I
        NPIBAK = N+IBAK
        XP(IBAK) = XP(IBAK)-TEMP(IBAK)*XP(IBAK+1)
        YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1)
    4   TEMP(IBAK) = TEMP(NPIBAK)-TEMP(IBAK)*TEMP(IBAK+1)
    5 XP(N) = (XP(N)-SDIAG2*XP(1)-SDIAG1*XP(NM1))/
     *        (DIAG1+DIAG2+SDIAG2*TEMP(1)+SDIAG1*TEMP(NM1))
      YP(N) = (YP(N)-SDIAG2*YP(1)-SDIAG1*YP(NM1))/
     *        (DIAG1+DIAG2+SDIAG2*TEMP(1)+SDIAG1*TEMP(NM1))
C
C PERFORM SECOND STEP OF BACK SUBSTITUTION
C
      XPN = XP(N)
      YPN = YP(N)
      DO 6 I = 1,NM1
        XP(I) = XP(I)+TEMP(I)*XPN
    6   YP(I) = YP(I)+TEMP(I)*YPN
      RETURN
C
C TOO FEW POINTS
C
    7 IERR = 1
      RETURN
C
C COINCIDENT ADJACENT POINTS
C
    8 IERR = 2
      RETURN
      END
      SUBROUTINE KURVP2 (T,XS,YS,N,X,Y,XP,YP,S,SIGMA)
C
      INTEGER N
      REAL T,XS,YS,X(N),Y(N),XP(N),YP(N),S(N),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE PERFORMS THE MAPPING OF POINTS IN THE
C INTERVAL (0.,1.) ONTO A CLOSED CURVE IN THE PLANE. THE
C SUBROUTINE KURVP1 SHOULD BE CALLED EARLIER TO DETERMINE
C CERTAIN NECESSARY PARAMETERS. THE RESULTING CURVE HAS A
C PARAMETRIC REPRESENTATION BOTH OF WHOSE COMPONENTS ARE
C PERIODIC SPLINES UNDER TENSION AND FUNCTIONS OF THE POLY-
C GONAL ARCLENGTH PARAMETER.
C
C ON INPUT--
C
C   T CONTAINS A VALUE TO BE MAPPED ONTO THE CURVE. THE
C   INTERVAL (0.,1.) IS MAPPED ONTO THE ENTIRE CLOSED CURVE
C   WITH BOTH 0. AND 1. MAPPING TO (X(1),Y(1)). THE MAPPING
C   IS PERIODIC WITH PERIOD ONE THUS ANY INTERVAL OF THE
C   FORM (TT,TT+1.) MAPS ONTO THE ENTIRE CURVE.
C
C   N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED
C   TO DETERMINE THE CURVE.
C
C   X AND Y ARE ARRAYS CONTAINING THE X- AND Y-COORDINATES
C   OF THE SPECIFIED POINTS.
C
C   XP AND YP ARE THE ARRAYS OUTPUT FROM KURVP1 CONTAINING
C   CURVATURE INFORMATION.
C
C   S IS AN ARRAY CONTAINING THE POLYGONAL ARCLENGTHS OF
C   THE CURVE.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS N, X, Y, XP, YP, S AND SIGMA SHOULD
C BE INPUT UNALTERED FROM THE OUTPUT OF KURVP1.
C
C ON OUTPUT--
C
C   XS AND YS CONTAIN THE X- AND Y-COORDINATES OF THE IMAGE
C   POINT ON THE CURVE.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULES INTRVL AND
C SNHCSH.
C
C-----------------------------------------------------------
C
C DETERMINE INTERVAL
C
      TN = T-FLOAT(IFIX(T))
      IF (TN .LT. 0.) TN = TN+1.
      TN = S(N)*TN+S(1)
      IM1 = N
      IF (TN .LT. S(N)) IM1 = INTRVL(TN,S,N)
      I = IM1+1
      IF (I .GT. N) I = 1
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N)/S(N)
C
C SET UP AND PERFORM INTERPOLATION
C
      SI = S(I)
      IF (IM1 .EQ. N) SI = S(N)+S(1)
      DEL1 = TN-S(IM1)
      DEL2 = SI-TN
      DELS = SI-S(IM1)
      SUMX = (X(I)*DEL1+X(IM1)*DEL2)/DELS
      SUMY = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS
      IF (SIGMAP .NE. 0.) GO TO 1
      D = DEL1*DEL2/(6.*DELS)
      C1 = (DEL1+DELS)*D
      C2 = (DEL2+DELS)*D
      XS = SUMX-XP(I)*C1-XP(IM1)*C2
      YS = SUMY-YP(I)*C1-YP(IM1)*C2
      RETURN
    1 DELP1 = SIGMAP*(DEL1+DELS)/2.
      DELP2 = SIGMAP*(DEL2+DELS)/2.
      CALL SNHCSH(SINHM1,DUMMY,SIGMAP*DEL1,-1)
      CALL SNHCSH(SINHM2,DUMMY,SIGMAP*DEL2,-1)
      CALL SNHCSH(SINHMS,DUMMY,SIGMAP*DELS,-1)
      CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1)
      CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1)
      CALL SNHCSH (DUMMY,COSHP1,DELP1,1)
      CALL SNHCSH (DUMMY,COSHP2,DELP2,1)
      D = SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS)
      CI = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*SINHP2+SIGMAP*
     *     COSHP1*DEL2))/D
      CIM1 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+
     *       SIGMAP*COSHP2*DEL1))/D
      XS = SUMX+CI*XP(I)+CIM1*XP(IM1)
      YS = SUMY+CI*YP(I)+CIM1*YP(IM1)
      RETURN
      END
      SUBROUTINE QURV1 (N,X,Y,Z,SLP1X,SLP1Y,SLP1Z,SLPNX,
     *                  SLPNY,SLPNZ,ISLPSW,XP,YP,ZP,TEMP,
     *                  S,SIGMA,IERR)
C
      INTEGER N,ISLPSW,IERR
      REAL X(N),Y(N),Z(N),SLP1X,SLP1Y,SLP1Z,SLPNX,SLPNY,
     *     SLPNZ,XP(N),YP(N),ZP(N),TEMP(N),S(N),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO
C COMPUTE A SPLINE UNDER TENSION PASSING THROUGH A SEQUENCE
C OF TRIPLES (X(1),Y(1),Z(1)),...,(X(N),Y(N),Z(N)). THE
C SLOPES AT THE TWO ENDS OF THE CURVE MAY BE SPECIFIED OR
C OMITTED. FOR ACTUAL COMPUTATION OF POINTS ON THE CURVE
C IT IS NECESSARY TO CALL THE SUBROUTINE QURV2.
C
C ON INPUT--
C
C   N IS THE NUMBER OF POINTS TO BE INTERPOLATED (N.GE.2).
C
C   X IS AN ARRAY CONTAINING THE N X-COORDINATES OF THE
C   POINTS.
C
C   Y IS AN ARRAY CONTAINING THE N Y-COORDINATES OF THE
C   POINTS.
C
C   Z IS AN ARRAY CONTAINING THE N Z-COORDINATES OF THE
C   POINTS. (ADJACENT X-Y-Z TRIPLES MUST BE DISTINCT, I. E.
C   EITHER X(I) .NE. X(I+1) OR Y(I) .NE. Y(I+1) OR Z(I) .NE.
C   Z(I+1), FOR I = 1,...,N-1 ).
C
C   SLP1X, SLP1Y, SLP1Z AND SLPNX, SLPNY, SLPNZ CONTAIN THE
C   DESIRED VALUES OF THE COMPONENTS OF TANGENT VECTORS TO
C   THE CURVE AT (X(1),Y(1),Z(1)) AND(X(N),Y(N),Z(N)),
C   RESPECTIVELY. THE POSITIVE SENSE OF THE CURVE IS ASSUMED
C   TO BE THAT MOVING FROM POINT 1 TO POINT N. THE USER MAY
C   OMIT VALUES FOR EITHER OR BOTH OF THESE TRIPLES AND
C   SIGNAL THIS WITH ISLPSW.
C
C   ISLPSW CONTAINS A SWITCH INDICATING WHICH SLOPE DATA
C   SHOULD BE USED AND WHICH SHOULD BE ESTIMATED BY THIS
C   SUBROUTINE,
C          = 0 IF SLP1X, SLP1Y, SLP1Z AND SLPNX, SLPNY,
C              SLPNZ ARE TO BE USED,
C          = 1 IF SLP1X, SLP1Y, SLP1Z ARE TO BE USED BUT
C              NOT SLPNX, SLPNY, SLPNZ,
C          = 2 IF SLPNX, SLPNY, SLPNZ ARE TO BE USED BUT
C              NOT SLP1X, SLP1Y, SLP1Z,
C          = 3 IF BOTH END-TANGENTS ARE TO BE ESTIMATED
C              INTERNALLY.
C
C   XP, YP, AND ZP ARE ARRAYS OF LENGTH AT LEAST N.
C
C   TEMP IS AN ARRAY OF LENGTH AT LEAST N WHICH IS USED
C   FOR SCRATCH STORAGE.
C
C   S IS AN ARRAY OF LENGTH AT LEAST N.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES
C   THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO
C   (E.G. .001) THE RESULTING CURVE IS APPROXIMATELY A CUBIC
C   SPLINE. IF ABS(SIGMA) IS LARGE (E. G. 50.) THE RESULTING
C   CURVE IS NEARLY A POLYGONAL LINE. IF SIGMA EQUALS ZERO A
C   CUBIC SPLINE RESULTS. A STANDARD VALUE FOR SIGMA IS
C   APPROXIMATELY 1. IN ABSOLUTE VALUE.
C
C ON OUTPUT--
C
C   XP, YP, AND ZP CONTAIN INFORMATION ABOUT THE CURVATURE
C   OF THE CURVE AT THE GIVEN NODES.
C
C   S CONTAINS THE POLYGONAL ARCLENGTHS OF THE CURVE.
C
C   IERR CONTAINS AN ERROR FLAG,
C        = 0 FOR NORMAL RETURN,
C        = 1 IF N IS LESS THAN 2,
C        = 2 IF ADJACENT TRIPLES COINCIDE.
C
C AND
C
C   N, X, Y, Z, SLP1X, SLP1Y, SLP1Z, SLPNX, SLPNY, SLPNZ,
C   ISLPSW, AND SIGMA ARE UNALTERED,
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULES CEEZ, TERMS,
C AND SNHCSH.
C
C-----------------------------------------------------------
C
      NM1 = N-1
      NP1 = N+1
      IERR = 0
      IF (N .LE. 1) GO TO 9
C
C DETERMINE POLYGONAL ARCLENGTHS
C
      S(1) = 0.
      DO 1 I = 2,N
        IM1 = I-1
    1   S(I) = S(IM1)+SQRT((X(I)-X(IM1))**2+(Y(I)-Y(IM1))**2
     *       +(Z(I)-Z(IM1))**2)
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S(N)
C
C APPROXIMATE END SLOPES
C
      IF (ISLPSW .GE. 2) GO TO 2
      SLPP1X = SLP1X
      SLPP1Y = SLP1Y
      SLPP1Z = SLP1Z
      GO TO 3
    2 DELS1 = S(2)-S(1)
      DELS2 = DELS1+DELS1
      IF (N .GT. 2) DELS2 = S(3)-S(1)
      IF (DELS1 .EQ. 0. .OR. DELS2 .EQ. 0.) GO TO 9
      CALL CEEZ (DELS1,DELS2,SIGMAP,C1,C2,C3,N)
      SLPP1X = C1*X(1)+C2*X(2)
      SLPP1Y = C1*Y(1)+C2*Y(2)
      SLPP1Z = C1*Z(1)+C2*Z(2)
      IF (N .EQ. 2) GO TO 3
      SLPP1X = SLPP1X+C3*X(3)
      SLPP1Y = SLPP1Y+C3*Y(3)
      SLPP1Z = SLPP1Z+C3*Z(3)
    3 DELT = SQRT(SLPP1X*SLPP1X+SLPP1Y*SLPP1Y+SLPP1Z*SLPP1Z)
      SLPP1X = SLPP1X/DELT
      SLPP1Y = SLPP1Y/DELT
      SLPP1Z = SLPP1Z/DELT
      IF (ISLPSW .EQ. 1 .OR. ISLPSW .EQ. 3) GO TO 4
      SLPPNX = SLPNX
      SLPPNY = SLPNY
      SLPPNZ = SLPNZ
      GO TO 5
    4 DELSN = S(N)-S(NM1)
      DELSNM = DELSN+DELSN
      IF (N .GT. 2) DELSNM = S(N)-S(N-2)
      IF (DELSN .EQ. 0. .OR. DELSNM .EQ. 0.) GO TO 10
      CALL CEEZ (-DELSN,-DELSNM,SIGMAP,C1,C2,C3,N)
      SLPPNX = C1*X(N)+C2*X(NM1)
      SLPPNY = C1*Y(N)+C2*Y(NM1)
      SLPPNZ = C1*Z(N)+C2*Z(NM1)
      IF (N .EQ. 2) GO TO 5
      SLPPNX = SLPPNX+C3*X(N-2)
      SLPPNY = SLPPNY+C3*Y(N-2)
      SLPPNZ = SLPPNZ+C3*Z(N-2)
    5 DELT = SQRT(SLPPNX*SLPPNX+SLPPNY*SLPPNY+SLPPNZ*SLPPNZ)
      SLPPNX = SLPPNX/DELT
      SLPPNY = SLPPNY/DELT
      SLPPNZ = SLPPNZ/DELT
C
C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR XP, YP
C AND ZP AND PERFORM FORWARD ELIMINATION
C
      DX1 = (X(2)-X(1))/S(2)
      DY1 = (Y(2)-Y(1))/S(2)
      DZ1 = (Z(2)-Z(1))/S(2)
      CALL TERMS (DIAG1,SDIAG1,SIGMAP,S(2))
      XP(1) = (DX1-SLPP1X)/DIAG1
      YP(1) = (DY1-SLPP1Y)/DIAG1
      ZP(1) = (DZ1-SLPP1Z)/DIAG1
      TEMP(1) = SDIAG1/DIAG1
      IF (N .EQ. 2) GO TO 7
      DO 6 I = 2,NM1
        DELS2 = S(I+1)-S(I)
        IF (DELS2 .EQ. 0.) GO TO 10
        DX2 = (X(I+1)-X(I))/DELS2
        DY2 = (Y(I+1)-Y(I))/DELS2
        DZ2 = (Z(I+1)-Z(I))/DELS2
        CALL TERMS (DIAG2,SDIAG2,SIGMAP,DELS2)
        DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1)
        DIAGIN = 1./DIAG
        XP(I) = (DX2-DX1-SDIAG1*XP(I-1))*DIAGIN
        YP(I) = (DY2-DY1-SDIAG1*YP(I-1))*DIAGIN
        ZP(I) = (DZ2-DZ1-SDIAG1*ZP(I-1))*DIAGIN
        TEMP(I) = SDIAG2*DIAGIN
        DX1 = DX2
        DY1 = DY2
        DZ1 = DZ2
        DIAG1 = DIAG2
    6   SDIAG1 = SDIAG2
    7 DIAG = DIAG1-SDIAG1*TEMP(NM1)
      XP(N) = (SLPPNX-DX1-SDIAG1*XP(NM1))/DIAG
      YP(N) = (SLPPNY-DY1-SDIAG1*YP(NM1))/DIAG
      ZP(N) = (SLPPNZ-DZ1-SDIAG1*ZP(NM1))/DIAG
C
C PERFORM BACK SUBSTITUTION
C
      DO 8 I = 2,N
        IBAK = NP1-I
        T = TEMP(IBAK)
        XP(IBAK) = XP(IBAK)-T*XP(IBAK+1)
        YP(IBAK) = YP(IBAK)-T*YP(IBAK+1)
    8   ZP(IBAK) = ZP(IBAK)-T*ZP(IBAK+1)
      RETURN
C
C TOO FEW POINTS
C
    9 IERR = 1
      RETURN
C
C COINCIDENT ADJACENT POINTS
C
   10 IERR = 2
      RETURN
      END
      SUBROUTINE QURV2 (T,XS,YS,ZS,N,X,Y,Z,XP,YP,ZP,S,SIGMA)
C
      INTEGER N
      REAL T,XS,YS,ZS,X(N),Y(N),Z(N),XP(N),YP(N),ZP(N),S(N)
      REAL SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE PERFORMS THE MAPPING OF POINTS IN THE
C INTERVAL (0.,1.) ONTO A CURVE IN SPACE.  THE SUBROUTINE
C QURV1 SHOULD BE CALLED EARLIER TO DETERMINE CERTAIN
C NECESSARY PARAMETERS. THE RESULTING CURVE HAS A PARAMETRIC
C REPRESENTATION ALL OF WHOSE COMPONENTS ARE SPLINES UNDER
C TENSION AND FUNCTIONS OF THE POLYGONAL ARCLENGTH
C PARAMETER.
C
C ON INPUT--
C
C   T CONTAINS A REAL VALUE TO BE MAPPED TO A POINT ON THE
C   CURVE. THE INTERVAL (0.,1.) IS MAPPED ONTO THE ENTIRE
C   CURVE, WITH 0. MAPPING TO (X(1),Y(1,Z(1)) AND 1. MAPPING
C   TO (X(N),Y(N),Z(N)). VALUES OUTSIDE THIS INTERVAL RESULT
C   IN EXTRAPOLATION.
C
C   N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED
C   TO DETERMINE THE CURVE.
C
C   X, Y, AND Z ARE ARRAYS CONTAINING THE X-, Y- AND Z-
C   COORDINATES OF THE SPECIFIED POINTS.
C
C   XP, YP, AND ZP ARE THE ARRAYS OUTPUT FROM QURV1
C   CONTAINING CURVATURE INFORMATION.
C
C   S IS AN ARRAY CONTAINING THE POLYGONAL ARCLENGTHS OF
C   THE CURVE.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS N, X, Y, Z, XP, YP, ZP, S, AND SIGMA
C SHOULD BE INPUT UNALTERED FROM THE OUTPUT OF QURV1.
C
C ON OUTPUT--
C
C   XS, YS AND ZS CONTAIN THE X-, Y- AND Z-COORDINATES OF
C   THE IMAGE POINT ON THE CURVE.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULES INTRVL AND
C SNHCSH.
C
C-----------------------------------------------------------
C
C DETERMINE INTERVAL
C
      TN = S(N)*T
      IM1 = INTRVL(TN,S,N)
      I = IM1+1
C
C DENORMALIZE TENSION FACTOR
C
      SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S(N)
C
C SET UP AND PERFORM INTERPOLATION
C
      DEL1 = TN-S(IM1)
      DEL2 = S(I)-TN
      DELS = S(I)-S(IM1)
      SUMX = (X(I)*DEL1+X(IM1)*DEL2)/DELS
      SUMY = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS
      SUMZ = (Z(I)*DEL1+Z(IM1)*DEL2)/DELS
      IF (SIGMAP .NE. 0.) GO TO 1
      D = DEL1*DEL2/(6.*DELS)
      C1 = (DEL1+DELS)*D
      C2 = (DEL2+DELS)*D
      XS = SUMX-XP(I)*C1-XP(IM1)*C2
      YS = SUMY-YP(I)*C1-YP(IM1)*C2
      ZS = SUMZ-ZP(I)*C1-ZP(IM1)*C2
      RETURN
    1 DELP1 = SIGMAP*(DEL1+DELS)/2.
      DELP2 = SIGMAP*(DEL2+DELS)/2.
      CALL SNHCSH(SINHM1,DUMMY,SIGMAP*DEL1,-1)
      CALL SNHCSH(SINHM2,DUMMY,SIGMAP*DEL2,-1)
      CALL SNHCSH(SINHMS,DUMMY,SIGMAP*DELS,-1)
      CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1)
      CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1)
      CALL SNHCSH (DUMMY,COSHP1,DELP1,1)
      CALL SNHCSH (DUMMY,COSHP2,DELP2,1)
      D = SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS)
      C1 = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*SINHP2+SIGMAP*
     *     COSHP1*DEL2))/D
      C2 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+SIGMAP*
     *     COSHP2*DEL1))/D
      XS = SUMX+XP(I)*C1+XP(IM1)*C2
      YS = SUMY+YP(I)*C1+YP(IM1)*C2
      ZS = SUMZ+ZP(I)*C1+ZP(IM1)*C2
      RETURN
      END
      SUBROUTINE CEEZ (DEL1,DEL2,SIGMA,C1,C2,C3,N)
C
      REAL DEL1,DEL2,SIGMA,C1,C2,C3
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE DETERMINES THE COEFFICIENTS C1, C2, AND C3
C USED TO DETERMINE ENDPOINT SLOPES. SPECIFICALLY, IF
C FUNCTION VALUES Y1, Y2, AND Y3 ARE GIVEN AT POINTS X1, X2,
C AND X3, RESPECTIVELY, THE QUANTITY C1*Y1 + C2*Y2 + C3*Y3
C IS THE VALUE OF THE DERIVATIVE AT X1 OF A SPLINE UNDER
C TENSION (WITH TENSION FACTOR SIGMA) PASSING THROUGH THE
C THREE POINTS AND HAVING THIRD DERIVATIVE EQUAL TO ZERO AT
C X1. OPTIONALLY, ONLY TWO VALUES, C1 AND C2 ARE DETERMINED.
C
C ON INPUT--
C
C   DEL1 IS X2-X1 (.GT. 0.).
C
C   DEL2 IS X3-X1 (.GT. 0.). IF N .EQ. 2, THIS PARAMETER IS
C   IGNORED.
C
C   SIGMA IS THE TENSION FACTOR.
C
C AND
C
C   N IS A SWITCH INDICATING THE NUMBER OF COEFFICIENTS TO
C   BE RETURNED. IF N .EQ. 2 ONLY TWO COEFFICIENTS ARE
C   RETURNED. OTHERWISE ALL THREE ARE RETURNED.
C
C ON OUTPUT--
C
C   C1, C2, AND C3 CONTAIN THE COEFFICIENTS.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULE SNHCSH.
C
C-----------------------------------------------------------
C
      IF (N .EQ. 2) GO TO 2
      IF (SIGMA .NE. 0.) GO TO 1
      DEL = DEL2-DEL1
C
C TENSION .EQ. 0.
C
      C1 = -(DEL1+DEL2)/(DEL1*DEL2)
      C2 = DEL2/(DEL1*DEL)
      C3 = -DEL1/(DEL2*DEL)
      RETURN
C
C TENSION .NE. 0.
C
    1 CALL SNHCSH (DUMMY,COSHM1,SIGMA*DEL1,1)
      CALL SNHCSH (DUMMY,COSHM2,SIGMA*DEL2,1)
      DELP = SIGMA*(DEL2+DEL1)/2.
      DELM = SIGMA*(DEL2-DEL1)/2.
      CALL SNHCSH (SINHMP,DUMMY,DELP,-1)
      CALL SNHCSH (SINHMM,DUMMY,DELM,-1)
      DENOM = COSHM1*(DEL2-DEL1)-2.*DEL1*(SINHMP+DELP)*
     *        (SINHMM+DELM)
      C1 = 2.*(SINHMP+DELP)*(SINHMM+DELM)/DENOM
      C2 = -COSHM2/DENOM
      C3 = COSHM1/DENOM
      RETURN
C
C TWO COEFFICIENTS
C
    2 C1 = -1./DEL1
      C2 = -C1
      RETURN
      END
      SUBROUTINE TERMS (DIAG,SDIAG,SIGMA,DEL)
C
      REAL DIAG,SDIAG,SIGMA,DEL
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE COMPUTES THE DIAGONAL AND SUPERDIAGONAL
C TERMS OF THE TRIDIAGONAL LINEAR SYSTEM ASSOCIATED WITH
C SPLINE UNDER TENSION INTERPOLATION.
C
C ON INPUT--
C
C   SIGMA CONTAINS THE TENSION FACTOR.
C
C AND
C
C   DEL CONTAINS THE STEP SIZE.
C
C ON OUTPUT--
C
C               (SIGMA*DEL*COSH(SIGMA*DEL) - SINH(SIGMA*DEL)
C   DIAG = DEL*--------------------------------------------.
C                     (SIGMA*DEL)**2 * SINH(SIGMA*DEL)
C
C                   SINH(SIGMA*DEL) - SIGMA*DEL
C   SDIAG = DEL*----------------------------------.
C                (SIGMA*DEL)**2 * SINH(SIGMA*DEL)
C
C AND
C
C   SIGMA AND DEL ARE UNALTERED.
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULE SNHCSH.
C
C-----------------------------------------------------------
C
      IF (SIGMA .NE. 0.) GO TO 1
      DIAG = DEL/3.
      SDIAG = DEL/6.
      RETURN
    1 SIGDEL = SIGMA*DEL
      CALL SNHCSH (SINHM,COSHM,SIGDEL,0)
      DENOM = DEL/((SINHM+SIGDEL)*SIGDEL*SIGDEL)
      DIAG = DENOM*(SIGDEL*COSHM-SINHM)
      SDIAG = DENOM*SINHM
      RETURN
      END
      INTEGER FUNCTION INTRVL (X, T, M)
      REAL X, T(M)
C-----------------------------------------------------------------------
C
C             LOCATION OF A VALUE X IN A SEQUENCE T
C
C                       ----------------
C
C     INPUT--
C
C        X IS A REAL NUMBER.
C
C        T IS AN ARRAY OF NONDECREASING VALUES. IT IS
C          ASSUMED THAT T(1) .LT. T(M).
C
C        M IS THE LENGTH OF T (M .GE. 2).
C
C     OUTPUT--
C
C        INTRVL HAS THE VALUE I WHEN  T(I) .LE. X .LT. T(I+1).
C        OTHERWISE, IF L IS THE INTEGER WHERE T(L) .LT. T(L+1)
C        AND T(L+1) = ... = T(M), THEN INTRVL HAS THE VALUE I
C        WHERE
C                  I = 1   IF X .LT. T(1)
C                  I = L   IF X .GE. T(L)
C
C-----------------------------------------------------------------------
      IF (X .LT. T(2)) GO TO 100
      TM = T(M)
      I = M - 1
   10    IF (T(I) .LT. TM) GO TO 20
         I = I - 1
         GO TO 10
   20 IF (X .GE. T(I)) GO TO 110
      IL = 2
      IR = I
C
C     BISECTION SEARCH
C
   30 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 110
      IF (X - T(I)) 40,60,50
   40 IR = I
      GO TO 30
   50 IL = I
      GO TO 30
C
C     CASE WHEN X = T(I) FOR SOME I
C
   60 IF (X .LT. T(I+1)) GO TO 110
      I = I + 1
      GO TO 60
C
C     LEFT END
C
  100 INTRVL = 1
      RETURN
C
C     NORMAL EXIT
C
  110 INTRVL = I
      RETURN
      END
      SUBROUTINE BVAL (T, BCOEF, N, K, X, JDERIV, W, WK)
C-----------------------------------------------------------------------
C
C     BVAL CALCULATES THE VALUE AT X OF THE JDERIV-TH DERIVATIVE
C     OF A SPLINE F FROM ITS B-REPRESENTATION.
C
C******  I N P U T ******
C
C  T     AN ARRAY OF DIMENSION N + K CONTAING THE KNOTS OF THE
C        SPLINE. IT IS ASSUMED THAT T(I) .LE. T(I+1) FOR EACH I.
C  BCOEF AN ARRAY OF DIMENSION N CONTAINING THE B-COEFFICIENTS
C        OF THE SPLINE F.
C  N     LENGTH OF BCOEF (N .GE. 1).
C  K     ORDER OF THE SPLINE.
C  X     THE POINT AT WHICH TO EVALUATE.
C  JDERIV  INTEGER GIVING THE ORDER OF THE DERIVATIVE TO BE
C        EVALUATED. IT IS ASSUMED THAT JDERIV .GE. 0.
C
C******  O U T P U T  ******
C
C  W     THE VALUE OF THE (JDERIV)-TH DERIVATIVE OF F AT X.
C
C******  W O R K  S P A C E ******
C
C  WK    AN ARRAY OF DIMENSION 3*K OR LARGER.
C
C******  M E T H O D  ******
C
C     THE NONTRIVIAL KNOT INTERVAL (T(I),T(I+1)) CONTAINING X IS FIRST
C  OBTAINED. THEN THE  K  B-COEFFICIENTS OF F RELEVANT FOR THIS INTERVAL
C  ARE OBTAINED FROM BCOEF (OR TAKEN TO BE ZERO IF NOT EXPLICITLY AVAIL-
C  ABLE), AND DIFFERENCED JDERIV TIMES TO OBTAIN THE B-COEFFICIENTS OF
C  (D**JDERIV)F  RELEVANT FOR THE INTERVAL. SPECIFICALLY, IF J = JDERIV
C  THEN FROM X.(12) OF THE REFERENCE WE HAVE
C
C     (D**J)F  =  SUM ( BCOEF(.,J)*B(.,K-J,T) )
C
C  WHERE
C                   / BCOEF(.),                     ,  J .EQ. 0
C                   /
C    BCOEF(.,J)  =  / BCOEF(.,J-1) - BCOEF(.-1,J-1)
C                   / ----------------------------- ,  J .GT. 0
C                   /    (T(.+K-J) - T(.))/(K-J)
C
C     THEN, WE USE REPEATEDLY THE FACT THAT
C
C    SUM ( A(.)*B(.,M,T)(X) )  =  SUM ( A(.,X)*B(.,M-1,T)(X) )
C  WITH
C                 (X - T(.))*A(.) + (T(.+M-1) - X)*A(.-1)
C    A(.,X)  =    ---------------------------------------
C                 (X - T(.))      + (T(.+M-1) - X)
C
C  TO WRITE (D**J)F(X) EVENTUALLY AS A LINEAR COMBINATION OF B-SPLINES
C  OF ORDER 1. THE COEFFICIENT FOR B(I,1,T)(X) MUST THEN BE THE DESIRED
C  NUMBER  (D**J)F(X). (SEE X.(17)-(19) OF THE REFERENCE).
C
C-----------------------------------------------------------------------
C  REFERENCE. DE BOOR, CARL, A PRATICAL GUIDE TO SPLINES, SPRINGER-
C  VERLAG, NEW YORK, 1978.
C-----------------------------------------------------------------------
      REAL T(*), BCOEF(N), WK(K,3)
C
      W = 0.0
      IF (JDERIV .GE. K) RETURN
C
C *** FIND I WHERE 1 .LE. I .LT. N+K  AND  T(I) .LE. X .LT. T(I+1).
C     IF NO SUCH I EXISTS, THEN X LIES OUTSIDE THE SUPPORT OF THE
C     SPLINE F AND W = 0.
C
      NPK = N + K
      IF (X .LT. T(1) .OR. X .GT. T(NPK)) RETURN
      I = INTRVL(X, T, NPK)
C
C  *** IF K = 1 (AND JDERIV = 0), W = BCOEF(I).
C
      KM1 = K - 1
      IF (KM1 .GT. 0) GO TO 10
         W = BCOEF(I)
         RETURN
C
C  *** STORE THE K B-SPLINE COEFFICIENTS RELEVANT FOR THE KNOT INTERVAL
C     (T(I),T(I+1)) IN THE FIRST COLUMN OF WK AND COMPUTE WK(J,2) =
C     X - T(I+1-J), WK(J,3) = T(I+J) - X, J=1,...,K-1 . SET ANY OF THE
C     WK(J,1) NOT OBTAINABLE FROM INPUT TO ZERO. SET ANY T.S NOT OBTAIN-
C     ABLE EQUAL TO T(1) OR TO T(N+K) APPROPRIATELY.
C
   10 JCMIN = 1
      IMK = I - K
      IF (IMK .GE. 0) GO TO 40
C
         JCMIN = 1 - IMK
         L = I
         DO 20 J = 1,I
            WK(J,2) = X - T(L)
            L = L - 1
   20    CONTINUE
         DO 30 J = I,KM1
            L = K - J
            WK(L,1) = 0.0
            WK(J,2) = WK(I,2)
   30    CONTINUE
         GO TO 60
C
   40 L = I
      DO 50 J = 1,KM1
         WK(J,2) = X - T(L)
         L = L - 1
   50 CONTINUE
C
   60 JCMAX = K
      NMI = N - I
      IF (NMI .GE. 0) GO TO 100
C
         JCMAX = K + NMI
         DO 70 J = 1,JCMAX
            IPJ = I + J
            WK(J,3) = T(IPJ) - X
   70    CONTINUE
         DO 80 J = JCMAX,KM1
            WK(J+1,1) = 0.0
            WK(J,3) = WK(JCMAX,3)
   80    CONTINUE
         GO TO 120
C
  100 DO 110 J = 1,KM1
         IPJ = I + J
         WK(J,3) = T(IPJ) - X
  110 CONTINUE
C
  120 DO 130 JC = JCMIN,JCMAX
         L = IMK + JC
         WK(JC,1) = BCOEF(L)
  130 CONTINUE
C
C               *** DIFFERENCE THE COEFFICIENTS  JDERIV  TIMES.
C
      IF (JDERIV .EQ. 0) GO TO 170
      DO 160 J = 1,JDERIV
         KMJ = K - J
         FKMJ = KMJ
         L = KMJ
         DO 150 JJ = 1,KMJ
            DL = WK(L,2)
            DR = WK(JJ,3)
            WK(JJ,1) = ((WK(JJ+1,1) - WK(JJ,1))/(DL + DR))*FKMJ
  150       L = L - 1
  160 CONTINUE
C
C  *** COMPUTE VALUE AT X IN (T(I),T(I+1)) OF JDERIV-TH DERIVATIVE,
C     GIVEN ITS RELEVANT B-SPLINE COEFFS IN WK(1,1),...,WK(K-JDERIV,1).
C
  170 IF (JDERIV .EQ. KM1) GO TO 200
      JDRVP1 = JDERIV + 1
      DO 190 J = JDRVP1,KM1
         KMJ = K - J
         L = KMJ
         DO 180 JJ = 1,KMJ
            DL = WK(L,2)
            DR = WK(JJ,3)
            WK(JJ,1) = (WK(JJ+1,1)*DL + WK(JJ,1)*DR)/(DL + DR)
  180       L = L - 1
  190 CONTINUE
C
  200 W = WK(1,1)
      RETURN
      END
      SUBROUTINE BVALI (T, BCOEFF, N, K, X, W, WK)
C-----------------------------------------------------------------------
C           INTEGRAL OF A PIECEWISE POLYNOMIAL FROM T(1) TO X
C                   USING ITS B-SPLINE REPRESENTATION
C-----------------------------------------------------------------------
C     REAL T(N + K), WK(N + 3*(K + 1))
C---------------------------
      REAL T(*), BCOEFF(N), WK(*)
C
      W = 0.0
      IF (X .LE. T(1)) RETURN
      NPK = N + K
      TLAST = T(NPK)
      XVAL = AMIN1(X, TLAST)
C
C     DEFINE THE FIRST NEW KNOT. THE REMAINING NEW KNOTS
C         ARE ASSUMED TO BE THE SAME AS THIS KNOT.
C
      TNEW = 0.1
      IF (TLAST .LT. -0.1) TNEW = 0.9*TLAST
      IF (TLAST .GT.  0.0) TNEW = 1.1*TLAST
C
C     COMPUTE THE FIRST N COEFFICIENTS OF THE ANTIDERIVATIVE
C
      SUM = 0.0
      DO 10 I = 1,N
         IPK = I + K
         SUM = SUM + BCOEFF(I)*(T(IPK) - T(I))
         WK(I) = SUM/K
   10 CONTINUE
C
C     COMPUTE THE ANTIDERIVATIVE
C
      KP1 = K + 1
      NP1 = N + 1
      CALL BVALI0 (T, TNEW, WK(1), N, KP1, XVAL, W, WK(NP1))
      RETURN
      END
      SUBROUTINE BVALI0 (T, TNEW, BCOEF, N, K, X, W, WK)
C-----------------------------------------------------------------------
C
C     BVALI0 CALCULATES THE VALUE AT X OF AN ANTIDERIVATIVE
C     OF A B-SPLINE F FOR T(1) .LE. X .LE. T(N + K - 1).
C
C******  I N P U T ******
C
C  T     AN ARRAY CONTAINING THE FIRST N + K - 1 KNOTS OF THE
C        ANTIDERIVATIVE.
C  TNEW  THE REMAING KNOTS ARE ALL LOCATED AT THIS POINT.
C  BCOEF AN ARRAY CONTAINING THE FIRST N COEFFICIENTS OF THE
C        ANTIDERIVATIVE.
C  N     LENGTH OF BCOEF (N .GE. 1).
C  K     ORDER OF THE ANTIDERIVATIVE.
C  X     THE POINT AT WHICH TO EVALUATE.
C
C******  O U T P U T  ******
C
C  W     THE VALUE OF THE ANTIDERIVATIVE AT X.
C
C******  W O R K  S P A C E ******
C
C  WK    AN ARRAY OF DIMENSION 3*K OR LARGER.
C
C-----------------------------------------------------------------------
C     REMARK. BVALI0 IS AN ADAPTATION BY A.H. MORRIS (NSWC) OF THE
C     SUBROUTINE BVAL.
C-----------------------------------------------------------------------
      REAL T(*), BCOEF(N), WK(K,3)
C
      W = 0.0
      KM1 = K - 1
      M = N + KM1
      I = INTRVL(X, T, M)
C
C  *** STORE THE K B-SPLINE COEFFICIENTS RELEVANT FOR THE KNOT INTERVAL
C     (T(I),T(I+1)) IN THE FIRST COLUMN OF WK AND COMPUTE WK(J,2) =
C     X - T(I+1-J), WK(J,3) = T(I+J) - X, J=1,...,K-1 . SET ANY OF THE
C     WK(J,1) NOT OBTAINABLE FROM INPUT TO ZERO. SET ANY T.S NOT OBTAIN-
C     ABLE EQUAL TO T(1) OR TNEW APPROPRIATELY.
C
      JCMIN = 1
      IMK = I - K
      IF (IMK .GE. 0) GO TO 30
C
         JCMIN = 1 - IMK
         L = I
         DO 10 J = 1,I
            WK(J,2) = X - T(L)
            L = L - 1
   10    CONTINUE
         DO 20 J = I,KM1
            L = K - J
            WK(L,1) = 0.0
            WK(J,2) = WK(I,2)
   20    CONTINUE
         GO TO 50
C
   30 L = I
      DO 40 J = 1,KM1
         WK(J,2) = X - T(L)
         L = L - 1
   40 CONTINUE
C
   50 DO 60 J = 1,KM1
         TIPJ = TNEW
         IPJ = I + J
         IF (IPJ .LE. M) TIPJ = T(IPJ)
         WK(J,3) = TIPJ - X
   60 CONTINUE
C
      DO 70 JC = JCMIN,K
         L = MIN0(IMK + JC, N)
         WK(JC,1) = BCOEF(L)
   70 CONTINUE
C
C  *** COMPUTE VALUE AT X IN (T(I),T(I+1)), GIVEN ITS RELEVANT
C     B-SPLINE COEFFS IN WK(1,1),...,WK(K,1).
C
      DO 110 J = 1,KM1
         KMJ = K - J
         L = KMJ
         DO 100 JJ = 1,KMJ
            DL = WK(L,2)
            DR = WK(JJ,3)
            WK(JJ,1) = (WK(JJ+1,1)*DL + WK(JJ,1)*DR)/(DL + DR)
  100       L = L - 1
  110 CONTINUE
C
      W = WK(1,1)
      RETURN
      END
      SUBROUTINE BSPP (T, A, N, K, BREAK, C, L, WK)
C-----------------------------------------------------------------------
C
C              CONVERSION FROM B-SPLINE REPRESENTATION
C              TO PIECEWISE POLYNOMIAL REPRESENTATION
C
C
C     INPUT ...
C
C       T     KNOT SEQUENCE OF LENGTH N+K
C       A     B-SPLINE COEFFICIENT SEQUENCE OF LENGTH N
C       N     LENGTH OF A
C       K     ORDER OF THE B-SPLINES
C
C     OUTPUT ...
C
C       BREAK BREAKPOINT SEQUENCE, OF LENGTH L+1, CONTAINING
C             (IN INCREASING ORDER) THE DISTINCT POINTS OF THE
C             SEQUENCE T(K),...,T(N+1).
C       C     KXL MATRIX WHERE C(I,J) = (I-1)ST RIGHT DERIVATIVE
C             OF THE PP AT BREAK(J) DIVIDED BY FACTORIAL(I-1).
C       L     NUMBER OF POLYNOMIALS WHICH FORM THE PP
C
C     WORK AREA ...
C
C       WK    2-DIMENSIONAL ARRAY OF DIMENSION (K,K+1)
C
C-----------------------------------------------------------------------
      REAL T(*), A(N), BREAK(*), C(K,*), WK(K,*)
C
      L = 0
      BREAK(1) = T(K)
      IF (K .EQ. 1) GO TO 100
      KM1 = K - 1
      KP1 = K + 1
C
C          GENERAL K-TH ORDER CASE
C
      DO 60 LEFT = K,N
         IF (T(LEFT) .EQ. T(LEFT + 1)) GO TO 60
         L = L + 1
         BREAK(L + 1) = T(LEFT + 1)
         DO 10 J = 1,K
            JJ = LEFT - K + J
            WK(J,1) = A(JJ)
   10    CONTINUE
C
         DO 21 J = 1,KM1
            JP1 = J + 1
            KMJ = K - J
            DO 20 I = 1,KMJ
               IL = I + LEFT
               ILKJ = IL - KMJ
               DIFF = T(IL) - T(ILKJ)
               WK(I,JP1) = (WK(I+1,J) - WK(I,J))/DIFF
   20       CONTINUE
   21    CONTINUE
C
         WK(1,KP1) = 1.0
         X = T(LEFT)
         C(K,L) = WK(1,K)
         R = 1.0
         DO 50 J = 1,KM1
            JP1 = J + 1
            S = 0.0
            DO 30 I = 1,J
               IL = I + LEFT
               ILJ = IL - J
               TERM = WK(I,KP1)/(T(IL) - T(ILJ))
               WK(I,KP1) = S + (T(IL) - X)*TERM
               S = (X - T(ILJ))*TERM
   30       CONTINUE
            WK(JP1,KP1) = S
C
            S = 0.0
            KMJ = K - J
            DO 40 I = 1,JP1
               S = S + WK(I,KMJ)*WK(I,KP1)
   40       CONTINUE
            R = (R*FLOAT(KMJ))/FLOAT(J)
            C(KMJ,L) = R*S
   50    CONTINUE
   60 CONTINUE
      RETURN
C
C          PIECEWISE CONSTANT CASE
C
  100 DO 110 LEFT = K,N
         IF (T(LEFT) .EQ. T(LEFT + 1)) GO TO 110
         L = L + 1
         BREAK(L + 1) = T(LEFT + 1)
         C(1,L) = A(LEFT)
  110 CONTINUE
      RETURN
      END
      SUBROUTINE PPVAL (X, A, L, N, XI, YI, NI)
C-----------------------------------------------------------------------
C
C         THIS ROUTINE EVALUATES A PIECEWISE POLYNOMIAL AT THE
C         ABSCISSAS IN XI. IT IS ASSUMED THAT THE COEFFICIENTS
C         OF THE POLYNOMIALS WHICH FORM THE PP ARE GIVEN.
C
C       --INPUT--
C
C         X   - ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER)
C               THAT DEFINE THE PP.
C         A   - MATRIX THAT CONTAINS THE COEFFICIENTS OF THE POLY-
C               NOMIALS  WHICH FORM THE PP. IF I = 1,...,N THEN THE
C               PP HAS THE VALUE
C                    A(1,I) + A(2,I)*DX + ... + A(L,I)*DX**(L-1)
C               FOR X(I) .LE. XX .LT. X(I+1).  HERE DX = XX - X(I).
C         L   - ORDER OF THE PIECEWISE POLYNOMIAL.
C         N   - THE NUMBER OF POLYNOMIALS THAT DEFINE THE PP.
C               N MUST BE GREATER THAN OR EQUAL TO 1.
C         XI  - THE ARRAY OF ABSCISSAS (IN ARBITRARY ORDER) AT WHICH
C               AT WHICH THE PP IS TO BE EVALUATED.
C         NI  - THE DIMENSION OF THE ARRAYS XI AND YI. IT IS ASSUMED
C               THAT NI IS GREATER THAN OR EQUAL TO 1.
C
C       --OUTPUT--
C
C         YI  - ARRAY OF VALUES OF THE PP AT THE POINTS IN XI.
C
C-----------------------------------------------------------------------
      DIMENSION X(N), A(L,N), XI(NI), YI(NI)
C
C     K IS INDEX ON VALUE OF XI BEING WORKED ON.  XX IS THAT VALUE.
C     I IS THE CURRENT INDEX IN THE X ARRAY.
C
      K  = 1
      XX = XI(1)
      LM1 = L - 1
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(N)) GO TO 80
      IL = 1
      IR = N
C
C     BISECTION SEARCH
C
   10 I = (IL + IR)/2
      IF (I .EQ. IL) GO TO 100
      IF (XX - X(I)) 20,100,30
   20 IR = I
      GO TO 10
   30 IL = I
      GO TO 10
C
C     LINEAR FORWARD SEARCH
C
   40 IF (XX .LT. X(I+1)) GO TO 100
      I = I + 1
      GO TO 40
C
C     XX IS GREATER THAN X(N) OR LESS THAN X(1)
C
   80 I = N
      GO TO 100
   90 I = 1
C
C     EVALUATION
C
  100 DX = XX - X(I)
      S = A(L,I)
      IF (L .EQ. 1) GO TO 120
      DO 110 J = 1,LM1
         LMJ = L - J
         S = A(LMJ,I) + DX*S
  110 CONTINUE
  120 YI(K) = S
C
C     NEXT POINT
C
      IF (K .GE. NI) RETURN
      K = K + 1
      XX = XI(K)
      IF (XX .LT. X(1)) GO TO 90
      IF (XX .GE. X(N)) GO TO 80
      IF (XX - XI(K-1)) 130,120,40
  130 IL = 1
      IR = MIN0(I + 1, N)
      GO TO 10
      END
      SUBROUTINE BSPVB (T, K, JHIGH, J, X, LEFT, BLIST)
C-----------------------------------------------------------------------
C
C     BSPVB CALCULATES THE VALUE OF ALL POSSIBLY NONZERO B-SPLINES
C     AT X OF ORDER MAX(JHIGH,J + 1) WHERE T(K) .LE. X .LT. T(N+1).
C
C     DESCRIPTION OF ARGUMENTS
C
C         INPUT
C
C          T       - KNOT VECTOR OF LENGTH N + K.
C          K       - HIGHEST POSSIBLE ORDER OF THE B-SPLINES.
C          JHIGH   - ORDER OF B-SPLINES (1 .LE. JHIGH .LE. K).
C          J       - J .LE. 0  GIVES B-SPLINES OF ORDER JHIGH.
C                    J .GE. 1  ON A PREVIOUS CALL TO BSPVB THE
C                              B-SPLINES OF ORDER J WERE COM-
C                              PUTED AND STORED IN BLIST. IT IS
C                              ASSUMED THAT WORK HAS NOT BEEN
C                              MODIFIED AND THAT J .LT. K.
C          X       - ARGUMENT OF THE B-SPLINES.
C          LEFT    - LARGEST INTEGER SUCH THAT
C                    T(LEFT) .LE. X .LT. T(LEFT+1)
C
C         OUTPUT
C
C          BLIST   - VECTOR OF LENGTH K FOR SPLINE VALUES.
C          J       - B-SPLINES OF ORDER J HAVE BEEN COMPUTED
C                    AND STORED IN BLIST.
C
C-----------------------------------------------------------------------
C     WRITTEN BY CARL DE BOOR (UNIVERSITY OF WISCONSIN) AND MODIFIED
C         BY A.H. MORRIS (NSWC).
C-----------------------------------------------------------------------
      REAL T(*), BLIST(K)
C
      IF (J .GT. 0) GO TO 10
         J = 1
         BLIST(1) = 1.0
         IF (J .GE. JHIGH) RETURN
C
   10 S = 0.0
      DO 20 L = 1,J
         I = LEFT + L
         IMJ = I - J
         TIMJ = T(IMJ)
         TI = T(I)
         TERM = BLIST(L)/(TI - TIMJ)
         BLIST(L) = S + (TI - X)*TERM
         S = (X - TIMJ)*TERM
   20 CONTINUE
      J = J + 1
      BLIST(J) = S
      IF (J .LT. JHIGH) GO TO 10
C
      RETURN
      END
      SUBROUTINE BSPVD (T, K, X, LEFT, DBIATX, IDIM, NDERIV, A)
C-----------------------------------------------------------------------
C
C CALCULATES VALUE AND DERIV.S OF ALL B-SPLINES WHICH DO NOT VANISH AT X
C
C******  I N P U T  ******
C
C  T     THE KNOT ARRAY, OF LENGTH LEFT+K (AT LEAST)
C  K     THE ORDER OF THE B-SPLINES TO BE EVALUATED
C  X     THE POINT AT WHICH THESE VALUES ARE SOUGHT
C  LEFT  AN INTEGER INDICATING THE LEFT ENDPOINT OF THE INTERVAL OF
C        INTEREST. THE  K  B-SPLINES WHOSE SUPPORT CONTAINS THE INTERVAL
C               (T(LEFT), T(LEFT+1))
C        ARE TO BE CONSIDERED.
C  A S S U M P T I O N  - - -  IT IS ASSUMED THAT
C               T(LEFT) .LT. T(LEFT+1)
C        DIVISION BY ZERO WILL RESULT OTHERWISE (IN  B S P V B ).
C        ALSO, THE OUTPUT IS AS ADVERTISED ONLY IF
C               T(LEFT) .LE. X .LE. T(LEFT+1) .
C  IDIM  THE ROW DIMENSION OF THE MATRIX DBIATX. IF IS ASSUMED THAT
C        IDIM .GE. K .
C  NDERIV  AN INTEGER INDICATING THAT VALUES OF B-SPLINES AND THEIR
C        DERIVATIVES UP TO BUT NOT INCLUDING THE  NDERIV-TH  ARE ASKED
C        FOR. (NDERIV IS REPLACED INTERNALLY BY THE INTEGER  M H I G H
C        IN (1,K) CLOSEST TO IT.)
C
C******  O U T P U T  ******
C
C  DBIATX  AN ARRAY OF ORDER (IDIM,NDERIV). ITS ENTRY (I,M) CONTAINS
C        VALUE OF  (M-1)ST  DERIVATIVE OF  (LEFT-K+I)-TH  B-SPLINE OF
C        ORDER  K  FOR KNOT SEQUENCE  T , I=M,...,K, M=1,...,NDERIV.
C
C******  W O R K   A R E A  ******
C
C  A     AN ARRAY OF ORDER (K,K), TO CONTAIN B-COEFF.S OF THE DERIVA-
C        TIVES OF A CERTAIN ORDER OF THE  K  B-SPLINES OF INTEREST.
C
C******  M E T H O D  ******
C
C  VALUES AT  X  OF ALL THE RELEVANT B-SPLINES OF ORDER K,K-1,...,
C  K+1-NDERIV  ARE GENERATED VIA BSPVB AND STORED TEMPORARILY IN
C  DBIATX. THEN THE B-COEFFS OF THE REQUIRED DERIVATIVES OF THE B-
C  SPLINES OF INTEREST ARE GENERATED BY DIFFERENCING, EACH FROM THE PRE-
C  CEDING ONE OF LOWER ORDER, AND COMBINED WITH THE VALUES OF B-SPLINES
C  OF CORRESPONDING ORDER IN  DBIATX  TO PRODUCE THE DESIRED VALUES .
C
C-----------------------------------------------------------------------
C  WRITTEN BY CARL DE BOOR (UNIVERSITY OF WISCONSIN) AND MODIFIED
C     BY A.H. MORRIS (NSWC).
C-----------------------------------------------------------------------
      REAL T(*), DBIATX(IDIM,NDERIV), A(K,K)
C
      MHIGH = MAX0(MIN0(NDERIV,K),1)
C     MHIGH IS USUALLY EQUAL TO NDERIV.
      KP1 = K + 1
      JJ = 0
      CALL BSPVB (T, K, KP1 - MHIGH, JJ, X, LEFT, DBIATX)
      IF (MHIGH .EQ. 1) RETURN
C
C     THE FIRST COLUMN OF DBIATX ALWAYS CONTAINS THE B-SPLINE VALUES
C     FOR THE CURRENT ORDER. THESE ARE STORED IN COLUMN K+1-CURRENT
C     ORDER  BEFORE  BSPVB  IS CALLED TO PUT VALUES FOR THE NEXT
C     HIGHER ORDER ON TOP OF IT.
C
      IDERIV = MHIGH
      DO 15 M = 2,MHIGH
         JP1MID = 1
         DO 10 J = IDERIV,K
            DBIATX(J,IDERIV) = DBIATX(JP1MID,1)
   10       JP1MID = JP1MID + 1
         IDERIV = IDERIV - 1
         CALL BSPVB (T, K, KP1 - IDERIV, JJ, X, LEFT, DBIATX)
   15 CONTINUE
C
C     AT THIS POINT, B(LEFT-K+I, K+1-J)(X) IS IN DBIATX(I,J) FOR
C     I = J,...,K AND J = 1,...,MHIGH. IN PARTICULAR, THE FIRST
C     COLUMN OF DBIATX IS ALREADY IN FINAL FORM. TO OBTAIN COR-
C     RESPONDING DERIVATIVES OF B-SPLINES IN SUBSEQUENT COLUMNS,
C     GENERATE THEIR B-REPR. BY DIFFERENCING. THEN EVALUATE AT X.
C
      JLOW = 1
      DO 20 I = 1,K
         DO 19 J = JLOW,K
   19       A(J,I) = 0.0
         JLOW = I
   20    A(I,I) = 1.0
C
C     AT THIS POINT, A(.,J) CONTAINS THE B-COEFFS FOR THE J-TH OF THE
C     K  B-SPLINES OF INTEREST HERE.
C
      DO 50 M = 2,MHIGH
         KP1MM = KP1 - M
         FKP1MM = FLOAT(KP1MM)
         IL = LEFT
         I = K
C
C        FOR J = 1,...,K, CONSTRUCT B-COEFFS OF (M-1)ST  DERIVATIVE OF
C        B-SPLINES FROM THOSE FOR PRECEDING DERIVATIVE BY DIFFERENCING
C        AND STORE AGAIN IN  A(.,J) . THE FACT THAT  A(I,J) = 0  FOR
C        I .LT. J  IS USED.
C
         DO 30 LDUMMY = 1,KP1MM
            L = IL + KP1MM
            FACTOR = FKP1MM/(T(L) - T(IL))
C
C           THE ASSUMPTION THAT T(LEFT).LT.T(LEFT+1) MAKES DENOMINATOR
C           IN THE FACTOR NONZERO.
C
            DO 25 J = 1,I
   25          A(I,J) = (A(I,J) - A(I-1,J))*FACTOR
            IL = IL - 1
            I = I - 1
   30    CONTINUE
C
C        FOR I = 1,...,K, COMBINE B-COEFFS A(.,I) WITH B-SPLINE VALUES
C        STORED IN DBIATX(.,M) TO GET VALUE OF  (M-1)ST  DERIVATIVE OF
C        I-TH B-SPLINE (OF INTEREST HERE) AT X, AND STORE IN
C        DBIATX(I,M). STORAGE OF THIS VALUE OVER THE VALUE OF A B-SPLINE
C        OF ORDER M THERE IS SAFE SINCE THE REMAINING B-SPLINE DERIVAT-
C        IVES OF THE SAME ORDER DO NOT USE THIS VALUE DUE TO THE FACT
C        THAT  A(J,I) = 0  FOR J .LT. I .
C
         DO 40 I = 1,K
            SUM = 0.0
            JLOW = MAX0(I,M)
            DO 35 J=JLOW,K
   35          SUM = A(J,I)*DBIATX(J,M) + SUM
            DBIATX(I,M) = SUM
   40    CONTINUE
   50 CONTINUE
      RETURN
      END
      SUBROUTINE BSTRP (TAU, GTAU, T, N, K, BCOEF, Q, IFLAG)
C-----------------------------------------------------------------------
C   THIS ROUTINE PRODUCES THE B-SPLINE COEFF.S BCOEF OF THE PIECEWISE
C   POLYNOMIAL OF ORDER K WITH KNOTS T(I) (I=1,...,N+K) WHICH HAS THE
C   VALUE GTAU(I) AT TAU(I) FOR I=1,...,N.
C
C******  I N P U T  ******
C
C  TAU.....ARRAY OF LENGTH  N , CONTAINING DATA POINT ABSCISSAE.
C    A S S U M P T I O N . . .  TAU  IS STRICTLY INCREASING
C  GTAU.....CORRESPONDING ARRAY OF LENGTH  N , CONTAINING DATA POINT
C        ORDINATES.
C  T.....KNOT SEQUENCE, OF LENGTH  N+K
C  N.....NUMBER OF DATA POINTS AND DIMENSION OF SPLINE SPACE  S(K,T)
C  K.....ORDER OF THE PIECEWISE POLYNOMIAL
C  IFLAG.....ON AN INITIAL CALL TO THE ROUTINE, IFLAG MAY BE ASSIGNED
C        ANY VALUE EXCEPT 0. THE ROUTINE MAY BE RECALLED WHEN ONLY GTAU
C        IS MODIFIED. IFLAG=0 WHEN THIS IS DONE.
C
C******  O U T P U T  ******
C
C  BCOEF.....THE B-COEFFICIENTS OF THE INTERPOLANT, OF LENGTH  N
C  Q.....ARRAY OF SIZE  (2*K-1)*N , CONTAINING THE TRIANGULAR FACTORIZ-
C        ATION OF THE COEFFICIENT MATRIX OF THE LINEAR SYSTEM FOR THE B-
C        COEFFICIENTS OF THE SPLINE INTERPOLANT.
C  IFLAG.....AN INTEGER INDICATING SUCCESS (= 0)  OR FAILURE (= 1)
C        THE LINEAR SYSTEM TO BE SOLVED IS (THEORETICALLY) INVERTIBLE IF
C        AND ONLY IF
C              B(I)(TAU(I)) .NE. 0   FOR ALL I.
C        VIOLATION OF THIS CONDITION IS CERTAIN TO LEAD TO IFLAG = 1.
C
C******  M E T H O D  ******
C
C     THE I-TH EQUATION OF THE LINEAR SYSTEM  A*BCOEF = B  FOR THE B-CO-
C  EFFS OF THE INTERPOLANT ENFORCES INTERPOLATION AT  TAU(I), I=1,...,N.
C  HENCE,  B(I) = GTAU(I), ALL I, AND  A  IS A BAND MATRIX WITH  2K-1
C  BANDS (IF IT IS INVERTIBLE).
C     THE MATRIX  A  IS GENERATED ROW BY ROW AND STORED, DIAGONAL BY DI-
C  AGONAL, IN THE  R O W S  OF THE ARRAY  Q , WITH THE MAIN DIAGONAL GO-
C  ING INTO ROW  K .  SEE COMMENTS IN THE PROGRAM BELOW.
C     THE BANDED SYSTEM IS THEN SOLVED BY A CALL TO BANFAC (WHICH CON-
C  STRUCTS THE TRIANGULAR FACTORIZATION FOR  A  AND STORES IT IN  Q),
C  FOLLOWED BY A CALL TO BANSLV (WHICH THEN OBTAINS THE SOLUTION BCOEF
C  BY SUBSTITUTION).
C     BANFAC PERFORMS NO PIVOTING SINCE THE TOTAL POSITIVITY OF THE
C  MATRIX A MAKES THIS UNNECESSARY.
C-----------------------------------------------------------------------
      REAL BCOEF(N), GTAU(N), Q(*), T(*), TAU(N)
C
      KM1 = K - 1
      IF (IFLAG .EQ. 0) GO TO 60
      NP1 = N + 1
      KPKM2 = 2*KM1
      IF (N .EQ. 1) GO TO 20
C
C        CHECK IF TAU(I) IS AN INCREASING SEQUENCE
C
      DO 10 I = 2,N
         IF (TAU(I) .LE. TAU(I-1)) GO TO 100
   10 CONTINUE
C
C                ZERO OUT ALL ENTRIES OF Q
C
   20 IF (TAU(N) .GT. T(NP1)) GO TO 100
      LENQ = N*(K + KM1)
      DO 21 I = 1,LENQ
         Q(I) = 0.0
   21 CONTINUE
C
C  ***   LOOP OVER I TO CONSTRUCT THE N INTERPOLATION EQUATIONS
C
      LEFT = K
      DO 51 I = 1,N
         TAUI = TAU(I)
         ILP1MX = MIN0(I + K,NP1)
C
C        *** FIND  LEFT  IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT
C                T(LEFT) .LE. TAU(I) .LT. T(LEFT+1)
C        MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE
C
         LEFT = MAX0(LEFT,I)
         IF (TAUI .LT. T(LEFT)) GO TO 100
   30       IF (TAUI .LT. T(LEFT+1)) GO TO 40
            LEFT = LEFT + 1
            IF (LEFT .LT. ILP1MX) GO TO 30
         IF (LEFT .EQ. I + K) GO TO 100
         LEFT = N
C
C        *** THE I-TH EQUATION ENFORCES INTERPOLATION AT TAUI, HENCE
C        A(I,J) = B(J,K,T)(TAUI), ALL J. ONLY THE  K  ENTRIES WITH  J =
C        LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE  K  NUMBERS
C        ARE RETURNED, IN  BCOEF (USED FOR TEMP.STORAGE HERE), BY THE
C        FOLLOWING
C
   40    JJ = 0
         CALL BSPVB (T, K, K, JJ, TAUI, LEFT, BCOEF)
C
C        LET Q DENOTE A TWO-DIMENSIONAL ARRAY OF DIMENSION (2*K-1,N).
C        WE THEREFORE WANT  BCOEF(J) = B(LEFT-K+J)(TAUI) TO GO INTO
C        A(I,LEFT-K+J), I.E., INTO  Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE
C        A(I+J,J)  IS TO GO INTO  Q(I+K,J), ALL I,J.  IN THE CURRENT
C        ROUTINE WE TREAT Q AS AN EQUIVALENT ONE-DIMENSIONAL ARRAY.
C        THUS WE WANT BCOEF(J) TO BE INSERTED INTO ENTRY
C            I - (LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1)
C                   =  I-LEFT+1 + (LEFT - K)*(2*K-1) + (2*K-2)*J
C        OF  Q .
C
         JJ = I - LEFT + 1 + (LEFT - K)*(K + KM1)
         DO 50 J = 1,K
            JJ = JJ + KPKM2
            Q(JJ) = BCOEF(J)
   50    CONTINUE
   51 CONTINUE
C
C     ***OBTAIN FACTORIZATION OF  A  , STORED AGAIN IN  Q.
C
      CALL BANFAC (Q, K + KM1, N, KM1, KM1, IFLAG)
      IFLAG = IFLAG - 1
      IF (IFLAG .NE. 0) RETURN
C
C     *** SOLVE  A*BCOEF = GTAU  BY BACKSUBSTITUTION
C
   60 DO 61 I = 1,N
         BCOEF(I) = GTAU(I)
   61 CONTINUE
      CALL BANSLV (Q, K + KM1, N, KM1, KM1, BCOEF)
      RETURN
C
C     *** ERROR RETURN
C
  100 IFLAG = 1
      RETURN
      END
      SUBROUTINE BANFAC ( W, NROWW, NROW, NBANDL, NBANDU, IFLAG )
C  FROM  * A PRACTICAL GUIDE TO SPLINES *  BY C. DE BOOR
C  RETURNS IN  W  THE LU-FACTORIZATION (WITHOUT PIVOTING) OF THE BANDED
C  MATRIX  A  OF ORDER  NROW  WITH  (NBANDL + 1 + NBANDU) BANDS OR DIAG-
C  ONALS IN THE WORK ARRAY  W .
C
C******  I N P U T  ******
C  W.....WORK ARRAY OF SIZE  (NROWW,NROW)  CONTAINING THE INTERESTING
C        PART OF A BANDED MATRIX  A , WITH THE DIAGONALS OR BANDS OF  A
C        STORED IN THE ROWS OF  W , WHILE COLUMNS OF  A  CORRESPOND TO
C        COLUMNS OF  W . THIS IS THE STORAGE MODE USED IN  LINPACK  AND
C        RESULTS IN EFFICIENT INNERMOST LOOPS.
C           EXPLICITLY,  A  HAS  NBANDL  BANDS BELOW THE DIAGONAL
C                            +     1     (MAIN) DIAGONAL
C                            +   NBANDU  BANDS ABOVE THE DIAGONAL
C        AND THUS, WITH    MIDDLE = NBANDU + 1,
C          A(I+J,J)  IS IN  W(I+MIDDLE,J)  FOR I=-NBANDU,...,NBANDL
C                                              J=1,...,NROW .
C        FOR EXAMPLE, THE INTERESTING ENTRIES OF A (1,2)-BANDED MATRIX
C        OF ORDER  9  WOULD APPEAR IN THE FIRST  1+1+2 = 4  ROWS OF  W
C        AS FOLLOWS.
C                          13 24 35 46 57 68 79
C                       12 23 34 45 56 67 78 89
C                    11 22 33 44 55 66 77 88 99
C                    21 32 43 54 65 76 87 98
C
C        ALL OTHER ENTRIES OF  W  NOT IDENTIFIED IN THIS WAY WITH AN EN-
C        TRY OF  A  ARE NEVER REFERENCED .
C  NROWW.....ROW DIMENSION OF THE WORK ARRAY  W .
C        MUST BE  .GE.  NBANDL + 1 + NBANDU  .
C  NBANDL.....NUMBER OF BANDS OF  A  BELOW THE MAIN DIAGONAL
C  NBANDU.....NUMBER OF BANDS OF  A  ABOVE THE MAIN DIAGONAL .
C
C******  O U T P U T  ******
C  IFLAG.....INTEGER INDICATING SUCCESS( = 1) OR FAILURE ( = 2) .
C     IF  IFLAG = 1, THEN
C  W.....CONTAINS THE LU-FACTORIZATION OF  A  INTO A UNIT LOWER TRIANGU-
C        LAR MATRIX  L  AND AN UPPER TRIANGULAR MATRIX  U (BOTH BANDED)
C        AND STORED IN CUSTOMARY FASHION OVER THE CORRESPONDING ENTRIES
C        OF  A . THIS MAKES IT POSSIBLE TO SOLVE ANY PARTICULAR LINEAR
C        SYSTEM  A*X = B  FOR  X  BY A
C              CALL BANSLV ( W, NROWW, NROW, NBANDL, NBANDU, B )
C        WITH THE SOLUTION X  CONTAINED IN  B  ON RETURN .
C     IF  IFLAG = 2, THEN
C        ONE OF  NROW-1, NBANDL,NBANDU FAILED TO BE NONNEGATIVE, OR ELSE
C        ONE OF THE POTENTIAL PIVOTS WAS FOUND TO BE ZERO INDICATING
C        THAT  A  DOES NOT HAVE AN LU-FACTORIZATION. THIS IMPLIES THAT
C        A  IS SINGULAR IN CASE IT IS TOTALLY POSITIVE .
C
C******  M E T H O D  ******
C     GAUSS ELIMINATION  W I T H O U T  PIVOTING IS USED. THE ROUTINE IS
C  INTENDED FOR USE WITH MATRICES  A  WHICH DO NOT REQUIRE ROW INTER-
C  CHANGES DURING FACTORIZATION, ESPECIALLY FOR THE  T O T A L L Y
C  P O S I T I V E  MATRICES WHICH OCCUR IN SPLINE CALCULATIONS.
C     THE ROUTINE SHOULD NOT BE USED FOR AN ARBITRARY BANDED MATRIX.
C
      REAL W(NROWW,NROW),   FACTOR,PIVOT
C
      IFLAG = 1
      MIDDLE = NBANDU + 1
C                         W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF  A .
      NROWM1 = NROW - 1
      IF (NROWM1)                       999,900,1
    1 IF (NBANDL .GT. 0)                GO TO 10
C                A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO .
      DO 5 I=1,NROWM1
         IF (W(MIDDLE,I) .EQ. 0.)       GO TO 999
    5    CONTINUE
                                        GO TO 900
   10 IF (NBANDU .GT. 0)                GO TO 20
C              A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND
C                 DIVIDE EACH COLUMN BY ITS DIAGONAL .
      DO 15 I=1,NROWM1
         PIVOT = W(MIDDLE,I)
         IF(PIVOT .EQ. 0.)              GO TO 999
         JMAX = MIN0(NBANDL, NROW - I)
         JBEG = MIDDLE + 1
         JEND = MIDDLE + JMAX
         DO 15 J=JBEG,JEND
   15       W(J,I) = W(J,I)/PIVOT
                                        GO TO 900
C
C        A  IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION
   20 DO 50 I=1,NROWM1
C                                  W(MIDDLE,I)  IS PIVOT FOR I-TH STEP .
         PIVOT = W(MIDDLE,I)
         IF (PIVOT .EQ. 0.)             GO TO 999
C                 JMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN  I
C                     BELOW THE DIAGONAL .
         JMAX = MIN0(NBANDL,NROW - I)
C              DIVIDE EACH ENTRY IN COLUMN  I  BELOW DIAGONAL BY PIVOT .
         JBEG = MIDDLE + 1
         JEND = MIDDLE + JMAX
         DO 32 J=JBEG,JEND
   32       W(J,I) = W(J,I)/PIVOT
C                 KMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN ROW  I  TO
C                     THE RIGHT OF THE DIAGONAL .
         KMAX = MIN0(NBANDU,NROW - I)
C                  SUBTRACT  A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN
C                  (BELOW ROW  I ) .
         DO 40 K=1,KMAX
            IPK = I + K
            MIDMK = MIDDLE - K
            FACTOR = W(MIDMK,IPK)
            DO 40 J=1,JMAX
               MJ = MIDDLE + J
               MDJ = MIDMK + J
   40          W(MDJ,IPK) = W(MDJ,IPK) - W(MJ,I)*FACTOR
   50    CONTINUE
C                                       CHECK THE LAST DIAGONAL ENTRY .
  900 IF (W(MIDDLE,NROW) .NE. 0.)       RETURN
  999 IFLAG = 2
                                        RETURN
      END
      SUBROUTINE BANSLV ( W, NROWW, NROW, NBANDL, NBANDU, B )
C  FROM  * A PRACTICAL GUIDE TO SPLINES *  BY C. DE BOOR
C  COMPANION ROUTINE TO  BANFAC . IT RETURNS THE SOLUTION  X  OF THE
C  LINEAR SYSTEM  A*X = B  IN PLACE OF  B , GIVEN THE LU-FACTORIZATION
C  FOR  A  IN THE WORKARRAY  W .
C
C******  I N P U T  ******
C  W, NROWW,NROW,NBANDL,NBANDU.....DESCRIBE THE LU-FACTORIZATION OF A
C        BANDED MATRIX  A  OF RODER  NROW  AS CONSTRUCTED IN  BANFAC .
C        FOR DETAILS, SEE  BANFAC .
C  B.....RIGHT SIDE OF THE SYSTEM TO BE SOLVED .
C
C******  O U T P U T  ******
C  B.....CONTAINS THE SOLUTION  X , OF ORDER  NROW .
C
C******  M E T H O D  ******
C     (WITH  A = L*U, AS STORED IN  W,) THE UNIT LOWER TRIANGULAR SYSTEM
C  L(U*X) = B  IS SOLVED FOR  Y = U*X, AND  Y  STORED IN  B . THEN THE
C  UPPER TRIANGULAR SYSTEM  U*X = Y  IS SOLVED FOR  X  . THE CALCUL-
C  ATIONS ARE SO ARRANGED THAT THE INNERMOST LOOPS STAY WITHIN COLUMNS.
C
      REAL W(NROWW,NROW),B(NROW)
      MIDDLE = NBANDU + 1
      IF (NROW .EQ. 1)                  GO TO 49
      NROWM1 = NROW - 1
      IF (NBANDL .EQ. 0)                GO TO 30
C                                 FORWARD PASS
C            FOR I=1,2,...,NROW-1, SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
C            OF  L )  FROM RIGHT SIDE  (BELOW I-TH ROW) .
      DO 21 I=1,NROWM1
         JMAX = MIN0(NBANDL, NROW-I)
         DO 21 J=1,JMAX
            IPJ = I + J
            MPJ = MIDDLE + J
   21       B(IPJ) = B(IPJ) - B(I)*W(MPJ,I)
C                                 BACKWARD PASS
C            FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG-
C            ONAL ENTRY OF  U, THEN SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
C            OF  U)  FROM RIGHT SIDE  (ABOVE I-TH ROW).
   30 IF (NBANDU .GT. 0)                GO TO 40
C                                A  IS LOWER TRIANGULAR .
      DO 31 I=1,NROW
   31    B(I) = B(I)/W(1,I)
                                        RETURN
   40 I = NROW
   41    B(I) = B(I)/W(MIDDLE,I)
         JMAX = MIN0(NBANDU,I-1)
         DO 45 J=1,JMAX
            IMJ = I - J
            MMJ = MIDDLE - J
   45       B(IMJ) = B(IMJ) - B(I)*W(MMJ,I)
         I = I - 1
         IF (I .GT. 1)                  GO TO 41
   49 B(1) = B(1)/W(MIDDLE,1)
                                        RETURN
      END
      SUBROUTINE BSLSQ (TAU, GTAU, WGT, NTAU, T, N, K, A, WK, Q, IERR)
C-----------------------------------------------------------------------
C
C        BSLSQ PRODUCES THE B-SPLINE COEFFICIENTS OF A PIECEWISE
C              POLYNOMIAL P(X) OF ORDER K WHICH MINIMIZES
C
C                SUM (WGT(J)*(P(TAU(J)) - GTAU(J))**2).
C
C
C     INPUT ...
C
C       TAU   ARRAY OF LENGTH NTAU CONTAINING DATA POINT ABSCISSAE.
C       GTAU  ARRAY OF LENGTH NTAU CONTAINING DATA POINT ORDINATES.
C       WGT   ARRAY OF LENGTH NTAU CONTAINING THE WEIGHTS.
C       NTAU  NUMBER OF DATA POINTS TO BE FITTED.
C       T     KNOT SEQUENCE OF LENGTH N + K.
C       N     DIMENSION OF THE PIECEWISE POLYNOMIAL SPACE.
C       K     ORDER OF THE B-SPLINES.
C
C     OUTPUT ...
C
C       A     ARRAY OF LENGTH N CONTAINING THE B-SPLINE COEFFICIENTS
C             OF THE L2 APPROXIMATION.
C
C       IERR  INTEGER REPORTING THE STATUS OF THE RESULTS ...
C
C             0  THE COEFFICIENT MATRIX IS NONSIGULAR. THE
C                UNIQUE LEAST SQUARES SOLUTION WAS OBTAINED.
C             1  THE COEFFICIENT MATRIX IS SINGULAR. A
C                LEAST SQUARES SOLUTION WAS OBTAINED.
C            -1  INPUT ERRORS WERE DETECTED.
C
C-----------------------------------------------------------------------
      REAL TAU(NTAU), GTAU(NTAU), WGT(NTAU)
      REAL T(*), A(N), WK(N), Q(K,N)
C
      IF (NTAU .LT. MAX0(2,K)) GO TO 100
      IF (TAU(1) .LT. T(K) .OR. TAU(NTAU) .GT. T(N + 1)) GO TO 100
C
      DO 10 I = 2,NTAU
         IF (TAU(I - 1) .GT. TAU(I)) GO TO 100
   10 CONTINUE
C
      DO 21 J = 1,N
         A(J) = 0.0
         DO 20 I = 1,K
            Q(I,J) = 0.0
   20    CONTINUE
   21 CONTINUE
C
      LEFT = K
      DO 70 L = 1,NTAU
C
C        *** FIND THE INDEX LEFT SUCH THAT
C            T(LEFT) .LE. TAU(L) .LT. T(LEFT+1)
C
   30    IF (LEFT .EQ. N) GO TO 40
            IF (TAU(L) .LT. T(LEFT+1)) GO TO 40
            LEFT = LEFT + 1
            GO TO 30
C
   40    JJ = 0
         CALL BSPVB (T, K, K, JJ, TAU(L), LEFT, WK)
C
         LEFTMK = LEFT - K
         DO 61 MM = 1,K
            DW = WK(MM)*WGT(L)
            J = LEFTMK + MM
            A(J) = DW*GTAU(L) + A(J)
            I = 1
            DO 60 JJ = MM,K
               Q(I,J) = WK(JJ)*DW + Q(I,J)
               I = I + 1
   60       CONTINUE
   61    CONTINUE
   70 CONTINUE
C
C        SOLVE THE NORMAL EQUATIONS
C
      CALL BCHFAC (Q, K, N, WK, IERR)
      CALL BCHSLV (Q, K, N, A)
      RETURN
C
C             ERROR RETURN
C
  100 IERR = -1
      RETURN
      END
      SUBROUTINE BCHFAC (W, NB, N, DIAG, IFLAG)
C-----------------------------------------------------------------------
C  FROM  * A PRACTICAL GUIDE TO SPLINES *  BY C. DE BOOR
C  CONSTRUCTS CHOLESKY FACTORIZATION
C                     C  =  L * D * L-TRANSPOSE
C  WITH L UNIT LOWER TRIANGULAR AND D DIAGONAL, FOR GIVEN MATRIX C OF
C  ORDER  N , IN CASE  C  IS (SYMMETRIC) POSITIVE SEMIDEFINITE
C  AND BANDED, HAVING NB DIAGONALS AT AND BELOW THE MAIN DIAGONAL.
C
C******  INPUT  ******
C
C     N      THE ORDER OF THE MATRIX C.
C
C     NB     THE BANDWIDTH OF C, I.E.,
C               C(I,J) = 0 FOR ABS(I-J) .GT. NB .
C
C     W      WORK ARRAY OF SIZE NB BY N CONTAINING THE NB DIAGONALS
C            IN ITS ROWS, WITH THE MAIN DIAGONAL IN ROW 1. PRECISELY,
C            W(I,J)  CONTAINS  C(I+J-1,J), I=1,...,NB, J=1,...,N.
C            FOR EXAMPLE, THE INTERESTING ENTRIES OF A SEVEN DIAGONAL
C            SYMMETRIC MATRIX C OF ORDER 9 WOULD BE STORED IN W AS
C
C                       11 22 33 44 55 66 77 88 99
C                       21 32 43 54 65 76 87 98
C                       31 42 53 64 75 86 97
C                       41 52 63 74 85 96
C
C            ALL OTHER ENTRIES OF W NOT IDENTIFIED WITH AN ENTRY OF C
C            ARE NEVER REFERENCED.
C
C     DIAG   WORK ARRAY OF LENGTH N.
C
C******  O U T P U T  ******
C                                                         T
C     W      CONTAINS THE CHOLESKY FACTORIZATION C = L*D*L   WHERE
C            W(1,I) = 1/D(I,I) AND W(I,J) = L(I-1+J,J) (I=2,...,NB).
C
C     IFLAG  0 IF C IS NONSINGULAR AND 1 IF C IS SINGULAR.
C
C******  M E T H O D  ******
C
C   GAUSS ELIMINATION, ADAPTED TO THE SYMMETRY AND BANDEDNESS OF  C , IS
C   USED .
C     NEAR ZERO PIVOTS ARE HANDLED IN A SPECIAL WAY. THE DIAGONAL ELE-
C  MENT C(K,K) = W(1,K) IS SAVED INITIALLY IN  DIAG(K), ALL K. AT THE K-
C  TH ELIMINATION STEP, THE CURRENT PIVOT ELEMENT, VIZ.  W(1,K), IS COM-
C  PARED WITH ITS ORIGINAL VALUE, DIAG(K). IF, AS THE RESULT OF PRIOR
C  ELIMINATION STEPS, THIS ELEMENT HAS BEEN REDUCED BY ABOUT A WORD
C  LENGTH, (I.E., IF W(1,K)+DIAG(K) .LE. DIAG(K)), THEN THE PIVOT IS DE-
C  CLARED TO BE ZERO, AND THE ENTIRE K-TH ROW IS DECLARED TO BE LINEARLY
C  DEPENDENT ON THE PRECEDING ROWS. THIS HAS THE EFFECT OF PRODUCING
C   X(K) = 0  WHEN SOLVING  C*X = B  FOR  X, REGARDLESS OF  B. JUSTIFIC-
C  ATION FOR THIS IS AS FOLLOWS. IN CONTEMPLATED APPLICATIONS OF THIS
C  PROGRAM, THE GIVEN EQUATIONS ARE THE NORMAL EQUATIONS FOR SOME LEAST-
C  SQUARES APPROXIMATION PROBLEM, DIAG(K) = C(K,K) GIVES THE NORM-SQUARE
C  OF THE K-TH BASIS FUNCTION, AND, AT THIS POINT,  W(1,K)  CONTAINS THE
C  NORM-SQUARE OF THE ERROR IN THE LEAST-SQUARES APPROXIMATION TO THE K-
C  TH BASIS FUNCTION BY LINEAR COMBINATIONS OF THE FIRST K-1 . HAVING
C  W(1,K)+DIAG(K) .LE. DIAG(K) SIGNIFIES THAT THE K-TH FUNCTION IS LIN-
C  EARLY DEPENDENT TO MACHINE ACCURACY ON THE FIRST K-1 FUNCTIONS, THERE
C  FORE CAN SAFELY BE LEFT OUT FROM THE BASIS OF APPROXIMATING FUNCTIONS
C     THE SOLUTION OF A LINEAR SYSTEM
C                       C*X = B
C   IS EFFECTED BY THE SUCCESSION OF THE FOLLOWING  T W O  CALLS ...
C     CALL BCHFAC (W, NB, N, DIAG, IFLAG)   , TO GET FACTORIZATION
C     CALL BCHSLV (W, NB, N, B, X )            , TO SOLVE FOR X.
C-----------------------------------------------------------------------
      REAL W(NB,N), DIAG(N)
C
      IF (N .GT. 1) GO TO 10
         IFLAG = 1
         IF (W(1,1) .EQ. 0.0) RETURN
         IFLAG = 0
         W(1,1) = 1.0/W(1,1)
         RETURN
C
C     STORE THE DIAGONAL OF C IN DIAG
C
   10 DO 11 K = 1,N
         DIAG(K) = W(1,K)
   11 CONTINUE
C
C     FACTORIZATION
C
      IFLAG = 0
      DO 60 K = 1,N
         T = W(1,K) + DIAG(K)
         IF (T .NE. DIAG(K)) GO TO 30
            IFLAG = 1
            DO 20 J = 1,NB
               W(J,K) = 0.0
   20       CONTINUE
            GO TO 60
C
   30    T = 1.0/W(1,K)
         W(1,K) = T
         IMAX = MIN0(NB - 1,N - K)
         IF (IMAX .LT. 1) GO TO 60
         JMAX = IMAX
         DO 50 I = 1,IMAX
            RATIO = T*W(I+1,K)
            KPI = K + I
            DO 40 J = 1,JMAX
               IPJ = I + J
               W(J,KPI) = W(J,KPI) - W(IPJ,K)*RATIO
   40       CONTINUE
            JMAX = JMAX - 1
            W(I+1,K) = RATIO
   50    CONTINUE
   60 CONTINUE
      RETURN
      END
      SUBROUTINE BCHSLV (W, NB, N, B)
C-----------------------------------------------------------------------
C
C     BCHSLV SOLVES THE LINEAR SYSTEM C*X = B FOR X WHEN W CONTAINS
C     THE CHOLESKY FACTORIZATION OBTAINED BY THE SUBROUTINE BCHFAC
C     FOR THE BANDED SYMMETRIC POSITIVE DEFINITE MATRIX C.
C
C     INPUT ...
C
C        N   THE ORDER OF THE MATRIX C
C        NB  THE BANDWIDTH OF C
C        W   THE CHOLESKY FACTORIZATION OF C
C        B   VECTOR OF LENGTH N CONTAINING THE RIGHT SIDE
C
C     OUTPUT ...
C
C        B   SOLUTION X OF THE LINEAR SYSTEM C*X = B
C
C                                       T
C     NOTE.  THE FACTORIZATION C = L*D*L  IS USED, WHERE L IS A
C     UNIT LOWER TRIANGULAR MATRIX AND D A DIAGONAL MATRIX.
C
C-----------------------------------------------------------------------
      REAL W(NB,N), B(N)
C
      IF (N .GT. 1) GO TO 10
      B(1) = B(1)*W(1,1)
      RETURN
C
C     FORWARD SUBSTITUTION. SOLVE L*Y = B FOR Y AND STORE Y IN B.
C
   10 NBM1 = NB - 1
      DO 30 K = 1,N
         JMAX = MIN0(NBM1,N - K)
         IF (JMAX .LT. 1) GO TO 30
         DO 20 J = 1,JMAX
            JPK = J + K
            B(JPK) = B(JPK) - W(J + 1,K)*B(K)
   20    CONTINUE
   30 CONTINUE
C                              T     -1
C     BACKSUBSTITUTION. SOLVE L X = D  Y  FOR X AND STORE X IN B.
C
      K = N
   40    B(K) = B(K)*W(1,K)
         JMAX = MIN0(NBM1,N - K)
         IF (JMAX .LT. 1) GO TO 60
         DO 50 J = 1,JMAX
            JPK = J + K
            B(K) = B(K) - W(J + 1,K)*B(JPK)
   50    CONTINUE
   60    K = K - 1
         IF (K .GT. 0) GO TO 40
      RETURN
      END
      SUBROUTINE BFIT (BKPT, N, NORD, XDATA, YDATA, NDATA,
     *                 XCONST, YCONST, NDERIV, NCONST,
     *                 MODE, COEFF, RNORM, W, IW)
C-----------------------------------------------------------------------
C
C      THIS SUBPROGRAM FITS A PIECE-WISE POLYNOMIAL CURVE
C      TO DISCRETE DATA.  THE PIECE-WISE POLYNOMIALS ARE
C      REPRESENTED AS B-SPLINES.
C      THE FITTING IS DONE IN A LEAST SQUARES SENSE.
C      EQUALITY AND INEQUALITY CONSTRAINTS CAN BE IMPOSED
C      ON THE FITTED CURVE.
C
C  INPUT..
C
C      N,NORD,BKPT(*)     N IS THE NUMBER OF COEFFICIENTS TO BE COM-
C                         PUTED AND NORD IS THE ORDER OF THE B-SPLINE.
C                         IT IS ASSUMED THAT N .GE. NORD. THE N + NORD
C                         KNOTS OF THE SPLINE ARE IN THE ARRAY BKPT(*).
C                         IT IS ASSUMED THAT THE KNOTS FORM A NONDE-
C                         CREASING SEQUENCE. THE PROBLEM DATA INTERVAL
C                         LIES BETWEEN THE POINTS BKPT(NORD) AND
C                         BKPT(N+1). THE ADDITIONAL END KNOTS BKPT(I),
C                         I = 1,...,NORD-1 AND I = N+2,...,N+NORD, ARE
C                         REQUIRED TO COMPUTE THE FUNCTIONS USED TO
C                         FIT THE DATA.
C
C                         (THE ORDER OF THE B-SPLINE IS ONE MORE THAN
C                         THE DEGREE OF THE PIECEWISE POLYNOMIAL. FOR
C                         EXAMPLE, NORD=4 WHEN WE ARE USING PIECEWISE
C                         CUBICS.)
C
C      NDATA,XDATA(*),
C      YDATA(*)           THE NDATA DISCRETE (X,Y) PAIRS ARE IN
C                         THE ARRAYS XDATA(*) AND YDATA(*). IT IS
C                         ASSUMED THAT XDATA(*) IS AN INCREASING
C                         SEQUENCE, XDATA(1) .GE. BKPT(NORD), AND
C                         XDATA(NDATA) .LE. BKPT(N+1).
C
C      NCONST,XCONST(*),
C      YCONST(*),NDERIV(*)
C                         THE NUMBER OF CONDITIONS THAT CONSTRAIN
C                         THE B-SPLINE IS NCONST. A CONSTRAINT IS
C                         SPECIFIED BY AN (X,Y) PAIR IN THE ARRAYS
C                         XCONST(*) AND YCONST(*), AND BY THE TYPE
C                         OF CONSTRAINT AND DERIVATIVE VALUE ENCODED
C                         IN THE ARRAY NDERIV(*). IT IS ASSUMED THAT
C                         THE VALUES IN XCONST(*) ARE IN THE CLOSED
C                         INTERVAL (BKPT(NORD),BKPT(N+1)). THE CON-
C                         STRAINTS MAY BE GIVEN IN ANY ORDER. THE
C                         VALUE OF NDERIV(*) IS DETERMINED AS FOLLOWS.
C                         SUPPOSE THE I-TH CONSTRAINT APPLIES TO THE
C                         J-TH DERIVATIVE OF THE B-SPLINE.  (ANY
C                         NONNEGATIVE VALUE OF J .LT. NORD IS PERMITTED.
C                         IN PARTICULAR, THE VALUE J = 0 REFERS TO THE
C                         B-SPLINE ITSELF.)
C                         FOR THIS I-TH CONSTRAINT, SET
C                          XCONST(I) = X,
C                          YCONST(I) = Y, AND
C                          NDERIV(I) = ITYPE + 4*J  WHERE
C
C                          ITYPE = 0,      IF (J-TH DERIV. AT X) .LE. Y.
C                                = 1,      IF (J-TH DERIV. AT X) .GE. Y.
C                                = 2,      IF (J-TH DERIV. AT X) .EQ. Y.
C                                = 3,      IF (J-TH DERIV. AT X) .EQ.
C                                             (J-TH DERIV. AT Y).
C                          (A NEGATIVE VALUE FOR NDERIV(I) WILL CAUSE
C                          THIS CONSTRAINT TO BE IGNORED.  THIS
C                          FEATURE IS OFTEN USEFUL WHEN TEMPORARILY
C                          SUPPRESSING A CONSTRAINT WHILE STILL
C                          RETAINING THE SOURCE CODE OF THE CALLING
C                          PROGRAM.)
C
C      MODE               AN INPUT FLAG THAT DIRECTS THE LEAST
C                         SQUARES SOLUTION METHOD USED BY BFIT( ).
C
C                         MODE = 0      A NEW PROBLEM.
C
C                         MODE .NE. 0   AN OLD PROBLEM.
C
C                         BY AN OLD PROBLEM IT IS MEANT THAT BFIT( )
C                         WAS LAST CALLED WITH THE SAME SET OF KNOTS
C                         AND DATA POINTS. (THE CONSTRAINTS MAY BE
C                         DIFFERENT THAN BEFORE.)
C
C
C      IW(1),IW(2)        THE AMOUNTS OF WORKING STORAGE ACTUALLY
C                         ALLOCATED FOR THE WORKING ARRAYS W(*) AND
C                         IW(*).  THESE QUANTITIES ARE COMPARED WITH THE
C                         ACTUAL AMOUNTS OF STORAGE NEEDED IN BFIT( ).
C                         INSUFFICIENT STORAGE ALLOCATED FOR
C                         EITHER W(*) OR IW(*) IS AN ERROR.
C
C                         LENGTH OF W(*) MUST BE AT LEAST
C
C                           NB = (N + 3)*(NORD + 1) + NORD**2
C
C                         AND THE LENGTH OF IW(*) MUST BE AT LEAST 2.
C                         WHENEVER POSSIBLE THE CODE USES BANDED MATRIX
C                         PROCESSORS BNDACC( ) AND BNDSL( ).  THESE
C                         ARE UTILIZED IF THERE ARE NO CONSTRAINTS AND
C                         THERE IS SUFFICIENT DATA TO UNIQUELY DETERMINE
C                         THE B-SPLINE COEFFICENTS.
C
C                         IF THE BAND PROCESSORS CANNOT BE USED TO
C                         DETERMINE THE SOLUTION, THEN THE CONSTRAINED
C                         LEAST SQUARES CODE LSEI( ) IS USED.
C                         IN THIS CASE THE SUBPROGRAM REQUIRES AN
C                         ADDITIONAL BLOCK OF STORAGE IN W(*).  FOR THE
C                         DISCUSSION HERE DEFINE THE INTEGERS
C                         NEQCON AND NINCON RESPECTIVELY AS THE
C                         NUMBER OF EQUALITY (ITYPE=2,3) AND
C                         INEQUALITY (ITYPE=0,1) CONSTRAINTS
C                         IMPOSED ON THE FITTED CURVE.  DEFINE
C
C                           L = N + 1
C
C                         AND NOTE THAT
C
C                           NCONST = NEQCON + NINCON.
C
C                         WHEN THE SUBPROGRAM BFIT( ) USES LSEI( ) THE
C                         LENGTH OF THE WORKING ARRAY W(*) MUST BE AT
C                         LEAST
C
C                           LW = NB + (L+NCONST)*L + 2*(NEQCON+L)
C                                   + (NINCON + L) + (NINCON+2)*(L+6)
C
C                         AND THE LENGTH OF THE ARRAY IW(*) MUST BE AT
C                         LEAST
C
C                           IW1 = NINCON + 2*L .
C
C  OUTPUT..
C
C      MODE               AN OUTPUT FLAG THAT INDICATES THE STATUS
C                         OF THE CONSTRAINED CURVE FIT.
C
C                         =-1  EITHER NORD .LT. 1 OR NORD .GT. N.
C
C                         =-2  EITHER NDATA .LT. 1 OR NCONST .LT. 0.
C
C                         =-3  BKPT(I) .GT. BKPT(I+1) FOR SOME I.
C
C                         =-4  XDATA(*) IS NOT AN INCREASING
C                              SEQUENCE IN THE CLOSED INTERVAL
C                              (BKPT(NORD), BKPT(N+1)).
C
C                         =-5  THE I-TH CONSTRAINT IS INCORRECT
C                              FOR THE VALUE OF I STORED IN IW(2).
C
C                         =-6  INSUFF. STORAGE FOR W(*). IW(1) HAS
C                              BEEN RESET TO THE AMOUNT OF STORAGE
C                              NEEDED BY W(*).
C
C                         =-7  INSUFF. STORAGE FOR IW(*). IW(2) HAS
C                              BEEN RESET TO THE AMOUNT OF STORAGE
C                              NEEDED BY IW(*).
C
C                         = 0  SUCCESSFUL CONSTRAINED CURVE FIT.
C
C                         = 1  THE REQUESTED EQUALITY CONSTRAINTS
C                              ARE CONTRADICTORY.
C
C                         = 2  THE PROBLEM CANNOT BE SOLVED. THE
C                              CONSTRAINTS ARE CONTRADICTORY.
C
C      COEFF(*)
C                         IF THE OUTPUT VALUE OF MODE=0 OR 1, COEFF(*)
C                         CONTAINS THE N UNKNOWNS OBTAINED FROM THE
C                         LEAST SQUARES FITTING PROCESS.  THESE N
C                         PARAMETERS ARE THE B-SPLINE COEFFICIENTS.
C                         FOR MODE=1, THE EQUALITY CONSTRAINTS ARE
C                         CONTRADICTORY.  TO MAKE THE FITTING PROCESS
C                         MORE ROBUST, THE EQUALITY CONSTRAINTS ARE
C                         SATISFIED IN A LEAST SQUARES SENSE.  IN
C                         THIS CASE THE ARRAY COEFF(*) CONTAINS
C                         B-SPLINE COEFFICIENTS FOR THIS EXTENDED
C                         CONCEPT OF A SOLUTION.
C                         IF MODE .LT. 0 OR MODE = 2 ON OUTPUT, THE
C                         ARRAY COEFF(*) IS UNDEFINED.
C
C      RNORM              IF THE OUTPUT VALUE OF MODE = 0 OR 1 THEN
C                         RNORM IS THE L2 NORM OF THE VECTOR
C                         (YDATA(I) - F(XDATA(I)), I = 1,NDATA).
C
C  WORKING ARRAYS..
C
C      W(*),IW(*)         THESE ARRAYS ARE RESPECTIVELY TYPED
C                         REAL AND INTEGER.  THEIR REQUIRED
C                         LENGTHS ARE SPECIFIED AS INPUT PARAMETERS
C                         IN IW(1), IW(2) NOTED ABOVE. IT IS ASSUMED
C                         THAT W(1),...,W(NB) HAVE NOT BEEN MODIFIED
C                         IF BFIT( ) IS BEING RECALLED FOR THE SAME
C                         KNOTS AND DATA AS BEFORE (I.E., IF WE HAVE
C                         AN OLD PROBLEM).
C
C
C   REFERENCE.  HANSON R.J., CONSTRAINED LEAST SQUARES CURVE FITTING
C               TO DISCRETE DATA USING B-SPLINES, A USERS GUIDE.
C               SANDIA LABS. TECH. REPT. SAND-78-1291, DEC, 1978.
C
C-----------------------------------------------------------------------
C   WRITTEN BY
C     RICHARD J. HANSON
C     SANDIA LABORATORIES
C   MODIFIED BY A.H. MORRIS (NSWC)
C-----------------------------------------------------------------------
      REAL BKPT(*), XDATA(NDATA), YDATA(NDATA)
      REAL XCONST(*), YCONST(*), COEFF(N), W(*)
      INTEGER NDERIV(*), IW(*)
C
      NBKPT = N + NORD
      MDG = N + 3
      MDW = N + 1 + NCONST
C
C                         USAGE IN BFIT0( ) OF W(*)..
C
C      I1,...,I2-1      G(*,*)
C
C      I2,...,I3-1      BF(*,*)
C
C      I3,...,I7-1      W(*,*)
C
C      I7,...           WORK(*) FOR BSPVD( ) AND LSEI( )
C
      I1 = 1
      I2 = I1 + MDG*(NORD + 1)
      I3 = I2 + NORD*NORD
      I7 = I3 + MDW*(N + 1)
C
      CALL BFIT0 (NDATA, XDATA, YDATA, NORD, NBKPT, BKPT, NCONST,
     1         XCONST, YCONST, NDERIV, MODE, COEFF, RNORM, W(I2),
     2         W(I1), MDG, W(I3), MDW, W(I7), IW)
      RETURN
      END
      SUBROUTINE BFIT0 (NDATA, XDATA, YDATA, NORD, NBKPT, BKPT,
     1        NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, RNORM,
     2        BF, G, MDG, W, MDW, WORK, IWORK)
C---------------------
      REAL BKPT(NBKPT), XDATA(NDATA), YDATA(NDATA)
      REAL XCONST(*), YCONST(*), COEFF(*)
      REAL BF(NORD,NORD), G(MDG,*), W(MDW,*), WORK(*)
      INTEGER NDERIV(*), IWORK(*)
C
      REAL PRGOPT(7)
      LOGICAL BAND, NEW
C
      GO TO 100
C
   10 IF (.NOT. BAND) GO TO 20
      CALL BNDSL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM, IERR)
      IF (IERR .EQ. 0) RETURN
C
C     CHECK FURTHER FOR SUFFICIENT STORAGE IN WORKING ARRAYS.
C
   20 IF (IW1 .LT. LW) GO TO 850
      IF (IW2 .LT. INTW1) GO TO 860
      GO TO 300
C
C     SOLVE THE EQUATIONS
C
   30 CALL LSEI(W, MDW, NEQCON, NP1, NINCON, N, PRGOPT, COEFF, RNORME,
     *          RNORM, MODE, WORK, IWORK)
      IWORK(1) = IW1
      IWORK(2) = IW2
      RETURN
C-----------------------------------------------------------------------
C               INITIALIZE-VARIABLES-AND-ANALYZE-INPUT
C-----------------------------------------------------------------------
  100 N = NBKPT - NORD
      IF (NORD .LT. 1 .OR. NORD .GT. N) GO TO 800
      IF (NDATA .LT. 1 .OR. NCONST .LT. 0) GO TO 810
C
C     CHECK THE BREAK POINTS
C
      IF (MODE .NE. 0) GO TO 120
      M = NBKPT - 1
      DO 110 I = 1,M
         IF (BKPT(I) .GT. BKPT(I+1)) GO TO 820
  110 CONTINUE
C
C     AMOUNT OF STORAGE ALLOCATED FOR W(*),IW(*)
C
  120 IW1 = IWORK(1)
      IW2 = IWORK(2)
      NB = (N + 3)*(NORD + 1) + NORD*NORD
      LW = NB
      IF (IW1 .LT. NB) GO TO 850
C
C     COMPUTE THE AMOUNT OF STORAGE NEEDED FOR LSEI
C
      NEQCON = 0
      NINCON = 0
      IF (NCONST .EQ. 0) GO TO 150
      DO 140 I = 1,NCONST
         L = NDERIV(I)
         IF (L .LT. 0) GO TO 140
         ITYPE = L - 4*(L/4)
         IF (ITYPE .GT. 1) GO TO 130
            NINCON = NINCON + 1
            GO TO 140
  130    NEQCON = NEQCON + 1
  140 CONTINUE
C
  150 NP1 = N + 1
      L = NP1
      LW = NB + (L+NCONST)*L + 2*(NEQCON+L) + (NINCON+L) +
     *          (NINCON+2)*(L+6)
      INTW1 = NINCON + 2*L
C
C     CHECK THE XCONST(*) ARRAY
C
      XMIN = BKPT(NORD)
      XMAX = BKPT(NP1)
      IF (NCONST .EQ. 0) GO TO 170
      DO 160 I = 1,NCONST
         IF (XCONST(I) .LT. XMIN .OR. XCONST(I) .GT. XMAX)
     *       GO TO 840
  160 CONTINUE
C
C     INITIALIZE PARAMETERS
C
  170 NEW = MODE .EQ. 0
      BAND = NCONST .EQ. 0
      MODE = 0
      NORDM1 = NORD - 1
      NORDP1 = NORD + 1
C
C     DEFINE THE OPTION VECTOR FOR USE IN LSEI( )
C
C     INCREASE THE RANK DETERMINATION TOLERANCES
C     FOR BOTH EQUALITY CONSTRAINT EQUATIONS AND
C     LEAST SQUARES EQUATIONS.
C
      PRGOPT(1) = 4
      PRGOPT(2) = 4
      PRGOPT(3) = 1.E-3
C
      PRGOPT(4) = 7
      PRGOPT(5) = 5
      PRGOPT(6) = 1.E-3
C
      PRGOPT(7) = 1
C
      IF (.NOT. NEW) GO TO 260
C
C     CHECK THE XDATA(*) ARRAY
C
      IF (XDATA(1) .LT. XMIN .OR. XDATA(NDATA) .GT. XMAX)
     *   GO TO 830
      IF (NDATA .EQ. 1) GO TO 200
C
      M = NDATA - 1
      DO 180 I = 1,M
         IF (XDATA(I) .GE. XDATA(I+1)) GO TO 830
  180 CONTINUE
C
C     INITIALIZE PARAMETERS OF BANDED MATRIX PROCESSOR, BNDACC( )
C
  200 MT = 0
      IP = 1
      IR = 1
      IDATA = 1
      ILEFT = NORD
C
  210 IF (IDATA .GT. NDATA) GO TO 250
      XVAL = XDATA(IDATA)
      IF (ILEFT .EQ. N) GO TO 230
C
C     WHEN INTERVAL CHANGES, PROCESS EQUATIONS IN THE LAST BLOCK.
C
      IP1 = ILEFT + 1
      IF (XVAL .LT. BKPT(IP1)) GO TO 230
      INTRVL = ILEFT - NORDM1
      CALL BNDACC (G, MDG, NORD, IP, IR, MT, INTRVL)
      MT = 0
C
C     MOVE POINTER UP SO THAT XVAL .GE. BKPT(ILEFT).
C
      DO 220 I = IP1,N
         IF (XVAL .LT. BKPT(I)) GO TO 230
  220    ILEFT = I
C
C     OBTAIN B-SPLINE FUNCTION VALUE
C
  230 J = 0
      CALL BSPVB (BKPT, NORD, NORD, J, 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(IDATA)
C
C     WHEN STAGING WORK AREA IS EXHAUSTED, PROCESS ROWS
C
      IF (IROW .NE. MDG - 1) GO TO 240
         INTRVL = ILEFT - NORDM1
         CALL BNDACC (G, MDG, NORD, IP, IR, MT, INTRVL)
         MT = 0
  240 IDATA = IDATA + 1
      GO TO 210
C
C     PROCESS  BLOCK OF EQUATIONS
C
  250 INTRVL = ILEFT - NORDM1
      CALL BNDACC (G, MDG, NORD, IP, IR, MT, INTRVL)
C
C     LAST CALL TO ADJUST BLOCK POSITIONING
C
      G(IR,1) = 0.0
      CALL SCOPY (NORDP1, G(IR,1), 0, G(IR,1), MDG)
      CALL BNDACC (G, MDG, NORD, IP, IR, 1, NP1)
C
  260 DO 270 I = 1,N
        BAND = BAND .AND. G(I,1) .NE. 0.0
  270 CONTINUE
      GO TO 10
C-----------------------------------------------------------------------
C       ANALYZE CONSTRAINT INDICATORS FOR EQUALITY CONSTRAINTS
C-----------------------------------------------------------------------
  300 IDATA = 0
      NEQCON = 0
C
  310 IDATA = IDATA + 1
      IF (IDATA .GT. NCONST) GO TO 400
      L = NDERIV(IDATA)
      IF (L .LT. 0) GO TO 310
      IDERIV = L/4
      ITYPE = L - 4*IDERIV
C
      IF (ITYPE .LT. 2) GO TO 310
      NEQCON = NEQCON + 1
      XVAL = XCONST(IDATA)
      ILEFT = NORD
      IF (NORD .EQ. N) GO TO 330
      DO 320 I = NORDP1,N
         IF (XVAL .LT. BKPT(I)) GO TO 330
  320    ILEFT = I
  330 CALL BSPVD (BKPT, NORD, XVAL, ILEFT, BF, NORD, IDERIV + 1, WORK)
      W(NEQCON,1) = 0.0
      CALL SCOPY (N, W(NEQCON,1), 0, W(NEQCON,1), MDW)
      INTRVL = ILEFT - NORDM1
      CALL SCOPY (NORD, BF(1,IDERIV+1), 1, W(NEQCON,INTRVL), MDW)
      IF (ITYPE .NE. 2) GO TO 340
      W(NEQCON,NP1) = YCONST(IDATA)
      GO TO 310
C
  340 W(NEQCON,NP1) = 0.0
      YVAL = YCONST(IDATA)
      I = IDATA
      IF (YVAL .LT. XMIN .OR. YVAL .GT. XMAX) GO TO 840
      ILEFT = NORD
      IF (NORD .EQ. N) GO TO 360
      DO 350 I = NORDP1,N
         IF (YVAL .LT. BKPT(I)) GO TO 360
  350    ILEFT = I
  360 CALL BSPVD (BKPT, NORD, YVAL, ILEFT, BF, NORD, IDERIV + 1, WORK)
      INTRVL = ILEFT - NORDM1
      CALL SAXPY (NORD, -1.0, BF(1,IDERIV+1), 1, W(NEQCON,INTRVL), MDW)
      GO TO 310
C-----------------------------------------------------------------------
C                    TRANSFER-LEAST-SQUARES DATA
C-----------------------------------------------------------------------
  400 DO 410 I = 1,NP1
        IROW = I + NEQCON
        W(IROW,1) = 0.0
        CALL SCOPY (N, W(IROW,1), 0, W(IROW,1), MDW)
        CALL SCOPY (MIN0(NP1-I,NORD), G(I,1), MDG, W(IROW,I), MDW)
        W(IROW,NP1) = G(I,NORDP1)
  410 CONTINUE
C-----------------------------------------------------------------------
C      ANALYZE CONSTRAINT INDICATORS FOR INEQUALITY CONSTRAINTS
C-----------------------------------------------------------------------
      IDATA = 0
      NINCON = 0
C
  500 IDATA = IDATA + 1
      IF (IDATA .GT. NCONST) GO TO 30
      L = NDERIV(IDATA)
      IF (L .LT. 0) GO TO 500
      IDERIV = L/4
      ITYPE = L - 4*IDERIV
C
      IF (ITYPE .GT. 1) GO TO 500
      NINCON = NINCON + 1
      XVAL = XCONST(IDATA)
      ILEFT = NORD
      IF (NORD .EQ. N) GO TO 520
      DO 510 I = NORDP1,N
         IF (XVAL .LT. BKPT(I)) GO TO 520
  510    ILEFT = I
  520 CALL BSPVD (BKPT, NORD, XVAL, ILEFT, BF, NORD, IDERIV + 1, WORK)
      IROW = NEQCON + NP1 + NINCON
      W(IROW,1) = 0.0
      CALL SCOPY (N, W(IROW,1), 0, W(IROW,1), MDW)
      INTRVL = ILEFT - NORDM1
      CALL SCOPY (NORD, BF(1,IDERIV+1), 1, W(IROW,INTRVL), MDW)
      W(IROW,NP1) = YCONST(IDATA)
      IF (ITYPE .NE. 0) GO TO 500
      W(IROW,NP1) = -W(IROW,NP1)
      CALL SSCAL(NORD, -1.0, W(IROW,INTRVL), MDW)
      GO TO 500
C-----------------------------------------------------------------------
C                         ERROR RETURN
C-----------------------------------------------------------------------
C                       EITHER NORD .LT. 1 OR NORD .GT. N.
  800 MODE = -1
      RETURN
C                       EITHER NDATA .LT. 1 OR NCONST .LT. 0.
  810 MODE = -2
      RETURN
C                       THE SEQUENCE OF KNOTS IS NOT NONDECREASING.
  820 MODE = -3
      RETURN
C                       XDATA(*) IS NOT AN INCREASING SEQUENCE IN THE
C                       CLOSED INTERVAL (BKPT(1),BKPT(N+1)).
  830 MODE = -4
      RETURN
C                       THE I-TH CONSTRAINT IS INCORRECT FOR THE
C                       VALUE OF I STORED IN IWORK(2).
  840 IWORK(2) = I
      MODE = -5
      RETURN
C                       INSUFF. STORAGE FOR W(*). IWORK(1) HAS BEEN SET
C                       TO THE AMOUNT OF STORAGE NEEDED BY W(*).
  850 IWORK(1) = LW
      MODE = -6
      RETURN
C                       INSUFF. STORAGE FOR IW(*). IWORK(2) HAS BEEN SET
C                       TO THE AMOUNT OF STORAGE NEEDED BY IW(*).
  860 IWORK(2) = INTW1
      MODE = -7
      RETURN
      END
      SUBROUTINE BNDACC (G,MDG,NB,IP,IR,MT,JT)
C
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C
C***PURPOSE  SOLVE THE LEAST SQUARES PROBLEM AX = B FOR BANDED
C            MATRICES A USING SEQUENTIAL ACCUMULATION OF ROWS OF
C            THE DATA MATRIX.  EXACTLY ONE RIGHT-HANDED SIDE VECTOR
C            IS PERMITTED.
C***DESCRIPTION
C
C     THESE SUBROUTINES SOLVE THE LEAST SQUARES PROBLEM AX = B FOR
C     BANDED MATRICES A USING SEQUENTIAL ACCUMULATION OF ROWS OF THE
C     DATA MATRIX.  EXACTLY ONE RIGHT-HAND SIDE VECTOR IS PERMITTED.
C
C     THESE SUBROUTINES ARE INTENDED FOR THE TYPE OF LEAST SQUARES
C     SYSTEMS THAT ARISE IN APPLICATIONS SUCH AS CURVE OR SURFACE
C     FITTING OF DATA.  THE LEAST SQUARES EQUATIONS ARE ACCUMULATED AND
C     PROCESSED USING ONLY PART OF THE DATA.  THIS REQUIRES A CERTAIN
C     USER INTERACTION DURING THE SOLUTION OF AX = B.
C
C     SPECIFICALLY, SUPPOSE THE DATA MATRIX (A B) IS ROW PARTITIONED
C     INTO Q SUBMATRICES.  LET (E F) BE THE T-TH ONE OF THESE
C     SUBMATRICES WHERE E = (0 C 0).  HERE THE DIMENSION OF E IS MT BY N
C     AND THE DIMENSION OF C IS MT BY NB.  THE VALUE OF NB IS THE
C     BANDWIDTH OF A.  THE DIMENSIONS OF THE LEADING BLOCK OF ZEROS IN E
C     ARE MT BY JT-1.
C
C     THE USER OF THE SUBROUTINE BNDACC PROVIDES MT,JT,C AND F FOR
C     T=1,...,Q.  NOT ALL OF THIS DATA MUST BE SUPPLIED AT ONCE.
C
C     FOLLOWING THE PROCESSING OF THE VARIOUS BLOCKS (E F), THE MATRIX
C     (A B) HAS BEEN TRANSFORMED TO THE FORM (R D) WHERE R IS UPPER
C     TRIANGULAR AND BANDED WITH BANDWIDTH NB.  THE LEAST SQUARES
C     SYSTEM RX = D IS THEN EASILY SOLVED USING BACK SUBSTITUTION BY
C     EXECUTING THE STATEMENT CALL BNDSL(1,...). THE SEQUENCE OF
C     VALUES FOR JT MUST BE NONDECREASING.  THIS MAY REQUIRE SOME
C     PRELIMINARY INTERCHANGES OF ROWS AND COLUMNS OF THE MATRIX A.
C
C     THE PRIMARY REASON FOR THESE SUBROUTINES IS THAT THE TOTAL
C     PROCESSING CAN TAKE PLACE IN A WORKING ARRAY OF DIMENSION MU BY
C     NB+1.  AN ACCEPTABLE VALUE FOR MU IS
C
C                       MU = MAX(MT + N + 1),
C
C     WHERE N IS THE NUMBER OF UNKNOWNS.
C
C     HERE THE MAXIMUM IS TAKEN OVER ALL VALUES OF MT FOR T=1,...,Q.
C     NOTICE THAT MT CAN BE TAKEN TO BE A SMALL AS ONE, SHOWING THAT
C     MU CAN BE AS SMALL AS N+2.  THE SUBPROGRAM BNDACC PROCESSES THE
C     ROWS MORE EFFICIENTLY IF MU IS LARGE ENOUGH SO THAT EACH NEW
C     BLOCK (C F) HAS A DISTINCT VALUE OF JT.
C
C     THE FOUR PRINCIPLE PARTS OF THESE ALGORITHMS ARE OBTAINED BY THE
C     FOLLOWING CALL STATEMENTS
C
C     CALL BNDACC(...)  INTRODUCE NEW BLOCKS OF DATA.
C
C     CALL BNDSL(1,...)COMPUTE SOLUTION VECTOR AND LENGTH OF
C                       RESIDUAL VECTOR.
C
C     CALL BNDSL(2,...)GIVEN ANY ROW VECTOR H SOLVE YR = H FOR THE
C                       ROW VECTOR Y.
C
C     CALL BNDSL(3,...)GIVEN ANY COLUMN VECTOR W SOLVE RZ = W FOR
C                       THE COLUMN VECTOR Z.
C
C     THE DOTS IN THE ABOVE CALL STATEMENTS INDICATE ADDITIONAL
C     ARGUMENTS THAT WILL BE SPECIFIED IN THE FOLLOWING PARAGRAPHS.
C
C     THE USER MUST DIMENSION THE ARRAY APPEARING IN THE CALL LIST..
C     G(MDG,NB+1)
C
C     DESCRIPTION OF CALLING SEQUENCE FOR BNDACC..
C
C     THE ENTIRE SET OF PARAMETERS FOR BNDACC ARE
C
C     INPUT..
C
C     G(*,*)            THE WORKING ARRAY INTO WHICH THE USER WILL
C                       PLACE THE MT BY NB+1 BLOCK (C F) IN ROWS IR
C                       THROUGH IR+MT-1, COLUMNS 1 THROUGH NB+1.
C                       SEE DESCRIPTIONS OF IR AND MT BELOW.
C
C     MDG               THE NUMBER OF ROWS IN THE WORKING ARRAY
C                       G(*,*).  THE VALUE OF MDG SHOULD BE .GE. MU.
C                       THE VALUE OF MU IS DEFINED IN THE ABSTRACT
C                       OF THESE SUBPROGRAMS.
C
C     NB                THE BANDWIDTH OF THE DATA MATRIX A.
C
C     IP                SET BY THE USER TO THE VALUE 1 BEFORE THE
C                       FIRST CALL TO BNDACC.  ITS SUBSEQUENT VALUE
C                       IS CONTROLLED BY BNDACC TO SET UP FOR THE
C                       NEXT CALL TO BNDACC.
C
C     IR                INDEX OF THE ROW OF G(*,*) WHERE THE USER IS
C                       TO PLACE THE NEW BLOCK OF DATA (C F).  SET BY
C                       THE USER TO THE VALUE 1 BEFORE THE FIRST CALL
C                       TO BNDACC.  ITS SUBSEQUENT VALUE IS CONTROLLED
C                       BY BNDACC. A VALUE OF IR .GT. MDG IS CONSIDERED
C                       AN ERROR.
C
C     MT,JT             SET BY THE USER TO INDICATE RESPECTIVELY THE
C                       NUMBER OF NEW ROWS OF DATA IN THE BLOCK AND
C                       THE INDEX OF THE FIRST NONZERO COLUMN IN THAT
C                       SET OF ROWS (E F) = (0 C 0 F) BEING PROCESSED.
C
C     OUTPUT..
C
C     G(*,*)            THE WORKING ARRAY WHICH WILL CONTAIN THE
C                       PROCESSED ROWS OF THAT PART OF THE DATA
C                       MATRIX WHICH HAS BEEN PASSED TO BNDACC.
C
C     IP,IR             THE VALUES OF THESE ARGUMENTS ARE ADVANCED BY
C                       BNDACC TO BE READY FOR STORING AND PROCESSING
C                       A NEW BLOCK OF DATA IN G(*,*).
C
C
C     REMARKS..
C
C     TO OBTAIN THE UPPER TRIANGULAR MATRIX AND TRANSFORMED RIGHT-HAND
C     SIDE VECTOR D SO THAT THE SUPER DIAGONALS OF R FORM THE COLUMNS
C     OF G(*,*), EXECUTE THE FOLLOWING FORTRAN STATEMENTS.
C
C     NBP1=NB+1
C
C     DO 10 J=1, NBP1
C
C  10 G(IR,J) = 0.E0
C
C     MT=1
C
C     JT=N+1
C
C     CALL BNDACC(G,MDG,NB,IP,IR,MT,JT)
C
C***REFERENCES  C. L. LAWSON AND R. J. HANSON,
C                 SOLVING LEAST SQUARE PROBLEMS,PRENCTICE-HALL, INC
C                 (1974), CHAPTER 27
C
      DIMENSION G(MDG,*)
C
C
C              ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE.
C
      NBP1 = NB + 1
      IF (MT .LE. 0 .OR. NB .LE. 0) RETURN
C                                             ALG. STEP 5
      IF (JT .EQ. IP) GO TO 70
C                                             ALG. STEPS 6-7
      IF (JT .LE. IR) GO TO 30
C                                             ALG. STEPS 8-9
      DO 11 I = 1,MT
         IG1 = JT + MT - I
         IG2 = IR + MT - I
         DO 10 J = 1,NBP1
            G(IG1,J) = G(IG2,J)
   10    CONTINUE
   11 CONTINUE
C                                             ALG. STEP 10
      IE = JT - IR
      DO 21 I = 1,IE
         IG = IR + I - 1
         DO 20 J = 1,NBP1
           G(IG,J) = 0.0
   20    CONTINUE
   21 CONTINUE
C                                             ALG. STEP 11
      IR = JT
C                                             ALG. STEP 12
   30 MU = MIN0(NB - 1, IR - IP - 1)
      IF (MU .EQ. 0) GO TO 60
C                                             ALG. STEP 13
      DO 50 L = 1,MU
C                                             ALG. STEP 14
         K = MIN0(L, JT - IP)
C                                             ALG. STEP 15
         LP1 = L + 1
         IG = IP + L
         DO 40 I = LP1,NB
            JG = I - K
            G(IG,JG) = G(IG,I)
   40    CONTINUE
C                                             ALG. STEP 16
         DO 45 I = 1,K
            JG = NBP1 - I
            G(IG,JG) = 0.0
   45    CONTINUE
   50 CONTINUE
C                                             ALG. STEP 17
   60 IP = JT
C                                             ALG. STEPS 18-19
   70 MH = IR + MT - IP
      KH = MIN0(NBP1, MH)
C                                             ALG. STEP 20
      DO 80 I = 1,KH
         CALL H12 (1,I,MAX0(I+1,IR-IP+1),MH,G(IP,I),1,RHO,
     1             G(IP,I+1),1,MDG,NBP1-I)
   80 CONTINUE
C                                             ALG. STEP 21
      IR = IP + KH
C                                             ALG. STEP 22
      IF (KH .LT. NBP1) GO TO 100
C                                             ALG. STEP 23
      DO 90 I = 1,NB
         G(IR-1,I) = 0.0
   90 CONTINUE
C                                             ALG. STEP 24
  100 CONTINUE
C                                             ALG. STEP 25
      RETURN
      END
      SUBROUTINE BNDSL (MODE,G,MDG,NB,IP,IR,X,N,RNORM,IERR)
C
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C
C***PURPOSE  SOLVE THE LEAST SQUARES PROBLEM AX = B FOR BANDED
C            MATRICES A USING SEQUENTIAL ACCUMULATION OF ROWS OF
C            THE DATA MATRIX.  EXACTLY ONE RIGHT-HANDED SIDE VECTOR
C            IS PERMITTED.
C
C     THESE SUBROUTINES SOLVE THE LEAST SQUARES PROBLEM AX = B FOR
C     BANDED MATRICES A USING SEQUENTIAL ACCUMULATION OF ROWS OF THE
C     DATA MATRIX.  EXACTLY ONE RIGHT-HAND SIDE VECTOR IS PERMITTED.
C
C     THESE SUBROUTINES ARE INTENDED FOR THE TYPE OF LEAST SQUARES
C     SYSTEMS THAT ARISE IN APPLICATIONS SUCH AS CURVE OR SURFACE
C     FITTING OF DATA.  THE LEAST SQUARES EQUATIONS ARE ACCUMULATED AND
C     PROCESSED USING ONLY PART OF THE DATA.  THIS REQUIRES A CERTAIN
C     USER INTERACTION DURING THE SOLUTION OF AX = B.
C
C     SPECIFICALLY, SUPPOSE THE DATA MATRIX (A B) IS ROW PARTITIONED
C     INTO Q SUBMATRICES.  LET (E F) BE THE T-TH ONE OF THESE
C     SUBMATRICES WHERE E = (0 C 0).  HERE THE DIMENSION OF E IS MT BY N
C     AND THE DIMENSION OF C IS MT BY NB.  THE VALUE OF NB IS THE
C     BANDWIDTH OF A.  THE DIMENSIONS OF THE LEADING BLOCK OF ZEROS IN E
C     ARE MT BY JT-1.
C
C     THE USER OF THE SUBROUTINE BNDACC PROVIDES MT,JT,C AND F FOR
C     T=1,...,Q.  NOT ALL OF THIS DATA MUST BE SUPPLIED AT ONCE.
C
C     FOLLOWING THE PROCESSING OF THE VARIOUS BLOCKS (E F), THE MATRIX
C     (A B) HAS BEEN TRANSFORMED TO THE FORM (R D) WHERE R IS UPPER
C     TRIANGULAR AND BANDED WITH BANDWIDTH NB.  THE LEAST SQUARES
C     SYSTEM RX = D IS THEN EASILY SOLVED USING BACK SUBSTITUTION BY
C     EXECUTING THE STATEMENT CALL BNDSL(1,...). THE SEQUENCE OF
C     VALUES FOR JT MUST BE NONDECREASING.  THIS MAY REQUIRE SOME
C     PRELIMINARY INTERCHANGES OF ROWS AND COLUMNS OF THE MATRIX A.
C
C     THE PRIMARY REASON FOR THESE SUBROUTINES IS THAT THE TOTAL
C     PROCESSING CAN TAKE PLACE IN A WORKING ARRAY OF DIMENSION MU BY
C     NB+1.  AN ACCEPTABLE VALUE FOR MU IS
C
C                       MU = MAX(MT + N + 1),
C
C     WHERE N IS THE NUMBER OF UNKNOWNS.
C
C     HERE THE MAXIMUM IS TAKEN OVER ALL VALUES OF MT FOR T=1,...,Q.
C     NOTICE THAT MT CAN BE TAKEN TO BE A SMALL AS ONE, SHOWING THAT
C     MU CAN BE AS SMALL AS N+2.  THE SUBPROGRAM BNDACC PROCESSES THE
C     ROWS MORE EFFICIENTLY IF MU IS LARGE ENOUGH SO THAT EACH NEW
C     BLOCK (C F) HAS A DISTINCT VALUE OF JT.
C
C     THE FOUR PRINCIPLE PARTS OF THESE ALGORITHMS ARE OBTAINED BY THE
C     FOLLOWING CALL STATEMENTS
C
C     CALL BNDACC(...)  INTRODUCE NEW BLOCKS OF DATA.
C
C     CALL BNDSL(1,...)COMPUTE SOLUTION VECTOR AND LENGTH OF
C                       RESIDUAL VECTOR.
C
C     CALL BNDSL(2,...)GIVEN ANY ROW VECTOR H SOLVE YR = H FOR THE
C                       ROW VECTOR Y.
C
C     CALL BNDSL(3,...)GIVEN ANY COLUMN VECTOR W SOLVE RZ = W FOR
C                       THE COLUMN VECTOR Z.
C
C     THE DOTS IN THE ABOVE CALL STATEMENTS INDICATE ADDITIONAL
C     ARGUMENTS THAT WILL BE SPECIFIED IN THE FOLLOWING PARAGRAPHS.
C
C     THE USER MUST DIMENSION THE ARRAY APPEARING IN THE CALL LIST..
C     G(MDG,NB+1)
C
C     DESCRIPTION OF CALLING SEQUENCE FOR BNDSL..
C
C     THE USER MUST DIMENSION THE ARRAYS APPEARING IN THE CALL LIST..
C
C     G(MDG,NB+1), X(N)
C
C     THE ENTIRE SET OF PARAMETERS FOR BNDSL ARE
C
C     INPUT..
C
C     MODE              SET BY THE USER TO ONE OF THE VALUES 1, 2, OR
C                       3.  THESE VALUES RESPECTIVELY INDICATE THAT
C                       THE SOLUTION OF AX = B, YR = H OR RZ = W IS
C                       REQUIRED.
C
C     G(*,*),MDG,       THESE ARGUMENTS ALL HAVE THE SAME MEANING AND
C      NB,IP,IR         CONTENTS AS FOLLOWING THE LAST CALL TO BNDACC.
C
C     X(*)              WITH MODE=2 OR 3 THIS ARRAY CONTAINS,
C                       RESPECTIVELY, THE RIGHT-SIDE VECTORS H OR W OF
C                       THE SYSTEMS YR = H OR RZ = W.
C
C     N                 THE NUMBER OF VARIABLES IN THE SOLUTION
C                       VECTOR.  IF ANY OF THE N DIAGONAL TERMS ARE
C                       ZERO THE SUBROUTINE BNDSL PRINTS AN
C                       APPROPRIATE MESSAGE.  THIS CONDITION IS
C                       CONSIDERED AN ERROR.
C
C     OUTPUT..
C
C     X(*)              THIS ARRAY CONTAINS THE SOLUTION VECTORS X,
C                       Y OR Z OF THE SYSTEMS AX = B, YR = H OR
C                       RZ = W DEPENDING ON THE VALUE OF MODE=1,
C                       2 OR 3.
C
C     RNORM             IF MODE=1 RNORM IS THE EUCLIDEAN LENGTH OF THE
C                       RESIDUAL VECTOR AX-B.  WHEN MODE=2 OR 3 RNORM
C                       IS SET TO ZERO.
C
C     IERR              IERR = 0 IF THE SOLUTION WAS OBTAINED.
C                       IERR = 1 IF THE PROBLEM CANNOT BE SOLVED.
C
C
C***REFERENCES  C. L. LAWSON AND R. J. HANSON,
C                 SOLVING LEAST SQUARE PROBLEMS,PRENCTICE-HALL, INC
C                 (1974), CHAPTER 27
C
      DIMENSION G(MDG,*),X(N)
C
      IERR = 0
      RNORM = 0.0
      GO TO (10,90,50), MODE
C                                   ********************* MODE = 1
C                                   ALG. STEP 26
   10 DO 20 J = 1,N
         X(J) = G(J, NB+1)
   20 CONTINUE
      RSQ = 0.0
      NP1 = N + 1
      IRM1 = IR - 1
      IF (NP1 .GT. IRM1) GO TO 40
         DO 30 J = NP1,IRM1
            RSQ = RSQ + G(J, NB+1)**2
   30    CONTINUE
         RNORM = SQRT(RSQ)
   40 CONTINUE
C                                   ********************* MODE = 3
C                                   ALG. STEP 27
   50 DO 80 II = 1,N
         I = N + 1 - II
C                                   ALG. STEP 28
         S = 0.0
         L = MAX0(0, I - IP)
C                                   ALG. STEP 29
         IF (I .EQ. N) GO TO 70
C                                   ALG. STEP 30
            IE = MIN0(N + 1 - I, NB)
            DO 60 J = 2,IE
               JG = J + L
               IX = I - 1 + J
               S = S + G(I,JG)*X(IX)
   60       CONTINUE
C                                   ALG. STEP 31
   70    IF (G(I,L+1) .EQ. 0.0) GO TO 130
         X(I) = (X(I) - S)/G(I,L+1)
   80 CONTINUE
C                                   ALG. STEP 32
      RETURN
C                                   ********************* MODE = 2
   90 DO 120 J = 1,N
         S = 0.0
         IF (J .EQ. 1) GO TO 110
            I1 = MAX0(1, J - NB + 1)
            I2 = J - 1
            DO 100 I = I1,I2
               L = J - I + 1 + MAX0(0, I - IP)
               S = S + X(I)*G(I,L)
  100       CONTINUE
  110    L = MAX0(0, J - IP)
         IF (G(J,L+1) .EQ. 0.0) GO TO 130
         X(J) = (X(J) - S)/G(J,L+1)
  120 CONTINUE
      RETURN
C
C            A ZERO DIAGONAL TERM OCCURS
C
  130 IERR = 1
      RETURN
      END
      SUBROUTINE SPFIT2 (X, WX, MX, Y, WY, MY, Z, KZ, XBREAK, NX,
     *                   YBREAK, NY, F, S, T, WK, NUM, IERR)
C-----------------------------------------------------------------------
C
C            WEIGHTED LEAST SQUARES BICUBIC SPLINE FITTING
C
C                          -----------------
C
C     THE PIECEWISE POLYNOMIALS CONSIDERED ARE TENSOR PRODUCTS OF
C     B-SPLINES, HAVING THE FORM
C
C                          M    N
C              F(X,Y)  =  SUM  SUM  A   U (X) V (Y)
C                         I=1  J=1   IJ  I     J
C
C     WHERE M = NX + 2 AND N = NY + 2, AND U  AND V  ARE B-SPLINE
C     BASIS FUNCTIONS OF DEGREE 3. LET      I      J
C
C                       M
C              G (X) = SUM A   U (X)
C               J      I=1  IJ  I
C
C     FOR J = 1,...,N. THEN G (X),...,G (X) ARE CUBIC SPLINES AND
C                            1         N
C                        N
C              F(X,Y) = SUM G (X) V (Y) .
C                       J=1  J     J
C
C     THE ARRAYS S AND T DEFINED IN THE CODE ARE THE KNOT SEQUENCES
C     FOR THE B-SPLINES U (X) AND V (Y).
C                        I         J
C-----------------------------------------------------------------------
C     WRITTEN BY
C        ALFRED H. MORRIS, JR.
C        NAVAL SURFACE WARFARE CENTER
C        DAHLGREN, VIRGINIA
C-----------------------------------------------------------------------
      REAL X(MX), WX(MX), Y(MY), WY(MY), Z(KZ, MY)
      REAL XBREAK(NX), YBREAK(NY), F(*)
      REAL S(*), T(*), WK(NUM)
C---------------------
C     REAL F(4*NX*NY), S(NX + 6), T(NY + 6)
C---------------------
      IF (NX .LT. 2) GO TO 100
      IF (NY .LT. 2) GO TO 120
      M = NX + 2
      N = NY + 2
      L = MAX0(M*N, M*MY + 5*MAX0(M,N))
      IF (NUM .LT. L) GO TO 130
C
C     DEFINE THE KNOT SQUENCES
C
      S(1) = XBREAK(1)
      S(2) = XBREAK(1)
      S(3) = XBREAK(1)
      S(4) = XBREAK(1)
      DO 10 I = 2,NX
         IF (XBREAK(I - 1) .GE. XBREAK(I)) GO TO 100
         S(I + 3) = XBREAK(I)
   10 CONTINUE
      S(NX + 4) = XBREAK(NX)
      S(NX + 5) = XBREAK(NX)
      S(NX + 6) = XBREAK(NX)
C
      T(1) = YBREAK(1)
      T(2) = YBREAK(1)
      T(3) = YBREAK(1)
      T(4) = YBREAK(1)
      DO 20 J = 2,NY
         IF (YBREAK(J - 1) .GE. YBREAK(J)) GO TO 120
         T(J + 3) = YBREAK(J)
   20 CONTINUE
      T(NY + 4) = YBREAK(NY)
      T(NY + 5) = YBREAK(NY)
      T(NY + 6) = YBREAK(NY)
C
C     OBTAIN THE B-SPLINE COEFFICIENTS OF THE BIVARIATE
C     LEAST SQUARES FIT AND STORE THEM IN WK.
C
      CALL BSLSQ2 (X, WX, MX, Y, WY, MY, Z, KZ, S, M, 4,
     *             T, N, 4, F, M, WK, NUM, IERR)
      IF (IERR .LT. 0) GO TO 110
      IERR = 0
C
      L = M*N
      DO 30 I = 1,L
         WK(I) = F(I)
   30 CONTINUE
C
C     COMPUTE THE N CUBIC SPLINES G (X) AND THEIR FIRST
C                                  J
C     DERIVATIVES AT THE POINTS IN XBREAK. THEN STORE THE
C     DERIVATIVES IN WK. (THE VALUES OF THE SPLINES WILL
C     BE IN THE LATTER HALF OF F.)
C
      NU = NX*NY
      L = 2*NU + 1
      CALL CSPP (S, WK, M, M, N, F(L), N, F(1), N)
C
      IMAX = N*NX
      DO 40 I = 1,IMAX
         WK(I) = F(I)
   40 CONTINUE
C
C     COMPUTE THE VALUES OF THE BISPLINE AND THEIR PARTIAL
C     DERIVATIVES WITH RESPECT TO Y. THE RESULTS ARE STORED
C     IN THE FIRST HALF OF F.
C
      LD = NU + 1
      CALL CSPP (T, F(L), N, N, NX, F(1), NX, F(LD), NX)
C
C     COMPUTE THE REMAINING PARTIAL DERIVATIVES AND STORE
C     THE RESULTS IN THE LATTER HALF OF F.
C
      LD = L + NU
      CALL CSPP (T, WK, N, N, NX, F(L), NX, F(LD), NX)
      RETURN
C
C     ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      IF (IERR .EQ. -2) IERR = 4
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 5
      WK(1) = L
      RETURN
      END
      SUBROUTINE CSPP (T, A, KA, M, N, Z, KZ, DZ, KDZ)
C-----------------------------------------------------------------------
C
C            COMPUTATION OF N CUBIC SPLINES AND THEIR FIRST
C            DERIVATIVES AT THE KNOTS T(4),...,T(M+1). THE
C            CUBIC SPLINES ARE REPRESENTED IN B-SPLINE FORM.
C
C                          ---------------
C
C     INPUT ...
C
C       T     KNOT SEQUENCE OF LENGTH M+4.
C       A     M X N MATRIX. EACH COLUMN OF A IS A SEQUENCE
C             OF M B-SPLINE COEFFICIENTS FOR A CUBIC SPLINE.
C       KA    THE NUMBER OF ROWS SPECIFIED IN THE CALLING
C             PROGRAM FOR A. IT IS ASSUMED THAT KA .GE. M.
C       M     DIMENSION OF THE B-SPLINE SPACE.
C       N     NUMBER OF CUBIC SPLINES CONSIDERED.
C       KZ    THE NUMBER OF ROWS SPECIFIED IN THE CALLING
C             PROGRAM FOR Z. IT IS ASSUMED THAT KZ .GE. N.
C       KDZ   THE NUMBER OF ROWS SPECIFIED IN THE CALLING
C             PROGRAM FOR DZ. IT IS ASSUMED THAT KZ .GE. N.
C
C     OUTPUT ...
C
C       Z     N X (M-2) MATRIX WHERE Z(J,I) = VALUE OF J-TH CUBIC
C             SPLINE AT THE POINT T(I+3) FOR I = 1,...,M-2.
C
C       DZ    N X (M-2) MATRIX WHERE DZ(J,I) = FIRST DERIVATIVE OF
C             THE J-TH CUBIC SPLINE EVALUATED AT THE POINT T(I+3).
C
C-----------------------------------------------------------------------
      REAL T(*), A(KA,N), Z(KZ,*), DZ(KDZ,*)
      REAL C(4), WK(4,5)
C
      K = 4
      MP1 = M + 1
      DO 70 MU = 1,N
C
C        OBTAING THE VALUES FOR THE MU-TH CUBIC SPLINE
C
         L = 0
         DO 60 LEFT = K,M
            L = L + 1
C
C           COMPUTE THE COEFFICIENTS FOR THE L-TH
C           POLYNOMIAL FORMING THE CUBIC SPLINE. THE
C           COEFFICIENTS ARE STORED IN C. THIS CODE
C           IS FROM THE SUBROUTINE BSPP.
C
            DO 10 J = 1,K
               JJ = LEFT - K + J
               WK(J,1) = A(JJ,MU)
   10       CONTINUE
C
            DO 21 J = 1,3
               JP1 = J + 1
               KMJ = K - J
               DO 20 I = 1,KMJ
                  IL = I + LEFT
                  ILKJ = IL - KMJ
                  DIFF = T(IL) - T(ILKJ)
                  WK(I,JP1) = (WK(I+1,J) - WK(I,J))/DIFF
   20          CONTINUE
   21       CONTINUE
C
            WK(1,5) = 1.0
            X = T(LEFT)
            C(4) = WK(1,4)
            R = 1.0
            DO 50 J = 1,3
               JP1 = J + 1
               S = 0.0
               DO 30 I = 1,J
                  IL = I + LEFT
                  ILJ = IL - J
                  TERM = WK(I,5)/(T(IL) - T(ILJ))
                  WK(I,5) = S + (T(IL) - X)*TERM
                  S = (X - T(ILJ))*TERM
   30          CONTINUE
               WK(JP1,5) = S
C
               S = 0.0
               KMJ = K - J
               DO 40 I = 1,JP1
                  S = S + WK(I,KMJ)*WK(I,5)
   40          CONTINUE
               R = (R*FLOAT(KMJ))/FLOAT(J)
               C(KMJ) = R*S
   50       CONTINUE
C
C           STORE THE VALUE OF THE SPLINE AND ITS
C           FIRST DERIVATIVE AT THE KNOT T(LEFT)
C
            Z(MU,L) = C(1)
            DZ(MU,L) = C(2)
   60    CONTINUE
C
C        COMPUTE THE SPLINE AND ITS FIRST DERIVATIVE
C                    AT THE KNOT T(M+1)
C
         L = L + 1
         DEL = T(MP1) - T(M)
         Z(MU,L) = ((C(4)*DEL + C(3))*DEL + C(2))*DEL + C(1)
         DZ(MU,L) = (3.0*C(4)*DEL + 2.0*C(3))*DEL + C(2)
   70 CONTINUE
      RETURN
      END
      SUBROUTINE CSURF (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N,
     *                  F, KF, F1, KF1, F2, KF2, F12, KF12)
C-----------------------------------------------------------------------
C
C             EVALUATION OR DIFFERENTIATION OF A BICUBIC
C                        SPLINE OVER A GRID
C
C-----------------------------------------------------------------------
      REAL X(MX), Y(MY), Z(KZ,MY)
      REAL S(M), T(N), F(KF,N), F1(KF1,N), F2(KF2,N), F12(KF12,N)
C
      IF (IDER .GT. 3 .OR. JDER .GT. 3) GO TO 400
      MM1 = M - 1
      NM1 = N - 1
C
      IOLD = 0
      JOLD = 0
      DO 360 L = 1,MY
         YY = Y(L)
         IF (YY .LT. T(2)) GO TO 10
         IF (YY .GE. T(NM1)) GO TO 20
         IF (L .EQ. 1) GO TO 30
         IF (YY - Y(L-1)) 30,50,40
C
   10    J = 1
         GO TO 50
   20    J = NM1
         GO TO 50
   30    J = INTRVL (YY, T, N)
         GO TO 50
C
C        LINEAR FORWARD SEARCH
C
   40    IF (YY .LT. T(J + 1)) GO TO 50
         J = J + 1
         GO TO 40
C
   50    JP1 = J + 1
         DT = T(JP1) - T(J)
C
         DO 350 K = 1,MX
            XX = X(K)
            IF (XX .LT. S(2)) GO TO 100
            IF (XX .GE. S(MM1)) GO TO 110
            IF (K .EQ. 1) GO TO 120
            IF (XX - X(K-1)) 120,130,140
C
  100       I = 1
            IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210
            GO TO 200
  110       I = MM1
            IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210
            GO TO 200
  120       I = INTRVL (XX, S, M)
            IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210
            GO TO 200
  130       Z(K,L) = Z(K-1,L)
            GO TO 350
C
C           LINEAR FORWARD SEARCH
C
  140       IF (XX .LT. S(I + 1)) GO TO 210
  150          I = I + 1
               IF (XX .GE. S(I + 1)) GO TO 150
C
C           COMPUTATION OF THE JDER-TH DERIVATIVE OF
C           F(S(I),Y), D1F(S(I),Y), F(S(I+1),Y), AND
C           D1F(S(I+1),Y) AT THE POINT YY.
C
  200          IOLD = I
               IP1 = I + 1
               DS = S(IP1) - S(I)
C
               D = (F(I,JP1) - F(I,J))/DT
               A = F2(I,J) + F2(I,JP1)
               B = (-A - F2(I,J) + 3.0*D)/DT
               C = (A - D - D)/(DT*DT)
C
               D = (F(IP1,JP1) - F(IP1,J))/DT
               A = F2(IP1,J) + F2(IP1,JP1)
               B1 = (-A - F2(IP1,J) + 3.0*D)/DT
               C1 = (A - D - D)/(DT*DT)
C
               D = (F1(I,JP1) - F1(I,J))/DT
               A = F12(I,J) + F12(I,JP1)
               B2 = (-A - F12(I,J) + 3.0*D)/DT
               C2 = (A - D - D)/(DT*DT)
C
               D = (F1(IP1,JP1) - F1(IP1,J))/DT
               A = F12(IP1,J) + F12(IP1,JP1)
               B3 = (-A - F12(IP1,J) + 3.0*D)/DT
               C3 = (A - D - D)/(DT*DT)
C
  210       DY = YY - T(J)
            IF (JDER .EQ. 0) GO TO 220
            IF (JDER - 2) 230,240,250
C
  220       FI = ((C*DY + B)*DY + F2(I,J))*DY + F(I,J)
            FIP1 = ((C1*DY + B1)*DY + F2(IP1,J))*DY + F(IP1,J)
            DFI = ((C2*DY + B2)*DY + F12(I,J))*DY + F1(I,J)
            DFIP1 = ((C3*DY + B3)*DY + F12(IP1,J))*DY + F1(IP1,J)
            GO TO 300
C
  230       FI = (3.0*C*DY + 2.0*B)*DY + F2(I,J)
            FIP1 = (3.0*C1*DY + 2.0*B1)*DY + F2(IP1,J)
            DFI = (3.0*C2*DY + 2.0*B2)*DY + F12(I,J)
            DFIP1 = (3.0*C3*DY + 2.0*B3)*DY + F12(IP1,J)
            GO TO 300
C
  240       FI = 6.0*C*DY + 2.0*B
            FIP1 = 6.0*C1*DY + 2.0*B1
            DFI = 6.0*C2*DY + 2.0*B2
            DFIP1 = 6.0*C3*DY + 2.0*B3
            GO TO 300
C
  250       FI = 6.0*C
            FIP1 = 6.0*C1
            DFI = 6.0*C2
            DFIP1 = 6.0*C3
C
C           COMPUTATION OF THE IDER-TH DERIVATIVE
C           AT THE POINT XX.
C
  300       D = (FIP1 - FI)/DS
            A = DFI + DFIP1
            BX = (-A - DFI + 3.0*D)/DS
            CX = (A - D - D)/(DS*DS)
C
            DX = XX - S(I)
            IF (IDER .EQ. 0) GO TO 310
            IF (IDER - 2) 320,330,340
C
  310       Z(K,L) = ((CX*DX + BX)*DX + DFI)*DX + FI
            GO TO 350
  320       Z(K,L) = (3.0*CX*DX + 2.0*BX)*DX + DFI
            GO TO 350
  330       Z(K,L) = 6.0*CX*DX + 2.0*BX
            GO TO 350
  340       Z(K,L) = 6.0*CX
C
  350    CONTINUE
         JOLD = J
  360 CONTINUE
      RETURN
C
C     CASE WHEN THE RESULTS ARE ZERO.
C
  400 DO 420 L = 1,MY
         DO 410 K = 1,MX
            Z(K,L) = 0.0
  410    CONTINUE
  420 CONTINUE
      RETURN
      END
      SUBROUTINE CSURF1 (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N, F)
C-----------------------------------------------------------------------
C
C             EVALUATION OR DIFFERENTIATION OF A BICUBIC
C                        SPLINE OVER A GRID
C
C-----------------------------------------------------------------------
      REAL X(MX), Y(MY), Z(KZ,MY)
      REAL S(M), T(N), F(M,N,4)
C
      CALL CSURF (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N, F, M,
     *            F(1,1,3), M, F(1,1,2), M, F(1,1,4), M)
      RETURN
      END
      SUBROUTINE CSRF (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N,
     *                 F, KF, F1, KF1, F2, KF2, F12, KF12)
C-----------------------------------------------------------------------
C
C             EVALUATION OR DIFFERENTIATION OF A BICUBIC
C                        SPLINE OVER A GRID
C
C-----------------------------------------------------------------------
      REAL X(MX), Y(MY), Z(KZ,MY)
      REAL S(M), T(N), F(KF,N), F1(KF1,N), F2(KF2,N), F12(KF12,N)
C
      IF (IDER .GT. 3 .OR. JDER .GT. 3) GO TO 400
      MM1 = M - 1
      NM1 = N - 1
C
      IOLD = 0
      JOLD = 0
      DO 360 L = 1,MY
         YY = Y(L)
         IF (YY .LT. T(2)) GO TO 10
         IF (YY .GE. T(NM1)) GO TO 20
         IF (L .EQ. 1) GO TO 30
         IF (YY - Y(L-1)) 30,50,40
C
   10    J = 1
         GO TO 50
   20    J = NM1
         GO TO 50
   30    J = INTRVL (YY, T, N)
         GO TO 50
C
C        LINEAR FORWARD SEARCH
C
   40    IF (YY .LT. T(J + 1)) GO TO 50
         J = J + 1
         GO TO 40
C
   50    JP1 = J + 1
         DT = T(JP1) - T(J)
C
         DO 350 K = 1,MX
            XX = X(K)
            IF (XX .LT. S(2)) GO TO 100
            IF (XX .GE. S(MM1)) GO TO 110
            IF (K .EQ. 1) GO TO 120
            IF (XX - X(K-1)) 120,130,140
C
  100       I = 1
            IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210
            GO TO 200
  110       I = MM1
            IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210
            GO TO 200
  120       I = INTRVL (XX, S, M)
            IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210
            GO TO 200
  130       Z(K,L) = Z(K-1,L)
            GO TO 350
C
C           LINEAR FORWARD SEARCH
C
  140       IF (XX .LT. S(I + 1)) GO TO 210
  150          I = I + 1
               IF (XX .GE. S(I + 1)) GO TO 150
C
C           COMPUTATION OF THE JDER-TH DERIVATIVE OF
C           F(S(I),Y), D1F(S(I),Y), F(S(I+1),Y), AND
C           D1F(S(I+1),Y) AT THE POINT YY.
C
  200          IOLD = I
               IP1 = I + 1
               DS = S(IP1) - S(I)
C
               D = (F(I,JP1) - F(I,J))/DT
               A = D - DT*(2.0*F2(I,J) + F2(I,JP1))/6.0
               C = (F2(I,JP1) - F2(I,J))/(6.0*DT)
C
               D = (F(IP1,JP1) - F(IP1,J))/DT
               A1 = D - DT*(2.0*F2(IP1,J) + F2(IP1,JP1))/6.0
               C1 = (F2(IP1,JP1) - F2(IP1,J))/(6.0*DT)
C
               D = (F1(I,JP1) - F1(I,J))/DT
               A2 = D - DT*(2.0*F12(I,J) + F12(I,JP1))/6.0
               C2 = (F12(I,JP1) - F12(I,J))/(6.0*DT)
C
               D = (F1(IP1,JP1) - F1(IP1,J))/DT
               A3 = D - DT*(2.0*F12(IP1,J) + F12(IP1,JP1))/6.0
               C3 = (F12(IP1,JP1) - F12(IP1,J))/(6.0*DT)
C
  210       DY = YY - T(J)
            IF (JDER .EQ. 0) GO TO 220
            IF (JDER - 2) 230,240,250
C
  220       FI = ((C*DY + 0.5*F2(I,J))*DY + A)*DY + F(I,J)
            FIP1 = ((C1*DY + 0.5*F2(IP1,J))*DY + A1)*DY + F(IP1,J)
            DFI = ((C2*DY + 0.5*F12(I,J))*DY + A2)*DY + F1(I,J)
            DFIP1 = ((C3*DY + 0.5*F12(IP1,J))*DY + A3)*DY + F1(IP1,J)
            GO TO 300
C
  230       FI = (3.0*C*DY + F2(I,J))*DY + A
            FIP1 = (3.0*C1*DY + F2(IP1,J))*DY + A1
            DFI = (3.0*C2*DY + F12(I,J))*DY + A2
            DFIP1 = (3.0*C3*DY + F12(IP1,J))*DY + A3
            GO TO 300
C
  240       FI = 6.0*C*DY + F2(I,J)
            FIP1 = 6.0*C1*DY + F2(IP1,J)
            DFI = 6.0*C2*DY + F12(I,J)
            DFIP1 = 6.0*C3*DY + F12(IP1,J)
            GO TO 300
C
  250       FI = 6.0*C
            FIP1 = 6.0*C1
            DFI = 6.0*C2
            DFIP1 = 6.0*C3
C
C           COMPUTATION OF THE IDER-TH DERIVATIVE
C           AT THE POINT XX.
C
  300       D = (FIP1 - FI)/DS
            AX = D - DS*(2.0*DFI + DFIP1)/6.0
            CX = (DFIP1 - DFI)/(6.0*DS)
C
            DX = XX - S(I)
            IF (IDER .EQ. 0) GO TO 310
            IF (IDER - 2) 320,330,340
C
  310       Z(K,L) = ((CX*DX + 0.5*DFI)*DX + AX)*DX + FI
            GO TO 350
  320       Z(K,L) = (3.0*CX*DX + DFI)*DX + AX
            GO TO 350
  330       Z(K,L) = 6.0*CX*DX + DFI
            GO TO 350
  340       Z(K,L) = 6.0*CX
C
  350    CONTINUE
         JOLD = J
  360 CONTINUE
      RETURN
C
C     CASE WHEN THE RESULTS ARE ZERO.
C
  400 DO 420 L = 1,MY
         DO 410 K = 1,MX
            Z(K,L) = 0.0
  410    CONTINUE
  420 CONTINUE
      RETURN
      END
      SUBROUTINE CSRF2 (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N,
     *                  F, KF, DDF)
C-----------------------------------------------------------------------
C
C             EVALUATION OR DIFFERENTIATION OF A BICUBIC
C                        SPLINE OVER A GRID
C
C-----------------------------------------------------------------------
      REAL X(MX), Y(MY), Z(KZ,MY)
      REAL S(M), T(N), F(KF,N), DDF(M,N,3)
C
      CALL CSRF (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N, F, KF,
     *           DDF(1,1,2), M, DDF, M, DDF(1,1,3), M)
      RETURN
      END
      SUBROUTINE SURF (M,N,X,Y,Z,IZ,OPT,ZP,TEMP,SIGMA,IERR)
C
      INTEGER M,N,IZ,IERR
      REAL X(M),Y(N),Z(IZ,N),OPT(*),ZP(M,N,*),TEMP(*),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C                               MODIFIED BY ALFRED H. MORRIS
C                               NAVAL SURFACE WEAPONS CENTER
C                                          DAHLGREN VIRGINIA
C
C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO
C COMPUTE AN INTERPOLATORY SURFACE PASSING THROUGH A RECT-
C ANGULAR GRID OF FUNCTIONAL VALUES. THE SURFACE DETERMINED
C CAN BE REPRESENTED AS THE TENSOR PRODUCT OF SPLINES UNDER
C TENSION. THE X- AND Y-PARTIAL DERIVATIVES AROUND THE
C BOUNDARY AND THE X-Y-PARTIAL DERIVATIVES AT THE FOUR
C CORNERS MAY BE SPECIFIED OR OMITTED. FOR ACTUAL MAPPING
C OF POINTS ONTO THE SURFACE IT IS NECESSARY TO CALL THE
C FUNCTION SURF2.
C
C ON INPUT--
C
C   M IS THE NUMBER OF GRID LINES IN THE X-DIRECTION, I. E.
C   LINES PARALLEL TO THE Y-AXIS (M .GE. 2).
C
C   N IS THE NUMBER OF GRID LINES IN THE Y-DIRECTION, I. E.
C   LINES PARALLEL TO THE X-AXIS (N .GE. 2).
C
C   X IS AN ARRAY OF THE M X-COORDINATES OF THE GRID LINES
C   IN THE X-DIRECTION. THESE SHOULD BE STRICTLY INCREASING.
C
C   Y IS AN ARRAY OF THE N Y-COORDINATES OF THE GRID LINES
C   IN THE Y-DIRECTION. THESE SHOULD BE STRICTLY INCREASING.
C
C   Z IS AN ARRAY OF THE M * N FUNCTIONAL VALUES AT THE GRID
C   POINTS, I. E. Z(I,J) CONTAINS THE FUNCTIONAL VALUE AT
C   (X(I),Y(J)) FOR I = 1,...,M AND J = 1,...,N.
C
C   IZ IS THE ROW DIMENSION OF THE MATRIX Z USED IN THE
C   CALLING PROGRAM (IZ .GE. M).
C
C   OPT IS AN OPTION VECTOR. IF NO BOUNDARY CONDITIONS ARE
C   TO BE IMPOSED ON THE SURFACE THEN LET OPT BE OF LENGTH 1
C   AND SET OPT(1)=0. OTHERWISE, SEE THE DESCRIPTION OF SURF
C   IN THE NSWC LIBRARY MANUAL.
C
C   ZP IS AN ARRAY OF AT LEAST 3*M*N LOCATIONS.
C
C   TEMP IS AN ARRAY OF AT LEAST N+N+M LOCATIONS WHICH IS
C   USED FOR SCRATCH STORAGE.
C
C   SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES
C   THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO
C   (E. G. .001) THE RESULTING SURFACE IS APPROXIMATELY THE
C   TENSOR PRODUCT OF CUBIC SPLINES. IF ABS(SIGMA) IS LARGE
C   (E. G. 50.) THE RESULTING SURFACE IS APPROXIMATELY
C   BI-LINEAR. IF SIGMA EQUALS ZERO TENSOR PRODUCTS OF
C   CUBIC SPLINES RESULT. A STANDARD VALUE FOR SIGMA IS
C   APPROXIMATELY 1. IN ABSOLUTE VALUE.
C
C ON OUTPUT--
C
C   ZP CONTAINS THE VALUES OF THE XX-, YY-, AND XXYY-PARTIAL
C   DERIVATIVES OF THE SURFACE AT THE GIVEN NODES.
C
C   IERR CONTAINS AN ERROR FLAG,
C        = 0 FOR NORMAL RETURN,
C        = 1 IF N IS LESS THAN 2 OR M IS LESS THAN 2,
C        = 2 IF THE X-VALUES OR Y-VALUES ARE NOT STRICTLY
C            INCREASING,
C        = 3 THE OPTION VECTOR HAS AN ERROR.
C
C THIS SUBROUTINE REFERENCES PACKAGE MODULES CEEZ, TERMS,
C AND SNHCSH.
C
C-----------------------------------------------------------
C
      INTEGER IND(8),LOC(8),NUM(8)
      DATA NUM(5)/1/, NUM(6)/1/, NUM(7)/1/, NUM(8)/1/
C
      MM1 = M-1
      MP1 = M+1
      NM1 = N-1
      NP1 = N+1
      NPM = N+M
      IERR = 0
      IF (N .LE. 1 .OR. M .LE. 1) GO TO 46
      IF (Y(N) .LE. Y(1)) GO TO 47
C
C PROCESS THE OPTION VECTOR
C
      NUM(1) = N
      NUM(2) = N
      NUM(3) = M
      NUM(4) = M
      IND(1) = 0
      IND(2) = 0
      IND(3) = 0
      IND(4) = 0
      IND(5) = 0
      IND(6) = 0
      IND(7) = 0
      IND(8) = 0
C
      L = 1
  100 KEY = OPT(L)
      IF (KEY) 48,110,101
  101 IF (KEY .GT. 8) GO TO 48
      IND(KEY) = 1
      L = L+1
      LOC(KEY) = L
      L = L + NUM(KEY)
      GO TO 100
C
C DENORMALIZE TENSION FACTOR IN Y-DIRECTION
C
  110 SIGMAY = ABS(SIGMA)*FLOAT(N-1)/(Y(N)-Y(1))
C
C OBTAIN Y-PARTIAL DERIVATIVES ALONG Y = Y(1)
C
      IF (IND(3) .EQ. 0) GO TO 2
      L = LOC(3)
      DO 1 I = 1,M
        ZP(I,1,1) = OPT(L)
    1   L = L+1
      GO TO 5
    2 DELY1 = Y(2)-Y(1)
      DELY2 = DELY1+DELY1
      IF (N .GT. 2) DELY2 = Y(3)-Y(1)
      IF (DELY1 .LE. 0. .OR. DELY2 .LE. DELY1) GO TO 47
      CALL CEEZ (DELY1,DELY2,SIGMAY,C1,C2,C3,N)
      DO 3 I = 1,M
    3   ZP(I,1,1) = C1*Z(I,1)+C2*Z(I,2)
      IF (N .EQ. 2) GO TO 5
      DO 4 I = 1,M
    4   ZP(I,1,1) = ZP(I,1,1)+C3*Z(I,3)
C
C OBTAIN Y-PARTIAL DERIVATIVES ALONG Y = Y(N)
C
    5 IF (IND(4) .EQ. 0) GO TO 7
      L = LOC(4)
      DO 6 I = 1,M
        NPI = N+I
        TEMP(NPI) = OPT(L)
    6   L = L+1
      GO TO 10
    7 DELYN = Y(N)-Y(NM1)
      DELYNM = DELYN+DELYN
      IF (N .GT. 2) DELYNM = Y(N)-Y(N-2)
      IF (DELYN .LE. 0. .OR. DELYNM .LE. DELYN) GO TO 47
      CALL CEEZ (-DELYN,-DELYNM,SIGMAY,C1,C2,C3,N)
      DO 8 I = 1,M
        NPI = N+I
    8   TEMP(NPI) = C1*Z(I,N)+C2*Z(I,NM1)
      IF (N .EQ. 2) GO TO 10
      DO 9 I = 1,M
        NPI = N+I
    9   TEMP(NPI) = TEMP(NPI)+C3*Z(I,N-2)
   10 IF (X(M) .LE. X(1)) GO TO 47
C
C DENORMALIZE TENSION FACTOR IN X-DIRECTION
C
      SIGMAX = ABS(SIGMA)*FLOAT(M-1)/(X(M)-X(1))
C
C OBTAIN X-PARTIAL DERIVATIVES ALONG X = X(1)
C
      IF (IND(1) .EQ. 0) GO TO 12
      L = LOC(1)
      DO 11 J = 1,N
        ZP(1,J,2) = OPT(L)
   11   L = L+1
      IF (IND(5)+IND(7) .EQ. 2) GO TO 15
   12 DELX1 = X(2)-X(1)
      DELX2 = DELX1+DELX1
      IF (M .GT. 2) DELX2 = X(3)-X(1)
      IF (DELX1 .LE. 0. .OR. DELX2 .LE. DELX1) GO TO 47
      CALL CEEZ (DELX1,DELX2,SIGMAX,C1,C2,C3,M)
      IF (IND(1) .EQ. 1) GO TO 15
      DO 13 J = 1,N
   13   ZP(1,J,2) = C1*Z(1,J)+C2*Z(2,J)
      IF (M .EQ. 2) GO TO 15
      DO 14 J = 1,N
   14   ZP(1,J,2) = ZP(1,J,2)+C3*Z(3,J)
C
C OBTAIN X-Y-PARTIAL DERIVATIVE AT (X(1),Y(1))
C
   15 IF (IND(5) .EQ. 0) GO TO 16
      L = LOC(5)
      ZP(1,1,3) = OPT(L)
      GO TO 17
   16 ZP(1,1,3) = C1*ZP(1,1,1)+C2*ZP(2,1,1)
      IF (M .GT. 2) ZP(1,1,3) = ZP(1,1,3)+C3*ZP(3,1,1)
C
C OBTAIN X-Y-PARTIAL DERIVATIVE AT (X(1),Y(N))
C
   17 IF (IND(7) .EQ. 0) GO TO 18
      L = LOC(7)
      ZXY1NS = OPT(L)
      GO TO 19
   18 ZXY1NS = C1*TEMP(N+1)+C2*TEMP(N+2)
      IF (M .GT. 2) ZXY1NS = ZXY1NS+C3*TEMP(N+3)
C
C OBTAIN X-PARTIAL DERIVATIVE ALONG X = X(M)
C
   19 IF (IND(2) .EQ. 0) GO TO 21
      L = LOC(2)
      DO 20 J = 1,N
        NPMPJ = NPM+J
        TEMP(NPMPJ) = OPT(L)
   20   L = L+1
   21 IF (IND(6)+IND(8) .EQ. 2) GO TO 24
      DELXM = X(M)-X(MM1)
      DELXMM = DELXM+DELXM
      IF (M .GT. 2) DELXMM = X(M)-X(M-2)
      IF (DELXM .LE. 0. .OR. DELXMM .LE. DELXM) GO TO 47
      CALL CEEZ (-DELXM,-DELXMM,SIGMAX,C1,C2,C3,M)
      IF (IND(2) .EQ. 1) GO TO 24
      DO 22 J = 1,N
        NPMPJ = NPM+J
   22   TEMP(NPMPJ) = C1*Z(M,J)+C2*Z(MM1,J)
      IF (M .EQ. 2) GO TO 24
      DO 23 J = 1,N
        NPMPJ = NPM+J
   23   TEMP(NPMPJ) = TEMP(NPMPJ)+C3*Z(M-2,J)
C
C OBTAIN X-Y-PARTIAL DERIVATIVE AT (X(M),Y(1))
C
   24 IF (IND(6) .EQ. 0) GO TO 25
      L = LOC(6)
      ZP(M,1,3) = OPT(L)
      GO TO 26
   25 ZP(M,1,3) = C1*ZP(M,1,1)+C2*ZP(MM1,1,1)
      IF (M .GT. 2) ZP(M,1,3) = ZP(M,1,3)+C3*ZP(M-2,1,1)
C
C OBTAIN X-Y-PARTIAL DERIVATIVE AT (X(M),Y(N))
C
   26 IF (IND(8) .EQ. 0) GO TO 27
      L = LOC(8)
      ZXYMNS = OPT(L)
      GO TO 28
   27 ZXYMNS = C1*TEMP(NPM)+C2*TEMP(NPM-1)
      IF (M .GT. 2) ZXYMNS = ZXYMNS+C3*TEMP(NPM-2)
C
C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR Y-GRID
C PERFORM FORWARD ELIMINATION
C
   28 DEL1 = Y(2)-Y(1)
      IF (DEL1 .LE. 0.) GO TO 47
      DELI = 1./DEL1
      DO 29 I = 1,M
   29   ZP(I,2,1) = DELI*(Z(I,2)-Z(I,1))
      ZP(1,2,3) = DELI*(ZP(1,2,2)-ZP(1,1,2))
      ZP(M,2,3) = DELI*(TEMP(NPM+2)-TEMP(NPM+1))
      CALL TERMS (DIAG1,SDIAG1,SIGMAY,DEL1)
      DIAGI = 1./DIAG1
      DO 30 I = 1,M
   30   ZP(I,1,1) = DIAGI*(ZP(I,2,1)-ZP(I,1,1))
      ZP(1,1,3) = DIAGI*(ZP(1,2,3)-ZP(1,1,3))
      ZP(M,1,3) = DIAGI*(ZP(M,2,3)-ZP(M,1,3))
      TEMP(1) = DIAGI*SDIAG1
      IF (N .EQ. 2) GO TO 34
      DO 33 J = 2,NM1
        JM1 = J-1
        JP1 = J+1
        NPMPJ = NPM+J
        DEL2 = Y(JP1)-Y(J)
        IF (DEL2 .LE. 0.) GO TO 47
        DELI = 1./DEL2
        DO 31 I = 1,M
   31     ZP(I,JP1,1) = DELI*(Z(I,JP1)-Z(I,J))
        ZP(1,JP1,3) = DELI*(ZP(1,JP1,2)-ZP(1,J,2))
        ZP(M,JP1,3) = DELI*(TEMP(NPMPJ+1)-TEMP(NPMPJ))
        CALL TERMS (DIAG2,SDIAG2,SIGMAY,DEL2)
        DIAGIN = 1./(DIAG1+DIAG2-SDIAG1*TEMP(JM1))
        DO 32 I = 1,M
   32     ZP(I,J,1) = DIAGIN*(ZP(I,JP1,1)-ZP(I,J,1)-
     *                        SDIAG1*ZP(I,JM1,1))
        ZP(1,J,3) = DIAGIN*(ZP(1,JP1,3)-ZP(1,J,3)-
     *                      SDIAG1*ZP(1,JM1,3))
        ZP(M,J,3) = DIAGIN*(ZP(M,JP1,3)-ZP(M,J,3)-
     *                      SDIAG1*ZP(M,JM1,3))
        TEMP(J) = DIAGIN*SDIAG2
        DIAG1 = DIAG2
   33   SDIAG1 = SDIAG2
   34 DIAGIN = 1./(DIAG1-SDIAG1*TEMP(NM1))
      DO 35 I = 1,M
        NPI = N+I
   35   ZP(I,N,1) = DIAGIN*(TEMP(NPI)-ZP(I,N,1)-
     *                      SDIAG1*ZP(I,NM1,1))
      ZP(1,N,3) = DIAGIN*(ZXY1NS-ZP(1,N,3)-
     *                    SDIAG1*ZP(1,NM1,3))
      TEMP(N) = DIAGIN*(ZXYMNS-ZP(M,N,3)-
     *                  SDIAG1*ZP(M,NM1,3))
C
C PERFORM BACK SUBSTITUTION
C
      DO 37 J = 2,N
        JBAK = NP1-J
        JBAKP1 = JBAK+1
        T = TEMP(JBAK)
        DO 36 I = 1,M
   36     ZP(I,JBAK,1) = ZP(I,JBAK,1)-T*ZP(I,JBAKP1,1)
        ZP(1,JBAK,3) = ZP(1,JBAK,3)-T*ZP(1,JBAKP1,3)
   37   TEMP(JBAK) = ZP(M,JBAK,3)-T*TEMP(JBAKP1)
C
C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR X-GRID
C PERFORM FORWARD ELIMINATION
C
      DEL1 = X(2)-X(1)
      IF (DEL1 .LE. 0.) GO TO 47
      DELI = 1./DEL1
      DO 38 J = 1,N
        ZP(2,J,2) = DELI*(Z(2,J)-Z(1,J))
   38   ZP(2,J,3) = DELI*(ZP(2,J,1)-ZP(1,J,1))
      CALL TERMS (DIAG1,SDIAG1,SIGMAX,DEL1)
      DIAGI = 1./DIAG1
      DO 39 J = 1,N
        ZP(1,J,2) = DIAGI*(ZP(2,J,2)-ZP(1,J,2))
   39   ZP(1,J,3) = DIAGI*(ZP(2,J,3)-ZP(1,J,3))
      TEMP(N+1) = DIAGI*SDIAG1
      IF (M  .EQ. 2) GO TO 43
      DO 42 I = 2,MM1
        IM1 = I-1
        IP1 = I+1
        NPI = N+I
        DEL2 = X(IP1)-X(I)
        IF (DEL2 .LE. 0.) GO TO 47
        DELI = 1./DEL2
        DO 40 J = 1,N
          ZP(IP1,J,2) = DELI*(Z(IP1,J)-Z(I,J))
   40     ZP(IP1,J,3) = DELI*(ZP(IP1,J,1)-ZP(I,J,1))
        CALL TERMS (DIAG2,SDIAG2,SIGMAX,DEL2)
        DIAGIN = 1./(DIAG1+DIAG2-SDIAG1*TEMP(NPI-1))
        DO 41 J = 1,N
          ZP(I,J,2) = DIAGIN*(ZP(IP1,J,2)-ZP(I,J,2)-
     *                        SDIAG1*ZP(IM1,J,2))
   41     ZP(I,J,3) = DIAGIN*(ZP(IP1,J,3)-ZP(I,J,3)-
     *                        SDIAG1*ZP(IM1,J,3))
        TEMP(NPI) = DIAGIN*SDIAG2
        DIAG1 = DIAG2
   42   SDIAG1 = SDIAG2
   43 DIAGIN = 1./(DIAG1-SDIAG1*TEMP(NPM-1))
      DO 44 J = 1,N
        NPMPJ = NPM+J
        ZP(M,J,2) = DIAGIN*(TEMP(NPMPJ)-ZP(M,J,2)-
     *                      SDIAG1*ZP(MM1,J,2))
   44   ZP(M,J,3) = DIAGIN*(TEMP(J)-ZP(M,J,3)-
     *                      SDIAG1*ZP(MM1,J,3))
C
C PERFORM BACK SUBSTITUTION
C
      DO 45 I = 2,M
        IBAK = MP1-I
        IBAKP1 = IBAK+1
        NPIBAK = N+IBAK
        T = TEMP(NPIBAK)
        DO 45 J = 1,N
          ZP(IBAK,J,2) = ZP(IBAK,J,2)-T*ZP(IBAKP1,J,2)
   45     ZP(IBAK,J,3) = ZP(IBAK,J,3)-T*ZP(IBAKP1,J,3)
      RETURN
C
C TOO FEW POINTS
C
   46 IERR = 1
      RETURN
C
C POINTS NOT STRICTLY INCREASING
C
   47 IERR = 2
      RETURN
C
C THE OPTION VECTOR HAS AN ERROR
C
   48 IERR = 3
      RETURN
      END
      FUNCTION SURF2 (XX,YY,M,N,X,Y,Z,IZ,ZP,SIGMA)
C
      INTEGER M,N,IZ
      REAL XX,YY,X(M),Y(N),Z(IZ,N),ZP(M,N,*),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                       CODED BY A. K. CLINE AND R. J. RENKA
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS FUNCTION INTERPOLATES A SURFACE AT A GIVEN COORDINATE
C PAIR USING A BI-SPLINE UNDER TENSION. THE SUBROUTINE SURF1
C SHOULD BE CALLED EARLIER TO DETERMINE CERTAIN NECESSARY
C PARAMETERS.
C
C ON INPUT--
C
C   XX AND YY CONTAIN THE X- AND Y-COORDINATES OF THE POINT
C   TO BE MAPPED ONTO THE INTERPOLATING SURFACE.
C
C   M AND N CONTAIN THE NUMBER OF GRID LINES IN THE X- AND
C   Y-DIRECTIONS, RESPECTIVELY, OF THE RECTANGULAR GRID
C   WHICH SPECIFIED THE SURFACE.
C
C   X AND Y ARE ARRAYS CONTAINING THE X- AND Y-GRID VALUES,
C   RESPECTIVELY, EACH IN INCREASING ORDER.
C
C   Z IS A MATRIX CONTAINING THE M * N FUNCTIONAL VALUES
C   CORRESPONDING TO THE GRID VALUES (I. E. Z(I,J) IS THE
C   SURFACE VALUE AT THE POINT (X(I),Y(J)) FOR I = 1,...,M
C   AND J = 1,...,N).
C
C   IZ CONTAINS THE ROW DIMENSION OF THE ARRAY Z AS DECLARED
C   IN THE CALLING PROGRAM.
C
C   ZP IS AN ARRAY OF 3*M*N LOCATIONS STORED WITH THE
C   VARIOUS SURFACE DERIVATIVE INFORMATION DETERMINED BY
C   SURF1.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS M, N, X, Y, Z, IZ, ZP, AND SIGMA SHOULD BE
C INPUT UNALTERED FROM THE OUTPUT OF SURF1.
C
C ON OUTPUT--
C
C   SURF2 CONTAINS THE INTERPOLATED SURFACE VALUE.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS FUNCTION REFERENCES PACKAGE MODULES INTRVL AND
C SNHCSH.
C
C-----------------------------------------------------------
C
C INLINE ONE DIMENSIONAL CUBIC SPLINE INTERPOLATION
C
      HERMZ (F1,F2,FP1,FP2) = (F2*DEL1+F1*DEL2)/DELS-DEL1*
     *                        DEL2*(FP2*(DEL1+DELS)+
     *                              FP1*(DEL2+DELS))/
     *                        (6.*DELS)
C
C INLINE ONE DIMENSIONAL SPLINE UNDER TENSION INTERPOLATION
C
      HERMNZ (F1,F2,FP1,FP2,SIGMAP) = (F2*DEL1+F1*DEL2)/DELS
     *          +(FP2*(SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*
     *                           SINHP2+SIGMAP*COSHP1*DEL2))
     *           +FP1*(SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*
     *                           SINHP1+SIGMAP*COSHP2*DEL1))
     *          )/(SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS))
C
C DENORMALIZE TENSION FACTOR IN X AND Y DIRECTION
C
      SIGMAX = ABS(SIGMA)*FLOAT(M-1)/(X(M)-X(1))
      SIGMAY = ABS(SIGMA)*FLOAT(N-1)/(Y(N)-Y(1))
C
C DETERMINE Y INTERVAL
C
      JM1 = INTRVL (YY,Y,N)
      J = JM1+1
C
C DETERMINE X INTERVAL
C
      IM1 = INTRVL (XX,X,M)
      I = IM1+1
      DEL1 = YY-Y(JM1)
      DEL2 = Y(J)-YY
      DELS = Y(J)-Y(JM1)
      IF (SIGMAY .NE. 0.) GO TO 1
C
C PERFORM FOUR INTERPOLATIONS IN Y-DIRECTION
C
      ZIM1 = HERMZ(Z(I-1,J-1),Z(I-1,J),ZP(I-1,J-1,1),
     *                                  ZP(I-1,J,1))
      ZI = HERMZ(Z(I,J-1),Z(I,J),ZP(I,J-1,1),ZP(I,J,1))
      ZXXIM1 = HERMZ(ZP(I-1,J-1,2),ZP(I-1,J,2),
     *                ZP(I-1,J-1,3),ZP(I-1,J,3))
      ZXXI = HERMZ(ZP(I,J-1,2),ZP(I,J,2),
     *              ZP(I,J-1,3),ZP(I,J,3))
      GO TO 2
    1 DELP1 = (DEL1+DELS)/2.
      DELP2 = (DEL2+DELS)/2.
      CALL SNHCSH (SINHM1,DUMMY,SIGMAY*DEL1,-1)
      CALL SNHCSH (SINHM2,DUMMY,SIGMAY*DEL2,-1)
      CALL SNHCSH (SINHMS,DUMMY,SIGMAY*DELS,-1)
      CALL SNHCSH (SINHP1,DUMMY,SIGMAY*DEL1/2.,-1)
      CALL SNHCSH (SINHP2,DUMMY,SIGMAY*DEL2/2.,-1)
      CALL SNHCSH (DUMMY,COSHP1,SIGMAY*DELP1,1)
      CALL SNHCSH (DUMMY,COSHP2,SIGMAY*DELP2,1)
      ZIM1 = HERMNZ(Z(I-1,J-1),Z(I-1,J),ZP(I-1,J-1,1),
     *               ZP(I-1,J,1),SIGMAY)
      ZI = HERMNZ(Z(I,J-1),Z(I,J),ZP(I,J-1,1),ZP(I,J,1),
     *             SIGMAY)
      ZXXIM1 = HERMNZ(ZP(I-1,J-1,2),ZP(I-1,J,2),
     *                 ZP(I-1,J-1,3),ZP(I-1,J,3),SIGMAY)
      ZXXI = HERMNZ(ZP(I,J-1,2),ZP(I,J,2),
     *               ZP(I,J-1,3),ZP(I,J,3),SIGMAY)
C
C PERFORM FINAL INTERPOLATION IN X-DIRECTION
C
    2 DEL1 = XX-X(IM1)
      DEL2 = X(I)-XX
      DELS = X(I)-X(IM1)
      IF (SIGMAX .NE. 0.) GO TO 3
      SURF2 = HERMZ(ZIM1,ZI,ZXXIM1,ZXXI)
      RETURN
    3 DELP1 = (DEL1+DELS)/2.
      DELP2 = (DEL2+DELS)/2.
      CALL SNHCSH (SINHM1,DUMMY,SIGMAX*DEL1,-1)
      CALL SNHCSH (SINHM2,DUMMY,SIGMAX*DEL2,-1)
      CALL SNHCSH (SINHMS,DUMMY,SIGMAX*DELS,-1)
      CALL SNHCSH (SINHP1,DUMMY,SIGMAX*DEL1/2.,-1)
      CALL SNHCSH (SINHP2,DUMMY,SIGMAX*DEL2/2.,-1)
      CALL SNHCSH (DUMMY,COSHP1,SIGMAX*DELP1,1)
      CALL SNHCSH (DUMMY,COSHP2,SIGMAX*DELP2,1)
      SURF2 = HERMNZ(ZIM1,ZI,ZXXIM1,ZXXI,SIGMAX)
      RETURN
      END
      SUBROUTINE NSURF2 (DXMIN,DXMAX,MD,DYMIN,DYMAX,ND,DZ,
     *                   IDZ,M,N,X,Y,Z,IZ,ZP,WORK,SIGMA)
C
      INTEGER MD,ND,IDZ,M,N,IZ
      REAL DXMIN,DXMAX,DYMIN,DYMAX,DZ(IDZ,ND),X(M),Y(N),
     *     Z(IZ,N),ZP(M,N,*),WORK(4,MD),SIGMA
C
C                      FROM THE SPLINE UNDER TENSION PACKAGE
C                                 CODED BY ALAN KAYLOR CLINE
C                            DEPARTMENT OF COMPUTER SCIENCES
C                              UNIVERSITY OF TEXAS AT AUSTIN
C
C THIS SUBROUTINE MAPS VALUES ONTO A SURFACE AT EVERY POINT
C OF A GRID EQUALLY SPACED IN BOTH X AND Y COORDINATES. THE
C SURFACE INTERPOLATION IS PERFORMED USING A BI-SPLINE
C UNDER TENSION. THE SUBROUTINE SURF1 OR NSURF1 SHOULD BE
C CALLED EARLIER TO DETERMINE CERTAIN NECESSARY PARAMETERS.
C
C ON INPUT--
C
C   DXMIN AND DXMAX CONTAIN THE LOWER AND UPPER LIMITS,
C   RESPECTIVELY, OF THE X-COORDINATES OF THE SECOND GRID.
C
C   MD CONTAINS THE NUMBER OF GRID LINES IN THE X DIRECTION
C   OF THE SECOND GRID (MD .GE. 1).
C
C   DYMIN AND DYMAX CONTAIN THE LOWER AND UPPER LIMITS,
C   RESPECTIVELY, OF THE Y-COORDINATES OF THE SECOND GRID.
C
C   ND CONTAINS THE NUMBER OF GRID LINES IN THE Y DIRECTION
C   OF THE SECOND GRID (ND .GE. 1).
C
C   IDZ CONTAINS THE ROW DIMENSION OF THE ARRAY DZ AS
C   DECLARED IN THE CALLING PROGRAM.
C
C   M AND N CONTAIN THE NUMBER OF GRID LINES IN THE X- AND
C   Y-DIRECTIONS, RESPECTIVELY, OF THE RECTANGULAR GRID
C   WHICH SPECIFIED THE SURFACE.
C
C   X AND Y ARE ARRAYS CONTAINING THE X- AND Y-GRID VALUES,
C   RESPECTIVELY, EACH IN INCREASING ORDER.
C
C   Z IS A MATRIX CONTAINING THE M * N FUNCTIONAL VALUES
C   CORRESPONDING TO THE GRID VALUES (I. E. Z(I,J) IS THE
C   SURFACE VALUE AT THE POINT (X(I),Y(J)) FOR I = 1,...,M
C   AND J = 1,...,N).
C
C   IZ CONTAINS THE ROW DIMENSION OF THE ARRAY Z AS DECLARED
C   IN THE CALLING PROGRAM.
C
C   ZP IS AN ARRAY OF 3*M*N LOCATIONS STORED WITH THE
C   VARIOUS SURFACE DERIVATIVE INFORMATION DETERMINED BY
C   SURF1.
C
C   WORK IS AN ARRAY OF 4*MD LOCATIONS TO BE USED INTERNALLY
C   FOR WORKSPACE.
C
C AND
C
C   SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED).
C
C THE PARAMETERS M, N, X, Y, Z, IZ, ZP, AND SIGMA SHOULD BE
C INPUT UNALTERED FROM THE OUTPUT OF SURF1 OR NSURF1.
C
C ON OUTPUT--
C
C   DZ CONTAINS THE MD BY ND ARRAY OF SURFACE VALUES
C   INTERPOLATED AT THE POINTS OF THE SECOND GRID.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED.
C
C THIS FUNCTION REFERENCES PACKAGE MODULE SNHCSH.
C
C-----------------------------------------------------------
C
C DENORMALIZE TENSION FACTOR IN X AND Y DIRECTION
C
      SIGMAX = ABS(SIGMA)*FLOAT(M-1)/(X(M)-X(1))
      SIGMAY = ABS(SIGMA)*FLOAT(N-1)/(Y(N)-Y(1))
C
C FIND INTERVALS OF SECOND X GRID WITH RESPECT TO ORIGINAL X
C GRID
C
      DELTDX = 0.
      IF (MD .GE. 2) DELTDX = (DXMAX-DXMIN)/FLOAT(MD-1)
      LASTI = 1
      DO 3 II = 1,MD
        XII = DXMIN+FLOAT(II-1)*DELTDX
        I = LASTI
    1   I = I+1
        IF (XII .GT. X(I) .AND. I .LT. M) GO TO 1
        IM1 = I-1
        LASTI = IM1
        DEL1 = XII-X(IM1)
        DEL2 = X(I)-XII
        DELS = X(I)-X(IM1)
        WORK(1,II) = DEL2/DELS
        WORK(2,II) = DEL1/DELS
        IF (SIGMAX .NE. 0.) GO TO 2
        TEMP = -DEL1*DEL2/(6.*DELS)
        WORK(3,II) = TEMP*(DEL2+DELS)
        WORK(4,II) = TEMP*(DEL1+DELS)
        GO TO 3
    2   DELP1 = (DEL1+DELS)/2.
        DELP2 = (DEL2+DELS)/2.
        CALL SNHCSH (SINHM1,DUMMY,SIGMAX*DEL1,-1)
        CALL SNHCSH (SINHM2,DUMMY,SIGMAX*DEL2,-1)
        CALL SNHCSH (SINHMS,DUMMY,SIGMAX*DELS,-1)
        CALL SNHCSH (SINHP1,DUMMY,SIGMAX*DEL1/2.,-1)
        CALL SNHCSH (SINHP2,DUMMY,SIGMAX*DEL2/2.,-1)
        CALL SNHCSH (DUMMY,COSHP1,SIGMAX*DELP1,1)
        CALL SNHCSH (DUMMY,COSHP2,SIGMAX*DELP2,1)
        TEMP = SIGMAX*SIGMAX*DELS*(SINHMS+SIGMAX*DELS)
        WORK(3,II) = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*
     *                SINHP1+SIGMAX*COSHP2*DEL1))/TEMP
        WORK(4,II) = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*
     *                SINHP2+SIGMAX*COSHP1*DEL2))/TEMP
    3   CONTINUE
C
C FIND INTERVALS OF SECOND Y GRID WITH RESPECT TO ORIGINAL Y
C GRID AND PERFORM INTRPOLATION
C
      DELTDY = 0.
      IF (ND .GE. 2) DELTDY = (DYMAX-DYMIN)/FLOAT(ND-1)
      LASTJ = 1
      DO 8 JJ=1,ND
        YJJ = DYMIN+FLOAT(JJ-1)*DELTDY
        J = LASTJ
    4   J = J+1
        IF (YJJ .GT. Y(J) .AND. J .LT. N) GO TO 4
        JM1 = J-1
        LASTJ = JM1
        DEL1 = YJJ-Y(JM1)
        DEL2 = Y(J)-YJJ
        DELS = Y(J)-Y(JM1)
        C1 = DEL2/DELS
        C2 = DEL1/DELS
        IF (SIGMAY .NE. 0.) GO TO 5
        TEMP = -DEL1*DEL2/(6.*DELS)
        C3 = TEMP*(DEL2+DELS)
        C4 = TEMP*(DEL1+DELS)
        GO TO 6
    5   DELP1 = (DEL1+DELS)/2.
        DELP2 = (DEL2+DELS)/2.
        CALL SNHCSH (SINHM1,DUMMY,SIGMAY*DEL1,-1)
        CALL SNHCSH (SINHM2,DUMMY,SIGMAY*DEL2,-1)
        CALL SNHCSH (SINHMS,DUMMY,SIGMAY*DELS,-1)
        CALL SNHCSH (SINHP1,DUMMY,SIGMAY*DEL1/2.,-1)
        CALL SNHCSH (SINHP2,DUMMY,SIGMAY*DEL2/2.,-1)
        CALL SNHCSH (DUMMY,COSHP1,SIGMAY*DELP1,1)
        CALL SNHCSH (DUMMY,COSHP2,SIGMAY*DELP2,1)
        TEMP = SIGMAY*SIGMAY*DELS*(SINHMS+SIGMAY*DELS)
        C3 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*
     *        SINHP1+SIGMAY*COSHP2*DEL1))/TEMP
        C4 = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*
     *        SINHP2+SIGMAY*COSHP1*DEL2))/TEMP
    6   LASTI = 0
        DO 8 II=1,MD
          XII = DXMIN+FLOAT(II-1)*DELTDX
          I = MAX0 (1, LASTI)
    7     I = I+1
          IF (XII .GT. X(I) .AND. I .LT. M) GO TO 7
          IM1 = I-1
          IF (IM1 .EQ. LASTI) GO TO 8
          LASTI = IM1
          ZIM1 = C1*Z(IM1,JM1)+C2*Z(IM1,J)
     *           +C3*ZP(IM1,JM1,1)+C4*ZP(IM1,J,1)
          ZI = C1*Z(I,JM1)+C2*Z(I,J)
     *         +C3*ZP(I,JM1,1)+C4*ZP(I,J,1)
          ZXXIM1 = C1*ZP(IM1,JM1,2)+C2*ZP(IM1,J,2)
     *             +C3*ZP(IM1,JM1,3)+C4*ZP(IM1,J,3)
          ZXXI = C1*ZP(I,JM1,2)+C2*ZP(I,J,2)
     *           +C3*ZP(I,JM1,3)+C4*ZP(I,J,3)
    8     DZ(II,JJ) = WORK(1,II)*ZIM1+WORK(2,II)*ZI
     *                +WORK(3,II)*ZXXIM1+WORK(4,II)*ZXXI
      RETURN
      END
      SUBROUTINE BSTRP2 (X, Y, Z, KZ, TX, NX, KX, TY, NY, KY,
     *                   A, KA, WK, L, IFLAG)
C-----------------------------------------------------------------------
C
C         PIECEWISE POLYNOMIAL INTERPOLATION IN TWO VARIABLES
C
C                          -----------------
C
C     THE PIECEWISE POLYNOMIALS CONSIDERED ARE TENSOR PRODUCTS OF
C     B-SPLINES, HAVING THE FORM
C
C                          NX   NY
C              F(X,Y)  =  SUM  SUM  A   U (X) V (Y)
C                         I=1  J=1   IJ  I     J
C
C     WHERE U  AND V  ARE ONE-DIMENSIONAL B-SPLINE BASIS FUNCTIONS.
C            I      J
C
C-----------------------------------------------------------------------
C     REAL TX(NX + KX), TY(NY + KY)
C     REAL WK(L)  WHERE L = NX*NY + MAX(2*KX*NX, 2*KY*NY)
C-------------------------
      REAL X(NX), Y(NY), Z(KZ,NY)
      REAL TX(*), TY(*), A(KA,NY), WK(L)
C
      M = NX*NY + 2*MAX0(KX*NX, KY*NY)
      IF (L .LT. M) GO TO 120
C
C     COMPUTE THE COEFFICIENTS
C
      IW = NX*NY + 1
      CALL BSTRP1 (X, Z, KZ, NX, NY, TX, KX, WK, NY, WK(IW), IFLAG)
      IF (IFLAG .NE. 0) GO TO 100
      CALL BSTRP1 (Y, WK, NY, NY, NX, TY, KY, A, KA, WK(IW), IFLAG)
      IF (IFLAG .NE. 0) GO TO 110
      RETURN
C
C     ERROR RETURN
C
  100 IFLAG = 1
      RETURN
  110 IFLAG = 2
      RETURN
  120 IFLAG = 3
      RETURN
      END
      SUBROUTINE BSTRP1 (X, Z, KZ, M, N, T, K, A, KA, WORK, IFLAG)
C-------------------------------------------------------------------
C     BSTRP1 COMPUTES B-SPLINE INTERPOLATION COEFFICIENTS FOR
C     N SETS OF DATA STORED IN THE COLUMNS OF THE ARRAY Z. THE
C     COEFFICIENTS ARE STORED IN THE ROWS OF A.
C
C     IT IS ASSUMED THAT KZ .GE. M AND KA .GE. N.
C-------------------------------------------------------------------
C     REAL T(M + K), WORK(2*K*M)
C-----------------------
      REAL X(M), Z(KZ,N), T(*), A(KA,M), WORK(*)
C
C     FIRST DATA SET
C
      IFLAG = 1
      MP1 = M + 1
      CALL BSTRP (X, Z, T, M, K, WORK(1), WORK(MP1), IFLAG)
      IF (IFLAG .NE. 0) RETURN
C
      DO 10 I = 1,M
         A(1,I) = WORK(I)
   10 CONTINUE
      IF (N .EQ. 1) RETURN
C
C     REMAINING DATA SETS
C
      DO 30 J = 2,N
         CALL BSTRP (X, Z(1,J), T, M, K, WORK(1), WORK(MP1), IFLAG)
         DO 20 I = 1,M
            A(J,I) = WORK(I)
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
      SUBROUTINE BSLSQ2 (X, WX, MX, Y, WY, MY, Z, KZ, TX, NX, KX,
     *                   TY, NY, KY, A, KA, WK, L, IFLAG)
C-----------------------------------------------------------------------
C
C             WEIGHTED LEAST SQUARES FITTING OF PIECEWISE
C                    POLYNOMIALS IN TWO VARIABLES
C
C                          ----------------
C
C     THE PIECEWISE POLYNOMIALS CONSIDERED ARE TENSOR PRODUCTS OF
C     B-SPLINES, HAVING THE FORM
C
C                          NX   NY
C              F(X,Y)  =  SUM  SUM  A   U (X) V (Y)
C                         I=1  J=1   IJ  I     J
C
C     WHERE U  AND V  ARE ONE-DIMENSIONAL B-SPLINE BASIS FUNCTIONS.
C            I      J
C
C-----------------------------------------------------------------------
C     REAL TX(NX + KX), TY(NY + KY)
C     REAL WK(L)  WHERE L = NX*MY + MAX((KX+1)*NX,(KY+1)*NY)
C-------------------------
      REAL X(MX), WX(MX), Y(MY), WY(MY), Z(KZ,MY)
      REAL TX(*), TY(*), A(KA,NY), WK(L)
C
      M = NX*MY + MAX0((KX + 1)*NX,(KY + 1)*NY)
      IF (L .LT. M) GO TO 120
C
C     COMPUTE THE COEFFICIENTS
C
      IW = NX*MY + 1
      IQ = IW + NX
      CALL BSLSQ1 (X, WX, MX, Z, KZ, MY, TX, NX, KX,
     *             WK, MY, WK(IW), WK(IQ), IERR)
      IF (IERR .LT. 0) GO TO 100
C
      IQ = IW + NY
      CALL BSLSQ1 (Y, WY, MY, WK, MY, NX, TY, NY, KY,
     *             A, KA, WK(IW), WK(IQ), IFLAG)
      IF (IFLAG .LT. 0) GO TO 110
      IFLAG = MAX0(IERR,IFLAG)
      RETURN
C
C     ERROR RETURN
C
  100 IFLAG = -1
      RETURN
  110 IFLAG = -2
      RETURN
  120 IFLAG = -3
      WK(1) = M
      RETURN
      END
      SUBROUTINE BSLSQ1 (TAU, WGT, NTAU, Z, KZ, M, T, N, K,
     *                   A, KA, WK, Q, IERR)
C-----------------------------------------------------------------------
C
C     BSLSQ1 PRODUCES THE B-SPLINE COEFFICIENTS A(J,1),...,A(J,N)
C     OF THE PIECEWISE POLYNOMIAL P(X) OF ORDER K WITH KNOTS T(I)
C     (I = 1,...,N+K) WHICH MINIMIZES
C
C              SUM (WGT(L)*(P(TAU(L)) - Z(L,J))**2)
C                 L
C
C     FOR J = 1,...,M.
C
C     INPUT ...
C
C       TAU   ARRAY OF LENGTH NTAU CONTAINING DATA POINT ABSCISSAE.
C       WGT   ARRAY OF LENGTH NTAU CONTAINING THE WEIGHTS.
C       NTAU  NUMBER OF DATA POINTS TO BE FITTED (NTAU .GE. N).
C       Z     MATRIX CONTAINING M SETS OF ORDINATES TO BE FITTED.
C             EACH SET OF NTAU ORDINATES IS A COLUMN OF Z.
C       KZ    NUMBER OF ROWS OF Z IN THE CALLING PROGRAM.
C             IT IS ASSUMED THAT KZ .GE. NTAU.
C       M     NUMBER OF SETS OF ORDINATES TO BE FITTED.
C       T     KNOT SEQUENCE OF LENGTH N+K.
C       N     DIMENSION OF THE PIECEWISE POLYNOMIAL SPACE.
C       K     ORDER OF THE B-SPLINES.
C       KA    NUMBER OF ROWS OF A IN THE CALLING PROGRAM.
C             IT IS ASSUMED THAT KA .GE. M.
C
C     OUTPUT ...
C
C       A     MATRIX CONTAINING THE M SETS OF B-SPLINE COEFFICIENTS
C             OF THE L2 APPROXIMATIONS. EACH SET OF N COEFFICIENTS
C             IS A ROW OF A.
C
C       IERR  INTEGER REPORTING THE STATUS OF THE RESULTS ...
C
C             0  THE COEFFICIENT MATRIX IS NONSIGULAR. THE
C                UNIQUE LEAST SQUARES SOLUTION WAS OBTAINED.
C             1  THE COEFFICIENT MATRIX IS SINGULAR. A
C                LEAST SQUARES SOLUTION WAS OBTAINED.
C            -1  INPUT ERRORS WERE DETECTED.
C
C-----------------------------------------------------------------------
      REAL TAU(NTAU), WGT(NTAU), Z(KZ,M)
      REAL T(*), A(KA,N), WK(N), Q(K,N)
C
      IF (NTAU .LT. MAX0(2,K)) GO TO 100
      IF (TAU(1) .LT. T(K) .OR. TAU(NTAU) .GT. T(N + 1)) GO TO 100
C
      DO 10 I = 2,NTAU
         IF (TAU(I - 1) .GT. TAU(I)) GO TO 100
   10 CONTINUE
C
      DO 21 J = 1,N
         DO 20 I = 1,M
            A(I,J) = 0.0
   20    CONTINUE
   21 CONTINUE
C
      DO 31 J = 1,N
         DO 30 I = 1,K
            Q(I,J) = 0.0
   30    CONTINUE
   31 CONTINUE
C
      LEFT = K
      DO 90 L = 1,NTAU
C
C        *** FIND THE INDEX LEFT SUCH THAT
C            T(LEFT) .LE. TAU(L) .LT. T(LEFT+1)
C
   40    IF (LEFT .EQ. N) GO TO 50
            IF (TAU(L) .LT. T(LEFT+1)) GO TO 50
            LEFT = LEFT + 1
            GO TO 40
C
   50    JJ = 0
         CALL BSPVB (T, K, K, JJ, TAU(L), LEFT, WK)
C
         LEFTMK = LEFT - K
         DO 80 MM = 1,K
            DW = WK(MM)*WGT(L)
            J = LEFTMK + MM
            DO 60 I = 1,M
               A(I,J) = DW*Z(L,I) + A(I,J)
   60       CONTINUE
            I = 1
            DO 70 JJ = MM,K
               Q(I,J) = WK(JJ)*DW + Q(I,J)
               I = I + 1
   70       CONTINUE
   80    CONTINUE
   90 CONTINUE
C
C        SOLVE THE NORMAL EQUATIONS
C
      CALL BCHFAC (Q, K, N, WK, IERR)
      CALL BCHSV1 (Q, K, N, A, KA, M)
      RETURN
C
C             ERROR RETURN
C
  100 IERR = -1
      RETURN
      END
      SUBROUTINE BCHSV1 (W, NB, N, B, KB, M)
C-----------------------------------------------------------------------
C
C     BCHSV1 SOLVES M LINEAR SYSTEMS C*X = B  (I = 1,...,M), WHERE
C                                       I   I
C     EACH B  IS A VECTOR STORED IN THE I-TH ROW OF A MATRIX B.
C           I
C                       ------------------
C
C     INPUT ...
C
C        N   THE ORDER OF THE MATRIX C
C        NB  THE BANDWIDTH OF C
C        W   THE CHOLESKY FACTORIZATION OF THE BANDED SYMMETRIC
C            POSITIVE DEFINITE MATRIX C OBTAINED BY THE ROUTINE
C            BCHFAC.
C        B   MATRIX WHOSE ROWS ARE THE VECTORS TO BE SOLVED FOR
C            IN THE M LINEAR SYSTEMS OF EQUATIONS.
C        KB  THE NUMBER OF ROWS OF B SPECIFIED IN THE CALLING
C            PROGRAM. IT IS ASSUMED THAT KB .GE. M.
C        M   NUMBER OF LINEAR SYSTEMS TO BE SOLVED.
C
C     OUTPUT ...
C
C        B   MATRIX WHOSE ROWS ARE THE SOLUTIONS X  OF THE M
C            LINEAR SYSTEMS OF EQUATIONS.         I
C
C                                       T
C     NOTE.  THE FACTORIZATION C = L*D*L  IS USED, WHERE L IS A
C     UNIT LOWER TRIANGULAR MATRIX AND D A DIAGONAL MATRIX.
C
C-----------------------------------------------------------------------
      REAL W(NB,N), B(KB,N)
C
      IF (N .GT. 1) GO TO 20
      DO 10 I = 1,M
         B(I,1) = B(I,1)*W(1,1)
   10 CONTINUE
      RETURN
C
C     FORWARD SUBSTITUTION. SOLVE L*Y = B FOR Y AND STORE Y IN B.
C
   20 NBM1 = NB - 1
      DO 40 K = 1,N
         JMAX = MIN0(NBM1,N - K)
         IF (JMAX .LT. 1) GO TO 40
         DO 31 J = 1,JMAX
            JPK = J + K
            T = W(J + 1,K)
            DO 30 I = 1,M
               B(I,JPK) = B(I,JPK) - T*B(I,K)
   30       CONTINUE
   31    CONTINUE
   40 CONTINUE
C                              T     -1
C     BACKSUBSTITUTION. SOLVE L X = D  Y  FOR X AND STORE X IN B.
C
      K = N
   50    T = W(1,K)
         DO 60 I = 1,M
            B(I,K) = T*B(I,K)
   60    CONTINUE
         JMAX = MIN0(NBM1,N - K)
         IF (JMAX .LT. 1) GO TO 80
         DO 71 J = 1,JMAX
            JPK = J + K
            T = W(J + 1,K)
            DO 70 I = 1,M
               B(I,K) = B(I,K) - T*B(I,JPK)
   70       CONTINUE
   71    CONTINUE
   80    K = K - 1
         IF (K .GT. 0) GO TO 50
      RETURN
      END
      SUBROUTINE BVAL2 (A, KA, TX, NX, KX, TY, NY, KY, X0, Y0,
     *                  IDX, IDY, F, WK)
C-----------------------------------------------------------------------
C
C                EVALUATION AND PARTIAL DIFFERENTIATION
C                      OF A PIECEWISE POLYNOMIAL
C
C                            NX   NY
C                F(X,Y)  =  SUM  SUM  A   U (X) V (Y)
C                           I=1  J=1   IJ  I     J
C
C     WHERE U  AND V  ARE ONE-DIMENSIONAL B-SPLINE BASIS FUNCTIONS.
C            I      J
C-----------------------------------------------------------------------
C     REAL TX(NX + KX), TY(NY + KY), WK(KY + 3*MAX(KX,KY))
C-----------------------------
      REAL A(KA,NY), TX(*), TY(*), WK(*)
C
      F = 0.0
      M = NX + KX
      IF (X0 .LT. TX(1) .OR. X0 .GT. TX(M)) RETURN
      M = NY + KY
      IF (Y0 .LT. TY(1) .OR. Y0 .GT. TY(M)) RETURN
C
      IW = KY + 1
      J = INTRVL(Y0, TY, M)
      IF (J .GT. KY) GO TO 20
C
C     CASE WHEN  J .LE. KY
C
      DO 10 L = 1,J
         CALL BVAL (TX, A(1,L), NX, KX, X0, IDX, WK(L), WK(IW))
   10 CONTINUE
      CALL BVAL (TY, WK(1), J, KY, Y0, IDY, F, WK(IW))
      RETURN
C
C     CASE WHEN  J .GT. KY
C
   20 L = J - KY
      DO 30 I = 1,KY
         L = L + 1
         CALL BVAL (TX, A(1,L), NX, KX, X0, IDX, WK(I), WK(IW))
   30 CONTINUE
      L = J - KY + 1
      CALL BVAL (TY(L), WK(1), KY, KY, Y0, IDY, F, WK(IW))
      RETURN
      END
      SUBROUTINE TRMESH (N,X,Y, IADJ,IEND,IER)
      INTEGER N, IADJ(*), IEND(N), IER
      REAL    X(N), Y(N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS ROUTINE CREATES A THIESSEN TRIANGULATION OF N
C ARBITRARILY SPACED POINTS IN THE PLANE REFERRED TO AS
C NODES.  THE TRIANGULATION IS OPTIMAL IN THE SENSE THAT IT
C IS AS NEARLY EQUIANGULAR AS POSSIBLE.  TRMESH IS PART OF
C AN INTERPOLATION PACKAGE WHICH ALSO PROVIDES SUBROUTINES
C TO REORDER THE NODES, ADD A NEW NODE, DELETE AN ARC, PLOT
C THE MESH, AND PRINT THE DATA STRUCTURE.
C   UNLESS THE NODES ARE ALREADY ORDERED IN SOME REASONABLE
C FASHION, THEY SHOULD BE REORDERED BY SUBROUTINE REORDR FOR
C INCREASED EFFICIENCY BEFORE CALLING TRMESH.
C
C INPUT PARAMETERS -     N - NUMBER OF NODES IN THE MESH.
C                            N .GE. 3.
C
C                      X,Y - N-VECTORS OF COORDINATES.
C                            (X(I),Y(I)) DEFINES NODE I.
C
C                     IADJ - VECTOR OF LENGTH .GE. 6*N-9.
C
C                     IEND - VECTOR OF LENGTH .GE. N.
C
C N, X, AND Y ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETERS - IADJ - ADJACENCY LISTS OF NEIGHBORS IN
C                            COUNTERCLOCKWISE ORDER.  THE
C                            LIST FOR NODE I+1 FOLLOWS THAT
C                            FOR NODE I WHERE X AND Y DEFINE
C                            THE ORDER.  THE VALUE 0 DENOTES
C                            THE BOUNDARY (OR A PSEUDO-NODE
C                            AT INFINITY) AND IS ALWAYS THE
C                            LAST NEIGHBOR OF A BOUNDARY
C                            NODE.  IADJ IS UNCHANGED IF IER
C                            .NE. 0.
C
C                     IEND - POINTERS TO THE ENDS OF
C                            ADJACENCY LISTS (SETS OF
C                            NEIGHBORS) IN IADJ.  THE
C                            NEIGHBORS OF NODE 1 BEGIN IN
C                            IADJ(1).  FOR K .GT. 1, THE
C                            NEIGHBORS OF NODE K BEGIN IN
C                            IADJ(IEND(K-1)+1) AND K HAS
C                            IEND(K) - IEND(K-1) NEIGHBORS
C                            INCLUDING (POSSIBLY) THE
C                            BOUNDARY.  IADJ(IEND(K)) .EQ. 0
C                            IFF NODE K IS ON THE BOUNDARY.
C                            IEND IS UNCHANGED IF IER = 1.
C                            IF IER = 2 IEND CONTAINS THE
C                            INDICES OF A SEQUENCE OF N
C                            NODES ORDERED FROM LEFT TO
C                            RIGHT WHERE LEFT AND RIGHT ARE
C                            DEFINED BY ASSUMING NODE 1 IS
C                            TO THE LEFT OF NODE 2.
C
C                      IER - ERROR INDICATOR
C                            IER = 0 IF NO ERRORS WERE
C                                    ENCOUNTERED.
C                            IER = 1 IF N .LT. 3.
C                            IER = 2 IF N .GE. 3 AND ALL
C                                    NODES ARE COLLINEAR.
C
C MODULES REFERENCED BY TRMESH - SHIFTD, ADNODE, TRFIND,
C                                INTADD, BDYADD, SWPTST,
C                                SWAPD, TINDX
C
C***********************************************************
C
      INTEGER NN, K, KM1, NL, NR, IND, INDX, N0, ITEMP,
     .        IERR, KM1D2, KMI, I, KMIN
      REAL    XL, YL, XR, YR, DXR, DYR, XK, YK, DXK, DYK,
     .        CPROD, SPROD
C
C LOCAL PARAMETERS -
C
C NN =          LOCAL COPY OF N
C K =           NODE (INDEX) TO BE INSERTED INTO IEND
C KM1 =         K-1 - (VARIABLE) LENGTH OF IEND
C NL,NR =       IEND(1), IEND(KM1) -- LEFTMOST AND RIGHTMOST
C                 NODES IN IEND AS VIEWED FROM THE RIGHT OF
C                 1-2 WHEN IEND CONTAINS THE INITIAL ORDERED
C                 SET OF NODAL INDICES
C XL,YL,XR,YR = X AND Y COORDINATES OF NL AND NR
C DXR,DYR =     XR-XL, YR-YL
C XK,YK =       X AND Y COORDINATES OF NODE K
C DXK,DYK =     XK-XL, YK-YL
C CPROD =       VECTOR CROSS PRODUCT OF NL-NR AND NL-K --
C                 USED TO DETERMINE THE POSITION OF NODE K
C                 WITH RESPECT TO THE LINE DEFINED BY THE
C                 NODES IN IEND
C SPROD =       SCALAR PRODUCT USED TO DETERMINE THE
C                 INTERVAL CONTAINING NODE K WHEN K IS ON
C                 THE LINE DEFINED BY THE NODES IN IEND
C IND,INDX =    INDICES FOR IEND AND IADJ, RESPECTIVELY
C N0,ITEMP =    TEMPORARY NODES (INDICES)
C IERR =        DUMMY PARAMETER FOR CALL TO ADNODE
C KM1D2,KMI,I = KM1/2, K-I, DO-LOOP INDEX -- USED IN IEND
C                 REORDERING LOOP
C KMIN =        FIRST NODE INDEX SENT TO ADNODE
C
      NN = N
      IER = 1
      IF (NN .LT. 3) RETURN
      IER = 0
C
C INITIALIZE IEND, NL, NR, AND K
C
      IEND(1) = 1
      IEND(2) = 2
      XL = X(1)
      YL = Y(1)
      XR = X(2)
      YR = Y(2)
      K = 2
C
C BEGIN LOOP ON NODES 3,4,...
C
    1 DXR = XR-XL
      DYR = YR-YL
C
C NEXT LOOP BEGINS HERE IF NL AND NR ARE UNCHANGED
C
    2 IF (K .EQ. NN) GO TO 13
      KM1 = K
      K = KM1 + 1
      XK = X(K)
      YK = Y(K)
      DXK = XK-XL
      DYK = YK-YL
      CPROD = DXR*DYK - DXK*DYR
      IF (CPROD .GT. 0.) GO TO 6
      IF (CPROD .LT. 0.) GO TO 8
C
C NODE K LIES ON THE LINE CONTAINING NODES 1,2,...,K-1.
C   SET SPROD TO (NL-NR,NL-K).
C
      SPROD = DXR*DXK + DYR*DYK
      IF (SPROD .GT. 0.) GO TO 3
C
C NODE K IS TO THE LEFT OF NL.  INSERT K AS THE FIRST
C   (LEFTMOST) NODE IN IEND AND SET NL TO K.
C
      CALL SHIFTD(1,KM1,1, IEND )
      IEND(1) = K
      XL = XK
      YL = YK
      GO TO 1
C
C NODE K IS TO THE RIGHT OF NL.  FIND THE LEFTMOST NODE
C   N0 WHICH LIES TO THE RIGHT OF K.
C   SET SPROD TO (N0-NL,N0-K).
C
    3 DO 4 IND = 2,KM1
        N0 = IEND(IND)
        SPROD = (XL-X(N0))*(XK-X(N0)) +
     .          (YL-Y(N0))*(YK-Y(N0))
        IF (SPROD .GE. 0.) GO TO 5
    4   CONTINUE
C
C NODE K IS TO THE RIGHT OF NR.  INSERT K AS THE LAST
C   (RIGHTMOST) NODE IN IEND AND SET NR TO K.
C
      IEND(K) = K
      XR = XK
      YR = YK
      GO TO 1
C
C NODE K LIES BETWEEN IEND(IND-1) AND IEND(IND).  INSERT K
C   IN IEND.
C
    5 CALL SHIFTD(IND,KM1,1, IEND )
      IEND(IND) = K
      GO TO 2
C
C NODE K IS TO THE LEFT OF NL-NR.  REORDER IEND SO THAT NL
C   IS THE LEFTMOST NODE AS VIEWED FROM K.
C
    6 KM1D2 = KM1/2
      DO 7 I = 1,KM1D2
        KMI = K-I
        ITEMP = IEND(I)
        IEND(I) = IEND(KMI)
        IEND(KMI) = ITEMP
    7   CONTINUE
C
C NODE K IS TO THE RIGHT OF NL-NR.  CREATE A TRIANGULATION
C   CONSISTING OF NODES 1,2,...,K.
C
    8 NL = IEND(1)
      NR = IEND(KM1)
C
C CREATE THE ADJACENCY LISTS FOR THE FIRST K-1 NODES.
C   INSERT NEIGHBORS IN REVERSE ORDER.  EACH NODE HAS FOUR
C   NEIGHBORS EXCEPT NL AND NR WHICH HAVE THREE.
C
      DO 9 IND = 1,KM1
        N0 = IEND(IND)
        INDX = 4*N0
        IF (N0 .GE. NL) INDX = INDX-1
        IF (N0 .GE. NR) INDX = INDX-1
        IADJ(INDX) = 0
        INDX = INDX-1
        IF (IND .LT. KM1) IADJ(INDX) = IEND(IND+1)
        IF (IND .LT. KM1) INDX = INDX-1
        IADJ(INDX) = K
        IF (IND .EQ. 1) GO TO 9
        IADJ(INDX-1) = IEND(IND-1)
    9   CONTINUE
C
C CREATE THE ADJACENCY LIST FOR NODE K
C
      INDX = 5*KM1 - 1
      IADJ(INDX) = 0
      DO 10 IND = 1,KM1
        INDX = INDX-1
        IADJ(INDX) = IEND(IND)
   10   CONTINUE
C
C REPLACE IEND ELEMENTS WITH POINTERS TO IADJ
C
      INDX = 0
      DO 11 IND = 1,KM1
        INDX = INDX + 4
        IF (IND .EQ. NL  .OR.  IND .EQ. NR) INDX = INDX-1
        IEND(IND) = INDX
   11   CONTINUE
      INDX = INDX + K
      IEND(K) = INDX
C
C ADD THE REMAINING NODES TO THE TRIANGULATION
C
      IF (K .EQ. NN) RETURN
      KMIN = K+1
      DO 12 K = KMIN,NN
        CALL ADNODE(K,X,Y, IADJ,IEND, IERR)
   12   CONTINUE
      RETURN
C
C ALL NODES ARE COLLINEAR
C
   13 IER = 2
      RETURN
      END
      SUBROUTINE ADNODE (KK,X,Y, IADJ,IEND, IER)
      INTEGER KK, IADJ(*), IEND(KK), IER
      REAL    X(KK), Y(KK)
      LOGICAL SWPTST
      INTEGER TINDX
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS ROUTINE ADDS NODE KK TO A TRIANGULATION OF A SET
C OF POINTS IN THE PLANE PRODUCING A NEW TRIANGULATION.  A
C SEQUENCE OF EDGE SWAPS IS THEN APPLIED TO THE MESH,
C RESULTING IN AN OPTIMAL TRIANGULATION.  ADNODE IS PART
C OF AN INTERPOLATION PACKAGE WHICH ALSO PROVIDES ROUTINES
C TO INITIALIZE THE DATA STRUCTURE, PLOT THE MESH, AND
C DELETE ARCS.
C
C INPUT PARAMETERS -   KK - INDEX OF THE NODE TO BE ADDED
C                           TO THE MESH.  KK .GE. 4.
C
C                     X,Y - VECTORS OF COORDINATES OF THE
C                           NODES IN THE MESH.  (X(I),Y(I))
C                           DEFINES NODE I FOR I = 1,..,KK.
C
C                    IADJ - SET OF ADJACENCY LISTS OF NODES
C                           1,..,KK-1.
C
C                    IEND - POINTERS TO THE ENDS OF
C                           ADJACENCY LISTS IN IADJ FOR
C                           EACH NODE IN THE MESH.
C
C IADJ AND IEND MAY BE CREATED BY TRMESH.
C
C KK, X, AND Y ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETERS - IADJ,IEND - UPDATED WITH THE ADDITION
C                                 OF NODE KK AS THE LAST
C                                 ENTRY.
C
C                           IER - ERROR INDICATOR
C                                 IER = 0 IF NO ERRORS
C                                         WERE ENCOUNTERED.
C                                 IER = 1 IF ALL NODES
C                                         (INCLUDING KK) ARE
C                                         COLLINEAR.
C
C MODULES REFERENCED BY ADNODE - TRFIND, INTADD, BDYADD,
C                                SHIFTD, TINDX, SWPTST,
C                                SWAPD
C
C***********************************************************
C
      INTEGER K, KM1, I1, I2, I3, INDKF, INDKL, NABOR1,
     .        IO1, IO2, IN1, INDK1, IND2F, IND21
      REAL    XK, YK
C
C LOCAL PARAMETERS -
C
C K =        LOCAL COPY OF KK
C KM1 =      K - 1
C I1,I2,I3 = VERTICES OF A TRIANGLE CONTAINING K
C INDKF =    IADJ INDEX OF THE FIRST NEIGHBOR OF K
C INDKL =    IADJ INDEX OF THE LAST NEIGHBOR OF K
C NABOR1 =   FIRST NEIGHBOR OF K BEFORE ANY SWAPS OCCUR
C IO1,IO2 =  ADJACENT NEIGHBORS OF K DEFINING AN ARC TO
C              BE TESTED FOR A SWAP
C IN1 =      VERTEX OPPOSITE K -- FIRST NEIGHBOR OF IO2
C              WHICH PRECEDES IO1.  IN1,IO1,IO2 ARE IN
C              COUNTERCLOCKWISE ORDER.
C INDK1 =    INDEX OF IO1 IN THE ADJACENCY LIST FOR K
C IND2F =    INDEX OF THE FIRST NEIGHBOR OF IO2
C IND21 =    INDEX OF IO1 IN THE ADJACENCY LIST FOR IO2
C XK,YK =    X(K), Y(K)
C
      IER = 0
      K = KK
C
C INITIALIZATION
C
      KM1 = K - 1
      XK = X(K)
      YK = Y(K)
C
C ADD NODE K TO THE MESH
C
      CALL TRFIND(KM1,XK,YK,X,Y,IADJ,IEND, I1,I2,I3)
      IF (I1 .EQ. 0) GO TO 5
      IF (I3 .EQ. 0) CALL BDYADD(K,I1,I2, IADJ,IEND )
      IF (I3 .NE. 0) CALL INTADD(K,I1,I2,I3, IADJ,IEND )
C
C INITIALIZE VARIABLES FOR OPTIMIZATION OF THE MESH
C
      INDKF = IEND(KM1) + 1
      INDKL = IEND(K)
      NABOR1 = IADJ(INDKF)
      IO2 = NABOR1
      INDK1 = INDKF + 1
      IO1 = IADJ(INDK1)
C
C BEGIN LOOP -- FIND THE VERTEX OPPOSITE K
C
    1 IND2F = 1
      IF (IO2 .NE. 1) IND2F = IEND(IO2-1) + 1
      IND21 = TINDX(IO2,IO1,IADJ,IEND)
      IF (IND2F .EQ. IND21) GO TO 2
      IN1 = IADJ(IND21-1)
      GO TO 3
C
C IN1 IS THE LAST NEIGHBOR OF IO2
C
    2 IND21 = IEND(IO2)
      IN1 = IADJ(IND21)
      IF (IN1 .EQ. 0) GO TO 4
C
C SWAP TEST -- IF A SWAP OCCURS, TWO NEW ARCS ARE OPPOSITE K
C              AND MUST BE TESTED.  INDK1 AND INDKF MUST BE
C              DECREMENTED.
C
    3 IF ( .NOT. SWPTST(IN1,K,IO1,IO2,X,Y) ) GO TO 4
      CALL SWAPD (IN1,K,IO1,IO2, IADJ,IEND)
      IO1 = IN1
      INDK1 = INDK1 - 1
      INDKF = INDKF - 1
      GO TO 1
C
C NO SWAP OCCURRED.  RESET IO2 AND IO1, AND TEST FOR
C   TERMINATION.
C
    4 IF (IO1 .EQ. NABOR1) RETURN
      IO2 = IO1
      INDK1 = INDK1 + 1
      IF (INDK1 .GT. INDKL) INDK1 = INDKF
      IO1 = IADJ(INDK1)
      IF (IO1 .NE. 0) GO TO 1
      RETURN
C
C ALL NODES ARE COLLINEAR
C
    5 IER = 1
      RETURN
      END
      SUBROUTINE BDYADD (KK,I1,I2, IADJ,IEND )
      INTEGER KK, I1, I2, IADJ(*), IEND(KK)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS ROUTINE ADDS A BOUNDARY NODE TO A TRIANGULATION
C OF A SET OF KK-1 POINTS IN THE PLANE.  IADJ AND IEND ARE
C UPDATED WITH THE INSERTION OF NODE KK.
C
C INPUT PARAMETERS -   KK - INDEX OF AN EXTERIOR NODE TO BE
C                           ADDED.  KK .GE. 4.
C
C                      I1 - FIRST (RIGHTMOST AS VIEWED FROM
C                           KK) BOUNDARY NODE IN THE MESH
C                           WHICH IS VISIBLE FROM KK - THE
C                           LINE SEGMENT KK-I1 INTERSECTS
C                           NO ARCS.
C
C                      I2 - LAST (LEFTMOST) BOUNDARY NODE
C                           WHICH IS VISIBLE FROM KK.
C
C                    IADJ - SET OF ADJACENCY LISTS OF NODES
C                           IN THE MESH.
C
C                    IEND - POINTERS TO THE ENDS OF
C                           ADJACENCY LISTS IN IADJ FOR
C                           EACH NODE IN THE MESH.
C
C   IADJ AND IEND MAY BE CREATED BY TRMESH AND MUST CONTAIN
C THE VERTICES I1 AND I2.  I1 AND I2 MAY BE DETERMINED BY
C TRFIND.
C
C KK, I1, AND I2 ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETERS - IADJ,IEND - UPDATED WITH THE ADDITION
C                                 OF NODE KK AS THE LAST
C                                 ENTRY.  NODE KK WILL BE
C                                 CONNECTED TO I1, I2, AND
C                                 ALL BOUNDARY NODES BETWEEN
C                                 THEM.  NO OPTIMIZATION OF
C                                 THE MESH IS PERFORMED.
C
C MODULE REFERENCED BY BDYADD - SHIFTD
C
C INTRINSIC FUNCTIONS CALLED BY BDYADD - MIN0, MAX0
C
C***********************************************************
C
      INTEGER K, KM1, NRIGHT, NLEFT, NF, NL, N1, N2, I,
     .        IMIN, IMAX, KEND, NEXT, INDX
C
C LOCAL PARAMETERS -
C
C K =            LOCAL COPY OF KK
C KM1 =          K - 1
C NRIGHT,NLEFT = LOCAL COPIES OF I1, I2
C NF,NL =        INDICES OF IADJ BOUNDING THE PORTION OF THE
C                  ARRAY TO BE SHIFTED
C N1 =           IADJ INDEX OF THE FIRST NEIGHBOR OF NLEFT
C N2 =           IADJ INDEX OF THE LAST NEIGHBOR OF NRIGHT
C I =            DO-LOOP INDEX
C IMIN,IMAX =    BOUNDS ON DO-LOOP INDEX -- FIRST AND LAST
C                  ELEMENTS OF IEND TO BE INCREMENTED
C KEND =         POINTER TO THE LAST NEIGHBOR OF K IN IADJ
C NEXT =         NEXT BOUNDARY NODE TO BE CONNECTED TO KK
C INDX =         INDEX FOR IADJ
C
      K = KK
      KM1 = K - 1
      NRIGHT = I1
      NLEFT = I2
C
C INITIALIZE VARIABLES
C
      NL = IEND(KM1)
      N1 = 1
      IF (NLEFT .NE. 1) N1 = IEND(NLEFT-1) + 1
      N2 = IEND(NRIGHT)
      NF = MAX0(N1,N2)
C
C INSERT K AS A NEIGHBOR OF MAX(NRIGHT,NLEFT)
C
      CALL SHIFTD(NF,NL,2, IADJ )
      IADJ(NF+1) = K
      IMIN = MAX0(NRIGHT,NLEFT)
      DO 1 I = IMIN,KM1
        IEND(I) = IEND(I) + 2
    1   CONTINUE
C
C INITIALIZE KEND AND INSERT K AS A NEIGHBOR OF
C   MIN(NRIGHT,NLEFT)
C
      KEND = NL + 3
      NL = NF - 1
      NF = MIN0(N1,N2)
      CALL SHIFTD(NF,NL,1, IADJ )
      IADJ(NF) = K
      IMAX = IMIN - 1
      IMIN = MIN0(NRIGHT,NLEFT)
      DO 2 I = IMIN,IMAX
        IEND(I) = IEND(I) + 1
    2   CONTINUE
C
C INSERT NRIGHT AS THE FIRST NEIGHBOR OF K
C
      IADJ(KEND) = NRIGHT
C
C INITIALIZE INDX FOR LOOP ON BOUNDARY NODES BETWEEN NRIGHT
C   AND NLEFT
C
      INDX = IEND(NRIGHT) - 2
    3 NEXT = IADJ(INDX)
      IF (NEXT .EQ. NLEFT) GO TO 4
C
C CONNECT NEXT AND K
C
      KEND = KEND + 1
      IADJ(KEND) = NEXT
      INDX = IEND(NEXT)
      IADJ(INDX) = K
      INDX = INDX - 1
      GO TO 3
C
C INSERT NLEFT AND 0 AS THE LAST NEIGHBORS OF K
C
    4 IADJ(KEND+1) = NLEFT
      KEND = KEND + 2
      IADJ(KEND) = 0
      IEND(K) = KEND
      RETURN
      END
      SUBROUTINE INTADD (KK,I1,I2,I3, IADJ,IEND )
      INTEGER KK, I1, I2, I3, IADJ(*), IEND(KK)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS ROUTINE ADDS AN INTERIOR NODE TO A TRIANGULATION
C OF A SET OF KK-1 POINTS IN THE PLANE.  IADJ AND IEND ARE
C UPDATED WITH THE INSERTION OF NODE KK IN THE TRIANGLE
C WHOSE VERTICES ARE I1, I2, AND I3.
C
C INPUT PARAMETERS -        KK - INDEX OF NODE TO BE
C                                INSERTED.  KK .GE. 4.
C
C                     I1,I2,I3 - INDICES OF THE VERTICES OF
C                                A TRIANGLE CONTAINING NODE
C                                KK -- IN COUNTERCLOCKWISE
C                                ORDER.
C
C                         IADJ - SET OF ADJACENCY LISTS
C                                OF NODES IN THE MESH.
C
C                         IEND - POINTERS TO THE ENDS OF
C                                ADJACENCY LISTS IN IADJ FOR
C                                EACH NODE IN THE MESH.
C
C   IADJ AND IEND MAY BE CREATED BY TRMESH AND MUST CONTAIN
C THE VERTICES I1, I2, AND I3.  I1,I2,I3 MAY BE DETERMINED
C BY TRFIND.
C
C KK, I1, I2, AND I3 ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETERS - IADJ,IEND - UPDATED WITH THE ADDITION
C                                 OF NODE KK AS THE LAST
C                                 ENTRY.  NODE KK WILL BE
C                                 CONNECTED TO NODES I1, I2,
C                                 AND I3.  NO OPTIMIZATION
C                                 OF THE MESH IS PERFORMED.
C
C MODULE REFERENCED BY INTADD - SHIFTD
C
C INTRINSIC FUNCTION CALLED BY INTADD - MOD
C
C***********************************************************
C
      INTEGER K, KM1, N(3), NFT(3), IP1, IP2, IP3, INDX, NF,
     .        NL, N1, N2, IMIN, IMAX, I, ITEMP
C
C LOCAL PARAMETERS -
C
C K =           LOCAL COPY OF KK
C KM1 =         K - 1
C N =           VECTOR CONTAINING I1, I2, I3
C NFT =         POINTERS TO THE TOPS OF THE 3 SETS OF IADJ
C                 ELEMENTS TO BE SHIFTED DOWNWARD
C IP1,IP2,IP3 = PERMUTATION INDICES FOR N AND NFT
C INDX =        INDEX FOR IADJ AND N
C NF,NL =       INDICES OF FIRST AND LAST ENTRIES IN IADJ
C                 TO BE SHIFTED DOWN
C N1,N2 =       FIRST 2 VERTICES OF A NEW TRIANGLE --
C                 (N1,N2,KK)
C IMIN,IMAX =   BOUNDS ON DO-LOOP INDEX -- FIRST AND LAST
C                 ELEMENTS OF IEND TO BE INCREMENTED
C I =           DO-LOOP INDEX
C ITEMP =       TEMPORARY STORAGE LOCATION
C
      K = KK
C
C INITIALIZATION
C
      N(1) = I1
      N(2) = I2
      N(3) = I3
C
C SET UP NFT
C
      DO 2 I = 1,3
        N1 = N(I)
        INDX = MOD(I,3) + 1
        N2 = N(INDX)
        INDX = IEND(N1) + 1
C
C FIND THE INDEX OF N2 AS A NEIGHBOR OF N1
C
    1   INDX = INDX - 1
        IF (IADJ(INDX) .NE. N2) GO TO 1
        NFT(I) = INDX + 1
    2   CONTINUE
C
C ORDER THE VERTICES BY DECREASING MAGNITUDE.
C   N(IP(I+1)) PRECEDES N(IP(I)) IN IEND FOR
C   I = 1,2.
C
      IP1 = 1
      IP2 = 2
      IP3 = 3
      IF ( N(2) .LE. N(1) ) GO TO 3
      IP1 = 2
      IP2 = 1
    3 IF ( N(3) .LE. N(IP1) ) GO TO 4
      IP3 = IP1
      IP1 = 3
    4 IF ( N(IP3) .LE. N(IP2) )  GO TO 5
      ITEMP = IP2
      IP2 = IP3
      IP3 = ITEMP
C
C ADD NODE K TO THE ADJACENCY LISTS OF EACH VERTEX AND
C   UPDATE IEND.  FOR EACH VERTEX, A SET OF IADJ ELEMENTS
C   IS SHIFTED DOWNWARD AND K IS INSERTED.  SHIFTING STARTS
C   AT THE END OF THE ARRAY.
C
    5 KM1 = K - 1
      NL = IEND(KM1)
      NF = NFT(IP1)
      IF (NF .LE. NL) CALL SHIFTD(NF,NL,3, IADJ )
      IADJ(NF+2) = K
      IMIN = N(IP1)
      IMAX = KM1
      DO 6 I = IMIN,IMAX
        IEND(I) = IEND(I) + 3
    6   CONTINUE
C
      NL = NF - 1
      NF = NFT(IP2)
      CALL SHIFTD(NF,NL,2, IADJ )
      IADJ(NF+1) = K
      IMAX = IMIN - 1
      IMIN = N(IP2)
      DO 7 I = IMIN,IMAX
        IEND(I) = IEND(I) + 2
    7   CONTINUE
C
      NL = NF - 1
      NF = NFT(IP3)
      CALL SHIFTD(NF,NL,1, IADJ )
      IADJ(NF) = K
      IMAX = IMIN - 1
      IMIN = N(IP3)
      DO 8 I = IMIN,IMAX
        IEND(I) = IEND(I) + 1
    8   CONTINUE
C
C ADD NODE K TO IEND AND ITS NEIGHBORS TO IADJ
C
      INDX = IEND(KM1)
      IEND(K) = INDX + 3
      DO 9 I = 1,3
        INDX = INDX + 1
        IADJ(INDX) = N(I)
    9   CONTINUE
      RETURN
      END
      SUBROUTINE SHIFTD (NFRST,NLAST,KK, IARR )
      INTEGER NFRST, NLAST, KK, IARR(*)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS ROUTINE SHIFTS A SET OF CONTIGUOUS ELEMENTS OF AN
C INTEGER ARRAY KK POSITIONS DOWNWARD (UPWARD IF KK .LT. 0).
C THE LOOPS ARE UNROLLED IN ORDER TO INCREASE EFFICIENCY.
C
C INPUT PARAMETERS - NFRST,NLAST - BOUNDS ON THE PORTION OF
C                                  IARR TO BE SHIFTED.  ALL
C                                  ELEMENTS BETWEEN AND
C                                  INCLUDING THE BOUNDS ARE
C                                  SHIFTED UNLESS NFRST .GT.
C                                  NLAST, IN WHICH CASE NO
C                                  SHIFT OCCURS.
C
C                             KK - NUMBER OF POSITIONS EACH
C                                  ELEMENT IS TO BE SHIFTED.
C                                  IF KK .LT. 0 SHIFT UP.
C                                  IF KK .GT. 0 SHIFT DOWN.
C
C                           IARR - INTEGER ARRAY OF LENGTH
C                                  .GE. NLAST + MAX(KK,0).
C
C NFRST, NLAST, AND KK ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER -        IARR - SHIFTED ARRAY.
C
C MODULES REFERENCED BY SHIFTD - NONE
C
C***********************************************************
C
      INTEGER INC, K, NF, NL, NLP1, NS, NSL, I, IBAK, INDX,
     .        IMAX
      DATA    INC/5/
C
C LOCAL PARAMETERS -
C
C INC =  DO-LOOP INCREMENT (UNROLLING FACTOR) -- IF INC IS
C          CHANGED, STATEMENTS MUST BE ADDED TO OR DELETED
C          FROM THE DO-LOOPS
C K =    LOCAL COPY OF KK
C NF =   LOCAL COPY OF NFRST
C NL =   LOCAL COPY OF NLAST
C NLP1 = NL + 1
C NS =   NUMBER OF SHIFTS
C NSL =  NUMBER OF SHIFTS DONE IN UNROLLED DO-LOOP (MULTIPLE
C          OF INC)
C I =    DO-LOOP INDEX AND INDEX FOR IARR
C IBAK = INDEX FOR DOWNWARD SHIFT OF IARR
C INDX = INDEX FOR IARR
C IMAX = BOUND ON DO-LOOP INDEX
C
      K = KK
      NF = NFRST
      NL = NLAST
      IF (NF .GT. NL  .OR.  K .EQ. 0) RETURN
      NLP1 = NL + 1
      NS = NLP1 - NF
      NSL = INC*(NS/INC)
      IF ( K .LT. 0) GO TO 4
C
C SHIFT DOWNWARD STARTING FROM THE BOTTOM
C
      IF (NSL .LE. 0) GO TO 2
      DO 1 I = 1,NSL,INC
        IBAK = NLP1 - I
        INDX = IBAK + K
        IARR(INDX) = IARR(IBAK)
        IARR(INDX-1) = IARR(IBAK-1)
        IARR(INDX-2) = IARR(IBAK-2)
        IARR(INDX-3) = IARR(IBAK-3)
        IARR(INDX-4) = IARR(IBAK-4)
    1   CONTINUE
C
C PERFORM THE REMAINING NS-NSL SHIFTS ONE AT A TIME
C
    2 IBAK = NLP1 - NSL
    3 IF (IBAK .LE. NF) RETURN
      IBAK = IBAK - 1
      INDX = IBAK + K
      IARR(INDX) = IARR(IBAK)
      GO TO 3
C
C SHIFT UPWARD STARTING FROM THE TOP
C
    4 IF (NSL .LE. 0) GO TO 6
      IMAX = NLP1 - INC
      DO 5 I = NF,IMAX,INC
        INDX = I + K
        IARR(INDX) = IARR(I)
        IARR(INDX+1) = IARR(I+1)
        IARR(INDX+2) = IARR(I+2)
        IARR(INDX+3) = IARR(I+3)
        IARR(INDX+4) = IARR(I+4)
    5   CONTINUE
C
C PERFORM THE REMAINING NS-NSL SHIFTS ONE AT A TIME
C
    6 I = NSL + NF
    7 IF (I .GT. NL) RETURN
      INDX = I + K
      IARR(INDX) = IARR(I)
      I = I + 1
      GO TO 7
      END
      SUBROUTINE SWAPD (NIN1,NIN2,NOUT1,NOUT2, IADJ,IEND)
      INTEGER NIN1, NIN2, NOUT1, NOUT2, IADJ(*), IEND(*)
      INTEGER TINDX
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS SUBROUTINE SWAPS THE DIAGONALS IN A CONVEX QUADRI-
C LATERAL.
C
C INPUT PARAMETERS -  NIN1,NIN2,NOUT1,NOUT2 - NODAL INDICES
C                            OF A PAIR OF ADJACENT TRIANGLES
C                            WHICH FORM A CONVEX QUADRILAT-
C                            ERAL.  NOUT1 AND NOUT2 ARE CON-
C                            NECTED BY AN ARC WHICH IS TO BE
C                            REPLACED BY THE ARC NIN1-NIN2.
C                            (NIN1,NOUT1,NOUT2) MUST BE TRI-
C                            ANGLE VERTICES IN COUNTERCLOCK-
C                            WISE ORDER.
C
C THE ABOVE PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C                IADJ,IEND - TRIANGULATION DATA STRUCTURE
C                            (SEE SUBROUTINE TRMESH).
C
C OUTPUT PARAMETERS - IADJ,IEND - UPDATED WITH THE ARC
C                                 REPLACEMENT.
C
C MODULES REFERENCED BY SWAPD - TINDX, SHIFTD
C
C***********************************************************
C
      INTEGER IN(2), IO(2), IP1, IP2, J, K, NF, NL, I,
     .        IMIN, IMAX
C
C LOCAL PARAMETERS -
C
C IN =        NIN1 AND NIN2 ORDERED BY INCREASING MAGNITUDE
C               (THE NEIGHBORS OF IN(1) PRECEDE THOSE OF
C               IN(2) IN IADJ)
C IO =        NOUT1 AND NOUT2 IN INCREASING ORDER
C IP1,IP2 =   PERMUTATION OF (1,2) SUCH THAT IO(IP1)
C               PRECEDES IO(IP2) AS A NEIGHBOR OF IN(1)
C J,K =       PERMUTATION OF (1,2) USED AS INDICES OF IN
C               AND IO
C NF,NL =     IADJ INDICES BOUNDARY A PORTION OF THE ARRAY
C               TO BE SHIFTED
C I =         IEND INDEX
C IMIN,IMAX = BOUNDS ON THE PORTION OF IEND TO BE INCRE-
C               MENTED OR DECREMENTED
C
      IN(1) = NIN1
      IN(2) = NIN2
      IO(1) = NOUT1
      IO(2) = NOUT2
      IP1 = 1
C
C ORDER THE INDICES SO THAT IN(1) .LT. IN(2) AND IO(1) .LT.
C   IO(2), AND CHOOSE IP1 AND IP2 SUCH THAT (IN(1),IO(IP1),
C   IO(IP2)) FORMS A TRIANGLE.
C
      IF (IN(1) .LT. IN(2)) GO TO 1
      IN(1) = IN(2)
      IN(2) = NIN1
      IP1 = 2
    1 IF (IO(1) .LT. IO(2)) GO TO 2
      IO(1) = IO(2)
      IO(2) = NOUT1
      IP1 = 3 - IP1
    2 IP2 = 3 - IP1
      IF (IO(2) .LT. IN(1)) GO TO 8
      IF (IN(2) .LT. IO(1)) GO TO 12
C
C IN(1) AND IO(1) PRECEDE IN(2) AND IO(2).  FOR (J,K) =
C   (1,2) AND (2,1), DELETE IO(K) AS A NEIGHBOR OF IO(J)
C   BY SHIFTING A PORTION OF IADJ EITHER UP OR DOWN AND
C   AND INSERT IN(K) AS A NEIGHBOR OF IN(J).
C
      DO 7 J = 1,2
        K = 3 - J
        IF (IN(J) .GT. IO(J)) GO TO 4
C
C   THE NEIGHBORS OF IN(J) PRECEDE THOSE OF IO(J) -- SHIFT
C     DOWN BY 1
C
        NF = 1 + TINDX(IN(J),IO(IP1),IADJ,IEND)
        NL = -1 + TINDX(IO(J),IO(K),IADJ,IEND)
        IF (NF .LE. NL) CALL SHIFTD(NF,NL,1, IADJ )
        IADJ(NF) = IN(K)
        IMIN = IN(J)
        IMAX = IO(J)-1
        DO 3 I = IMIN,IMAX
    3     IEND(I) = IEND(I) + 1
        GO TO 6
C
C   THE NEIGHBORS OF IO(J) PRECEDE THOSE OF IN(J) -- SHIFT
C     UP BY 1
C
    4   NF = 1 + TINDX(IO(J),IO(K),IADJ,IEND)
        NL = -1 + TINDX(IN(J),IO(IP2),IADJ,IEND)
        IF (NF .LE. NL) CALL SHIFTD(NF,NL,-1, IADJ )
        IADJ(NL) = IN(K)
        IMIN = IO(J)
        IMAX = IN(J) - 1
        DO 5 I = IMIN,IMAX
    5     IEND(I) = IEND(I) - 1
C
C   REVERSE (IP1,IP2) FOR (J,K) = (2,1)
C
    6   IP1 = IP2
        IP2 = 3 - IP1
    7   CONTINUE
      RETURN
C
C THE VERTICES ARE ORDERED (IO(1),IO(2),IN(1),IN(2)).
C   DELETE IO(2) BY SHIFTING UP BY 1
C
    8 NF = 1 + TINDX(IO(1),IO(2),IADJ,IEND)
      NL = -1 + TINDX(IO(2),IO(1),IADJ,IEND)
      IF (NF .LE. NL) CALL SHIFTD(NF,NL,-1, IADJ )
      IMIN = IO(1)
      IMAX = IO(2)-1
      DO 9 I = IMIN,IMAX
    9   IEND(I) = IEND(I) - 1
C
C   DELETE IO(1) BY SHIFTING UP BY 2 AND INSERT IN(2)
C
      NF = NL + 2
      NL = -1 + TINDX(IN(1),IO(IP2),IADJ,IEND)
      IF (NF .LE. NL) CALL SHIFTD(NF,NL,-2, IADJ )
      IADJ(NL-1) = IN(2)
      IMIN = IO(2)
      IMAX = IN(1)-1
      DO 10 I = IMIN,IMAX
   10   IEND(I) = IEND(I) - 2
C
C   SHIFT UP BY 1 AND INSERT IN(1)
C
      NF = NL + 1
      NL = -1 + TINDX(IN(2),IO(IP1),IADJ,IEND)
      CALL SHIFTD(NF,NL,-1, IADJ )
      IADJ(NL) = IN(1)
      IMIN = IN(1)
      IMAX = IN(2)-1
      DO 11 I = IMIN,IMAX
   11   IEND(I) = IEND(I) - 1
      RETURN
C
C THE VERTICES ARE ORDERED (IN(1),IN(2),IO(1),IO(2)).
C   DELETE IO(1) BY SHIFTING DOWN BY 1
C
   12 NF = 1 + TINDX(IO(1),IO(2),IADJ,IEND)
      NL = -1 + TINDX(IO(2),IO(1),IADJ,IEND)
      IF (NF .LE. NL) CALL SHIFTD(NF,NL,1, IADJ )
      IMIN = IO(1)
      IMAX = IO(2) - 1
      DO 13 I = IMIN,IMAX
   13   IEND(I) = IEND(I) + 1
C
C   DELETE IO(2) BY SHIFTING DOWN BY 2 AND INSERT IN(1)
C
      NL = NF - 2
      NF = 1 + TINDX(IN(2),IO(IP2),IADJ,IEND)
      IF (NF .LE. NL) CALL SHIFTD(NF,NL,2, IADJ )
      IADJ(NF+1) = IN(1)
      IMIN = IN(2)
      IMAX = IO(1) - 1
      DO 14 I = IMIN,IMAX
   14   IEND(I) = IEND(I) + 2
C
C   SHIFT DOWN BY 1 AND INSERT IN(2)
C
      NL = NF - 1
      NF = 1 + TINDX(IN(1),IO(IP1),IADJ,IEND)
      CALL SHIFTD(NF,NL,1, IADJ )
      IADJ(NF) = IN(2)
      IMIN = IN(1)
      IMAX = IN(2) - 1
      DO 15 I = IMIN,IMAX
   15   IEND(I) = IEND(I) + 1
      RETURN
      END
      LOGICAL FUNCTION SWPTST (IN1,IN2,IO1,IO2,X,Y)
      INTEGER IN1, IN2, IO1, IO2
      REAL    X(*), Y(*)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS FUNCTION DECIDES WHETHER OR NOT TO REPLACE A
C DIAGONAL ARC IN A QUADRILATERAL WITH THE OTHER DIAGONAL.
C THE DETERMINATION IS BASED ON THE SIZES OF THE ANGLES
C CONTAINED IN THE 2 TRIANGLES DEFINED BY THE DIAGONAL.
C THE DIAGONAL IS CHOSEN TO MAXIMIZE THE SMALLEST OF THE
C SIX ANGLES OVER THE TWO PAIRS OF TRIANGLES.
C
C INPUT PARAMETERS -  IN1,IN2,IO1,IO2 - NODE INDICES OF THE
C                              FOUR POINTS DEFINING THE
C                              QUADRILATERAL.  IO1 AND IO2
C                              ARE CURRENTLY CONNECTED BY A
C                              DIAGONAL ARC.  THIS ARC
C                              SHOULD BE REPLACED BY AN ARC
C                              CONNECTING IN1, IN2 IF THE
C                              DECISION IS MADE TO SWAP.
C                              IN1,IO1,IO2 MUST BE IN
C                              COUNTERCLOCKWISE ORDER.
C
C                        X,Y - VECTORS OF NODAL COORDINATES.
C                              (X(I),Y(I)) ARE THE COORD-
C                              INATES OF NODE I FOR I = IN1,
C                              IN2, IO1, OR IO2.
C
C NONE OF THE INPUT PARAMETERS ARE ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER -  SWPTST - .TRUE. IFF THE ARC CONNECTING
C                              IO1 AND IO2 IS TO BE REPLACED
C
C MODULES REFERENCED BY SWPTST - NONE
C
C***********************************************************
C
      REAL DX11, DX12, DX22, DX21, DY11, DY12, DY22, DY21,
     .     SIN1, SIN2, COS1, COS2, SIN12
C
C LOCAL PARAMETERS -
C
C DX11,DY11 = X,Y COORDINATES OF THE VECTOR IN1-IO1
C DX12,DY12 = X,Y COORDINATES OF THE VECTOR IN1-IO2
C DX22,DY22 = X,Y COORDINATES OF THE VECTOR IN2-IO2
C DX21,DY21 = X,Y COORDINATES OF THE VECTOR IN2-IO1
C SIN1 =      CROSS PRODUCT OF THE VECTORS IN1-IO1 AND
C               IN1-IO2 -- PROPORTIONAL TO SIN(T1) WHERE T1
C               IS THE ANGLE AT IN1 FORMED BY THE VECTORS
C COS1 =      INNER PRODUCT OF THE VECTORS IN1-IO1 AND
C               IN1-IO2 -- PROPORTIONAL TO COS(T1)
C SIN2 =      CROSS PRODUCT OF THE VECTORS IN2-IO2 AND
C               IN2-IO1 -- PROPORTIONAL TO SIN(T2) WHERE T2
C               IS THE ANGLE AT IN2 FORMED BY THE VECTORS
C COS2 =      INNER PRODUCT OF THE VECTORS IN2-IO2 AND
C               IN2-IO1 -- PROPORTIONAL TO COS(T2)
C SIN12 =     SIN1*COS2 + COS1*SIN2 -- PROPORTIONAL TO
C               SIN(T1+T2)
C
      SWPTST = .FALSE.
C
C COMPUTE THE VECTORS CONTAINING THE ANGLES T1, T2
C
      DX11 = X(IO1) - X(IN1)
      DX12 = X(IO2) - X(IN1)
      DX22 = X(IO2) - X(IN2)
      DX21 = X(IO1) - X(IN2)
C
      DY11 = Y(IO1) - Y(IN1)
      DY12 = Y(IO2) - Y(IN1)
      DY22 = Y(IO2) - Y(IN2)
      DY21 = Y(IO1) - Y(IN2)
C
C COMPUTE INNER PRODUCTS
C
      COS1 = DX11*DX12 + DY11*DY12
      COS2 = DX22*DX21 + DY22*DY21
C
C THE DIAGONALS SHOULD BE SWAPPED IFF (T1+T2) .GT. 180
C   DEGREES.  THE FOLLOWING TWO TESTS INSURE NUMERICAL
C   STABILITY.
C
      IF (COS1 .GE. 0.  .AND.  COS2 .GE. 0.) RETURN
      IF (COS1 .LT. 0.  .AND.  COS2 .LT. 0.) GO TO 1
C
C COMPUTE VECTOR CROSS PRODUCTS
C
      SIN1 = DX11*DY12 - DX12*DY11
      SIN2 = DX22*DY21 - DX21*DY22
      SIN12 = SIN1*COS2 + COS1*SIN2
      IF (SIN12 .GE. 0.) RETURN
    1 SWPTST = .TRUE.
      RETURN
      END
      INTEGER FUNCTION TINDX (NVERTX,NABOR,IADJ,IEND)
      INTEGER NVERTX, NABOR, IADJ(*), IEND(*)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS FUNCTION RETURNS THE INDEX OF NABOR IN THE
C ADJACENCY LIST FOR NVERTX.
C
C INPUT PARAMETERS - NVERTX - NODE WHOSE ADJACENCY LIST IS
C                             TO BE SEARCHED.
C
C                     NABOR - NODE WHOSE INDEX IS TO BE
C                             RETURNED.  NABOR MUST BE
C                             CONNECTED TO NVERTX.
C
C                      IADJ - SET OF ADJACENCY LISTS.
C
C                      IEND - POINTERS TO THE ENDS OF
C                             ADJACENCY LISTS IN IADJ.
C
C INPUT PARAMETERS ARE NOT ALTERED BY THIS FUNCTION.
C
C OUTPUT PARAMETER -  TINDX - IADJ(TINDX) = NABOR.
C
C MODULES REFERENCED BY TINDX - NONE
C
C***********************************************************
C
      INTEGER NB, INDX
C
C LOCAL PARAMETERS -
C
C NB =   LOCAL COPY OF NABOR
C INDX = INDEX FOR IADJ
C
      NB = NABOR
C
C INITIALIZATION
C
      INDX = IEND(NVERTX) + 1
C
C SEARCH THE LIST OF NVERTX NEIGHBORS FOR NB
C
    1 INDX = INDX - 1
      IF (IADJ(INDX) .NE. NB) GO TO 1
C
      TINDX = INDX
      RETURN
      END
      SUBROUTINE TRFIND (NST,PX,PY,X,Y,IADJ,IEND, I1,I2,I3)
      INTEGER NST, IADJ(*), IEND(*), I1, I2, I3
      REAL    PX, PY, X(*), Y(*)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS ROUTINE LOCATES A POINT P IN A THIESSEN TRIANGU-
C LATION, RETURNING THE VERTEX INDICES OF A TRIANGLE WHICH
C CONTAINS P.  TRFIND IS PART OF AN INTERPOLATION PACKAGE
C WHICH PROVIDES SUBROUTINES FOR CREATING THE MESH.
C
C INPUT PARAMETERS -    NST - INDEX OF NODE AT WHICH TRFIND
C                             BEGINS SEARCH.  SEARCH TIME
C                             DEPENDS ON THE PROXIMITY OF
C                             NST TO P.
C
C                     PX,PY - X AND Y-COORDINATES OF THE
C                             POINT TO BE LOCATED.
C
C                       X,Y - VECTORS OF COORDINATES OF
C                             NODES IN THE MESH.  (X(I),Y(I))
C                             DEFINES NODE I FOR I = 1,...,N
C                             WHERE N .GE. 3.
C
C                      IADJ - SET OF ADJACENCY LISTS OF
C                             NODES IN THE MESH.
C
C                      IEND - POINTERS TO THE ENDS OF
C                             ADJACENCY LISTS IN IADJ FOR
C                             EACH NODE IN THE MESH.
C
C IADJ AND IEND MAY BE CREATED BY TRMESH.
C
C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETERS - I1,I2,I3 - VERTEX INDICES IN COUNTER-
C                                CLOCKWISE ORDER - VERTICES
C                                OF A TRIANGLE CONTAINING P
C                                IF P IS AN INTERIOR NODE.
C                                IF P IS OUTSIDE OF THE
C                                BOUNDARY OF THE MESH, I1
C                                AND I2 ARE THE FIRST (RIGHT
C                                -MOST) AND LAST (LEFTMOST)
C                                NODES WHICH ARE VISIBLE
C                                FROM P, AND I3 = 0.  IF P
C                                AND ALL OF THE NODES LIE ON
C                                A SINGLE LINE THEN I1 = I2
C                                = I3 = 0.
C
C MODULES REFERENCED BY TRFIND - NONE
C
C INTRINSIC FUNCTION CALLED BY TRFIND - MAX0
C
C***********************************************************
C
      INTEGER N0, N1, N2, N3, N4, INDX, IND, NF,
     .        NL, NEXT
      REAL    XP, YP
      LOGICAL LEFT
C
C LOCAL PARAMETERS -
C
C XP,YP =     LOCAL VARIABLES CONTAINING PX AND PY
C N0,N1,N2 =  NODES IN COUNTERCLOCKWISE ORDER DEFINING A
C               CONE (WITH VERTEX N0) CONTAINING P
C N3,N4 =     NODES OPPOSITE N1-N2 AND N2-N1, RESPECTIVELY
C INDX,IND =  INDICES FOR IADJ
C NF,NL =     FIRST AND LAST NEIGHBORS OF N0 IN IADJ, OR
C               FIRST (RIGHTMOST) AND LAST (LEFTMOST) NODES
C               VISIBLE FROM P WHEN P IS OUTSIDE THE
C               BOUNDARY
C NEXT =      CANDIDATE FOR I1 OR I2 WHEN P IS OUTSIDE OF
C               THE BOUNDARY
C LEFT =      STATEMENT FUNCTION WHICH COMPUTES THE SIGN OF
C               A CROSS PRODUCT (Z-COMPONENT).  LEFT(X1,...,
C               Y0) = .TRUE. IFF (X0,Y0) IS ON OR TO THE
C               LEFT OF THE VECTOR FROM (X1,Y1) TO (X2,Y2).
C
      LEFT(X1,Y1,X2,Y2,X0,Y0) = (X2-X1)*(Y0-Y1) .GE.
     .                          (X0-X1)*(Y2-Y1)
      XP = PX
      YP = PY
C
C INITIALIZE VARIABLES AND FIND A CONE CONTAINING P
C
      N0 = MAX0(NST,1)
    1 INDX = IEND(N0)
      NL = IADJ(INDX)
      INDX = 1
      IF (N0 .NE. 1) INDX = IEND(N0-1) + 1
      NF = IADJ(INDX)
      N1 = NF
      IF (NL .NE. 0) GO TO 3
C
C N0 IS A BOUNDARY NODE.  SET NL TO THE LAST NONZERO
C   NEIGHBOR OF N0.
C
      IND = IEND(N0) - 1
      NL = IADJ(IND)
      IF ( LEFT(X(N0),Y(N0),X(NF),Y(NF),XP,YP) ) GO TO 2
C
C P IS OUTSIDE THE BOUNDARY
C
      NL = N0
      GO TO 16
    2 IF ( LEFT(X(NL),Y(NL),X(N0),Y(N0),XP,YP) ) GO TO 4
C
C P IS OUTSIDE THE BOUNDARY AND N0 IS THE RIGHTMOST
C   VISIBLE BOUNDARY NODE
C
      I1 = N0
      GO TO 18
C
C N0 IS AN INTERIOR NODE.  FIND N1.
C
    3 IF ( LEFT(X(N0),Y(N0),X(N1),Y(N1),XP,YP) ) GO TO 4
      INDX = INDX + 1
      N1 = IADJ(INDX)
      IF (N1 .EQ. NL) GO TO 7
      GO TO 3
C
C P IS TO THE LEFT OF ARC N0-N1.  INITIALIZE N2 TO THE NEXT
C   NEIGHBOR OF N0.
C
    4 INDX = INDX + 1
      N2 = IADJ(INDX)
      IF ( .NOT. LEFT(X(N0),Y(N0),X(N2),Y(N2),XP,YP) )
     .   GO TO 8
      N1 = N2
      IF (N1 .NE. NL) GO TO 4
      IF ( .NOT. LEFT(X(N0),Y(N0),X(NF),Y(NF),XP,YP) )
     .   GO TO 7
      IF (XP .EQ. X(N0) .AND. YP .EQ. Y(N0)) GO TO 6
C
C P IS LEFT OF OR ON ARCS N0-NB FOR ALL NEIGHBORS NB
C   OF N0.
C ALL POINTS ARE COLLINEAR IFF P IS LEFT OF NB-N0 FOR
C   ALL NEIGHBORS NB OF N0.  SEARCH THE NEIGHBORS OF N0
C   IN REVERSE ORDER.  NOTE -- N1 = NL AND INDX POINTS TO
C   NL.
C
    5 IF ( .NOT. LEFT(X(N1),Y(N1),X(N0),Y(N0),XP,YP) )
     .   GO TO 6
      IF (N1 .EQ. NF) GO TO 20
      INDX = INDX - 1
      N1 = IADJ(INDX)
      GO TO 5
C
C P IS TO THE RIGHT OF N1-N0, OR P=N0.  SET N0 TO N1 AND
C   START OVER.
C
    6 N0 = N1
      GO TO 1
C
C P IS BETWEEN ARCS N0-N1 AND N0-NF
C
    7 N2 = NF
C
C P IS CONTAINED IN A CONE DEFINED BY LINE SEGMENTS N0-N1
C   AND N0-N2 WHERE N1 IS ADJACENT TO N2
C
    8 N3 = N0
    9 IF ( LEFT(X(N1),Y(N1),X(N2),Y(N2),XP,YP) ) GO TO 13
C
C SET N4 TO THE FIRST NEIGHBOR OF N2 FOLLOWING N1
C
      INDX = IEND(N2)
      IF (IADJ(INDX) .NE. N1) GO TO 10
C
C N1 IS THE LAST NEIGHBOR OF N2.
C SET N4 TO THE FIRST NEIGHBOR.
C
      INDX = 1
      IF (N2 .NE. 1) INDX = IEND(N2-1) + 1
      N4 = IADJ(INDX)
      GO TO 11
C
C N1 IS NOT THE LAST NEIGHBOR OF N2
C
   10 INDX = INDX-1
      IF (IADJ(INDX) .NE. N1) GO TO 10
      N4 = IADJ(INDX+1)
      IF (N4 .NE. 0) GO TO 11
C
C P IS OUTSIDE THE BOUNDARY
C
      NF = N2
      NL = N1
      GO TO 16
C
C DEFINE A NEW ARC N1-N2 WHICH INTERSECTS THE LINE
C   SEGMENT N0-P
C
   11 IF ( LEFT(X(N0),Y(N0),X(N4),Y(N4),XP,YP) ) GO TO 12
      N3 = N2
      N2 = N4
      GO TO 9
   12 N3 = N1
      N1 = N4
      GO TO 9
C
C P IS IN THE TRIANGLE (N1,N2,N3) AND NOT ON N2-N3.  IF
C   N3-N1 OR N1-N2 IS A BOUNDARY ARC CONTAINING P, TREAT P
C   AS EXTERIOR.
C
   13 INDX = IEND(N1)
      IF (IADJ(INDX) .NE. 0) GO TO 15
C
C N1 IS A BOUNDARY NODE.  N3-N1 IS A BOUNDARY ARC IFF N3
C   IS THE LAST NONZERO NEIGHBOR OF N1.
C
      IF (N3 .NE. IADJ(INDX-1)) GO TO 14
C
C N3-N1 IS A BOUNDARY ARC
C
      IF ( .NOT. LEFT(X(N1),Y(N1),X(N3),Y(N3),XP,YP) )
     .   GO TO 14
C
C P LIES ON N1-N3
C
      I1 = N1
      I2 = N3
      I3 = 0
      RETURN
C
C N3-N1 IS NOT A BOUNDARY ARC CONTAINING P.  N1-N2 IS A
C   BOUNDARY ARC IFF N2 IS THE FIRST NEIGHBOR OF N1.
C
   14 INDX = 1
      IF (N1 .NE. 1) INDX = IEND(N1-1) + 1
      IF (N2 .NE. IADJ(INDX)) GO TO 15
C
C N1-N2 IS A BOUNDARY ARC
C
      IF ( .NOT. LEFT(X(N2),Y(N2),X(N1),Y(N1),XP,YP) )
     .   GO TO 15
C
C P LIES ON N1-N2
C
      I1 = N2
      I2 = N1
      I3 = 0
      RETURN
C
C P DOES NOT LIE ON A BOUNDARY ARC.
C
   15 I1 = N1
      I2 = N2
      I3 = N3
      RETURN
C
C NF AND NL ARE ADJACENT BOUNDARY NODES WHICH ARE VISIBLE
C   FROM P.  FIND THE FIRST VISIBLE BOUNDARY NODE.
C SET NEXT TO THE FIRST NEIGHBOR OF NF.
C
   16 INDX = 1
      IF (NF .NE. 1) INDX = IEND(NF-1) + 1
      NEXT = IADJ(INDX)
      IF ( LEFT(X(NF),Y(NF),X(NEXT),Y(NEXT),XP,YP) )
     .   GO TO 17
      NF = NEXT
      GO TO 16
C
C NF IS THE FIRST (RIGHTMOST) VISIBLE BOUNDARY NODE
C
   17 I1 = NF
C
C FIND THE LAST VISIBLE BOUNDARY NODE.  NL IS THE FIRST
C   CANDIDATE FOR I2.
C SET NEXT TO THE LAST NEIGHBOR OF NL.
C
   18 INDX = IEND(NL) - 1
      NEXT = IADJ(INDX)
      IF ( LEFT(X(NEXT),Y(NEXT),X(NL),Y(NL),XP,YP) )
     .   GO TO 19
      NL = NEXT
      GO TO 18
C
C NL IS THE LAST (LEFTMOST) VISIBLE BOUNDARY NODE
C
   19 I2 = NL
      I3 = 0
      RETURN
C
C ALL POINTS ARE COLLINEAR
C
   20 I1 = 0
      I2 = 0
      I3 = 0
      RETURN
      END
      SUBROUTINE GRADG (N, X, Y, Z, IADJ, IEND, ZXZY, IERR)
C-----------------------------------------------------------------------
C                      DERIVATIVE ESTIMATION
C-----------------------------------------------------------------------
      REAL X(N), Y(N), Z(N), ZXZY(2,N)
      INTEGER IADJ(*), IEND(N)
C
      IF (N .LT. 3) GO TO 20
C
      EPS = 0.0
      MITER = 5
      DO 10 J = 1,N
         ZXZY(1,J) = 0.0
         ZXZY(2,J) = 0.0
   10 CONTINUE
      CALL GRADG1 (N, X, Y, Z, IADJ, IEND, EPS, MITER, ZXZY, IERR)
      IERR = 0
      RETURN
C
C     ERROR RETURN
C
   20 IERR = 1
      RETURN
      END
      SUBROUTINE GRADG1 (N,X,Y,Z,IADJ,IEND,EPS, NIT,
     .                   ZXZY, IER)
      INTEGER N, IADJ(*), IEND(N), NIT, IER
      REAL    X(N), Y(N), Z(N), EPS, ZXZY(2,N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   GIVEN A TRIANGULATION OF N NODES IN THE PLANE WITH
C ASSOCIATED DATA VALUES, THIS ROUTINE USES A GLOBAL METHOD
C TO COMPUTE ESTIMATED GRADIENTS AT THE NODES.  THE METHOD
C CONSISTS OF MINIMIZING A QUADRATIC FUNCTIONAL Q(G) OVER
C THE N-VECTOR G OF GRADIENTS WHERE Q APPROXIMATES THE LIN-
C EARIZED CURVATURE OF AN INTERPOLANT F OVER THE TRIANGULA-
C TION.  THE RESTRICTION OF F TO AN ARC OF THE TRIANGULATION
C IS TAKEN TO BE THE HERMITE CUBIC INTERPOLANT OF THE DATA
C VALUES AND TANGENTIAL GRADIENT COMPONENTS AT THE END-
C POINTS OF THE ARC, AND Q IS THE SUM OF THE LINEARIZED
C CURVATURES OF F ALONG THE ARCS -- THE INTEGRALS OVER THE
C ARCS OF D2F(T)**2 WHERE D2F(T) IS THE SECOND DERIVATIVE
C OF F WITH RESPECT TO DISTANCE T ALONG THE ARC.  THIS MIN-
C IMIZATION PROBLEM CORRESPONDS TO AN ORDER 2N SYMMETRIC
C POSITIVE-DEFINITE SPARSE LINEAR SYSTEM WHICH IS SOLVED FOR
C THE X AND Y PARTIAL DERIVATIVES BY THE BLOCK GAUSS-SEIDEL
C METHOD WITH 2 BY 2 BLOCKS.
C   AN ALTERNATIVE METHOD, SUBROUTINE GRADL, COMPUTES A
C LOCAL APPROXIMATION TO THE PARTIALS AT A SINGLE NODE AND
C MAY BE MORE ACCURATE, DEPENDING ON THE DATA VALUES AND
C DISTRIBUTION OF NODES (NEITHER METHOD EMERGED AS SUPERIOR
C IN TESTS FOR ACCURACY).  HOWEVER, IN TESTS RUN ON AN IBM
C 370, GRADG1 WAS FOUND TO BE ABOUT 3.6 TIMES AS FAST FOR
C NIT = 4.
C
C INPUT PARAMETERS - N - NUMBER OF NODES.  N .GE. 3.
C
C                  X,Y - CARTESIAN COORDINATES OF THE NODES.
C
C                    Z - DATA VALUES AT THE NODES.  Z(I) IS
C                        ASSOCIATED WITH (X(I),Y(I)).
C
C            IADJ,IEND - DATA STRUCTURE DEFINING THE TRIAN-
C                        GULATION.  SEE SUBROUTINE TRMESH.
C
C                  EPS - NONNEGATIVE CONVERGENCE CRITERION.
C                        THE METHOD IS TERMINATED WHEN THE
C                        MAXIMUM CHANGE IN A GRADIENT COMPO-
C                        NENT BETWEEN ITERATIONS IS AT MOST
C                        EPS.  EPS = 1.E-2 IS SUFFICIENT FOR
C                        EFFECTIVE CONVERGENCE.
C
C THE ABOVE PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C                  NIT - MAXIMUM NUMBER OF GAUSS-SEIDEL
C                        ITERATIONS TO BE APPLIED.  THIS
C                        MAXIMUM WILL LIKELY BE ACHIEVED IF
C                        EPS IS SMALLER THAN THE MACHINE
C                        PRECISION.  OPTIMAL EFFICIENCY WAS
C                        ACHIEVED IN TESTING WITH EPS = 0
C                        AND NIT = 3 OR 4.
C
C                 ZXZY - 2 BY N ARRAY WHOSE COLUMNS CONTAIN
C                        INITIAL ESTIMATES OF THE PARTIAL
C                        DERIVATIVES (ZERO VECTORS ARE
C                        SUFFICIENT).
C
C OUTPUT PARAMETERS - NIT - NUMBER OF GAUSS-SEIDEL ITERA-
C                           TIONS EMPLOYED.
C
C                    ZXZY - ESTIMATED X AND Y PARTIAL DERIV-
C                           ATIVES AT THE NODES WITH X PAR-
C                           TIALS IN THE FIRST ROW.  ZXZY IS
C                           NOT CHANGED IF IER = 2.
C
C                     IER - ERROR INDICATOR
C                           IER = 0 IF THE CONVERGENCE CRI-
C                                   TERION WAS ACHIEVED.
C                           IER = 1 IF CONVERGENCE WAS NOT
C                                   ACHIEVED WITHIN NIT
C                                   ITERATIONS.
C                           IER = 2 IF N OR EPS IS OUT OF
C                                   RANGE OR NIT .LT. 0 ON
C                                   INPUT.
C
C MODULES REFERENCED BY GRADG1 - NONE
C
C INTRINSIC FUNCTIONS CALLED BY GRADG1 - SQRT, AMAX1, ABS
C
C***********************************************************
C
      INTEGER NN, MAXIT, ITER, K, INDF, INDL, INDX, NB
      REAL    TOL, DGMAX, XK, YK, ZK, ZXK, ZYK, A11, A12,
     .        A22, R1, R2, DELX, DELY, DELXS, DELYS, DSQ,
     .        DCUB, T, DZX, DZY
C
C LOCAL PARAMETERS -
C
C NN =          LOCAL COPY OF N
C MAXIT =       INPUT VALUE OF NIT
C ITER =        NUMBER OF ITERATIONS USED
C K =           DO-LOOP AND NODE INDEX
C INDF,INDL =   IADJ INDICES OF THE FIRST AND LAST NEIGHBORS
C                 OF K
C INDX =        IADJ INDEX IN THE RANGE INDF,...,INDL
C NB =          NEIGHBOR OF K
C TOL =         LOCAL COPY OF EPS
C DGMAX =       MAXIMUM CHANGE IN A GRADIENT COMPONENT BE-
C                 TWEEN ITERATIONS
C XK,YK,ZK =    X(K), Y(K), Z(K)
C ZXK,ZYK =     INITIAL VALUES OF ZXZY(1,K) AND ZXZY(2,K)
C A11,A12,A22 = MATRIX COMPONENTS OF THE 2 BY 2 BLOCK A*DG
C                 = R WHERE A IS SYMMETRIC, DG = (DZX,DZY)
C                 IS THE CHANGE IN THE GRADIENT AT K, AND R
C                 IS THE RESIDUAL
C R1,R2 =       COMPONENTS OF THE RESIDUAL -- DERIVATIVES OF
C                 Q WITH RESPECT TO THE COMPONENTS OF THE
C                 GRADIENT AT NODE K
C DELX,DELY =   COMPONENTS OF THE ARC NB-K
C DELXS,DELYS = DELX**2, DELY**2
C DSQ =         SQUARE OF THE DISTANCE D BETWEEN K AND NB
C DCUB =        D**3
C T =           FACTOR OF R1 AND R2
C DZX,DZY =     SOLUTION OF THE 2 BY 2 SYSTEM -- CHANGE IN
C                 DERIVATIVES AT K FROM THE PREVIOUS ITERATE
C
      NN = N
      TOL = EPS
      MAXIT = NIT
C
C ERROR CHECKS AND INITIALIZATION
C
      IF (NN .LT. 3  .OR.  TOL .LT. 0.  .OR.  MAXIT .LT. 0)
     .   GO TO 5
      ITER = 0
C
C TOP OF ITERATION LOOP
C
    1 IF (ITER .EQ. MAXIT) GO TO 4
      DGMAX = 0.
      INDL = 0
      DO 3 K = 1,NN
        XK = X(K)
        YK = Y(K)
        ZK = Z(K)
        ZXK = ZXZY(1,K)
        ZYK = ZXZY(2,K)
C
C   INITIALIZE COMPONENTS OF THE 2 BY 2 SYSTEM
C
        A11 = 0.
        A12 = 0.
        A22 = 0.
        R1 = 0.
        R2 = 0.
C
C   LOOP ON NEIGHBORS NB OF K
C
        INDF = INDL + 1
        INDL = IEND(K)
        DO 2 INDX = INDF,INDL
          NB = IADJ(INDX)
          IF (NB .EQ. 0) GO TO 2
C
C   COMPUTE THE COMPONENTS OF ARC NB-K
C
          DELX = X(NB) - XK
          DELY = Y(NB) - YK
          DELXS = DELX*DELX
          DELYS = DELY*DELY
          DSQ = DELXS + DELYS
          DCUB = DSQ*SQRT(DSQ)
C
C   UPDATE THE SYSTEM COMPONENTS FOR NODE NB
C
          A11 = A11 + DELXS/DCUB
          A12 = A12 + DELX*DELY/DCUB
          A22 = A22 + DELYS/DCUB
          T = ( 1.5*(Z(NB)-ZK) - ((ZXZY(1,NB)/2.+ZXK)*DELX +
     .          (ZXZY(2,NB)/2.+ZYK)*DELY) )/DCUB
          R1 = R1 + T*DELX
          R2 = R2 + T*DELY
    2     CONTINUE
C
C   SOLVE THE 2 BY 2 SYSTEM AND UPDATE DGMAX
C
        DZY = (A11*R2 - A12*R1)/(A11*A22 - A12*A12)
        DZX = (R1 - A12*DZY)/A11
        DGMAX = AMAX1(DGMAX,ABS(DZX),ABS(DZY))
C
C   UPDATE THE PARTIALS AT NODE K
C
        ZXZY(1,K) = ZXK + DZX
    3   ZXZY(2,K) = ZYK + DZY
C
C   INCREMENT ITER AND TEST FOR CONVERGENCE
C
      ITER = ITER + 1
      IF (DGMAX .GT. TOL) GO TO 1
C
C METHOD CONVERGED
C
      NIT = ITER
      IER = 0
      RETURN
C
C METHOD FAILED TO CONVERGE WITHIN NIT ITERATIONS
C
    4 IER = 1
      RETURN
C
C PARAMETER OUT OF RANGE
C
    5 NIT = 0
      IER = 2
      RETURN
      END
      SUBROUTINE GRADL (N, X, Y, Z, IADJ, IEND, ZXZY, IERR)
C-----------------------------------------------------------------------
C                      DERIVATIVE ESTIMATION
C-----------------------------------------------------------------------
      REAL X(N), Y(N), Z(N), ZXZY(2,N)
      INTEGER IADJ(*), IEND(N)
C
      IF (N .LT. 3) GO TO 20
C
      DO 10 J = 1,N
         CALL GRADL1 (N, J, X, Y, Z, IADJ, IEND, ZXZY(1,J),
     *               ZXZY(2,J), IERR)
         IF (IERR .LT. 0) GO TO 30
   10 CONTINUE
      IERR = 0
      RETURN
C
C     ERROR RETURN
C
   20 IERR = 1
      RETURN
C
   30 IERR = 2
      RETURN
      END
      SUBROUTINE GRADL1 (N,K,X,Y,Z,IADJ,IEND, DX,DY,IER)
      INTEGER N, K, IADJ(*), IEND(N), IER
      REAL    X(N), Y(N), Z(N), DX, DY
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   GIVEN A THIESSEN TRIANGULATION OF N POINTS IN THE PLANE
C WITH ASSOCIATED DATA VALUES Z, THIS SUBROUTINE ESTIMATES
C X AND Y PARTIAL DERIVATIVES AT NODE K.  THE DERIVATIVES
C ARE TAKEN TO BE THE PARTIALS AT K OF A QUADRATIC FUNCTION
C WHICH INTERPOLATES Z(K) AND FITS THE DATA VALUES AT A SET
C OF NEARBY NODES IN A WEIGHTED LEAST SQUARES SENSE. A MAR-
C QUARDT STABILIZATION FACTOR IS USED IF NECESSARY TO ENSURE
C A WELL-CONDITIONED SYSTEM AND A LINEAR FITTING FUNCTION IS
C USED IF N .LT. 6.  THUS, A UNIQUE SOLUTION EXISTS UNLESS
C THE NODES ARE COLLINEAR.
C   AN ALTERNATIVE ROUTINE, GRADG, EMPLOYS A GLOBAL METHOD
C TO COMPUTE THE PARTIAL DERIVATIVES AT ALL OF THE NODES AT
C ONCE.  THAT METHOD IS MORE EFFICIENT (WHEN ALL PARTIALS
C ARE NEEDED) AND MAY BE MORE ACCURATE, DEPENDING ON THE
C DATA.
C
C INPUT PARAMETERS - N - NUMBER OF NODES IN THE TRIANGULA-
C                        TION.  N .GE. 3.
C
C                    K - NODE AT WHICH DERIVATIVES ARE
C                        SOUGHT.  1 .LE. K .LE. N.
C
C                  X,Y - N-VECTORS CONTAINING THE CARTESIAN
C                        COORDINATES OF THE NODES.
C
C                    Z - N-VECTOR CONTAINING THE DATA VALUES
C                        ASSOCIATED WITH THE NODES.
C
C                 IADJ - SET OF ADJACENCY LISTS.
C
C                 IEND - POINTERS TO THE ENDS OF ADJACENCY
C                        LISTS FOR EACH NODE.
C
C IADJ AND IEND MAY BE CREATED BY SUBROUTINE TRMESH.
C
C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETERS - DX,DY - ESTIMATED PARTIAL DERIVATIVES
C                             AT NODE K UNLESS IER .LT. 0.
C
C                       IER - ERROR INDICATOR
C                             IER .GT. 0 IF NO ERRORS WERE
C                                      ENCOUNTERED.  IER
C                                      CONTAINS THE NUMBER
C                                      OF NODES (INCLUDING
C                                      K) USED IN THE FIT.
C                                      IER = 3, 4, OR 5 IM-
C                                      PLIES A LINEAR FIT.
C                             IER = -1 IF N OR K IS OUT OF
C                                      RANGE.
C                             IER = -2 IF ALL NODES ARE
C                                      COLLINEAR.
C
C MODULES REFERENCED BY GRADL1 - GETNP, SETRM, SROTG, SROT
C
C INTRINSIC FUNCTIONS CALLED BY GRADL1 - MIN0, FLOAT, SQRT,
C                                       AMIN1, ABS
C
C***********************************************************
C
      INTEGER NN, KK, LMN, LMX, LMIN, LMAX, LM1, LNP,
     .        NPTS(30), IERR, NP, I, J, IM1, JP1, IP1, L
      REAL    SUM, DS, R, RS, RTOL, AVSQ, AV, XK, YK, ZK,
     .        A(6,6), C, S, DMIN, DTOL, SF
      DATA    LMN/10/
      DATA    LMX/30/, RTOL/1.E-5/, DTOL/.01/, SF/1./
C
C LOCAL PARAMETERS -
C
C NN,KK =     LOCAL COPIES OF N AND K
C LMN,LMX =   MINIMUM AND MAXIMUM VALUES OF LNP FOR N
C               SUFFICIENTLY LARGE.  IN MOST CASES LMN-1
C               NODES ARE USED IN THE FIT.  4 .LE. LMN .LE.
C               LMX.
C LMIN,LMAX = MIN(LMN,N), MIN(LMX,N)
C LM1 =       LMIN-1 OR LNP-1
C LNP =       LENGTH OF NPTS
C NPTS =      ARRAY CONTAINING THE INDICES OF A SEQUENCE OF
C               NODES ORDERED BY DISTANCE FROM K.  NPTS(1)=K
C               AND THE FIRST LNP-1 ELEMENTS OF NPTS ARE
C               USED IN THE LEAST SQUARES FIT.  UNLESS LNP
C               EXCEEDS LMAX, NPTS(LNP) DETERMINES R.
C IERR =      ERROR FLAG FOR CALLS TO GETNP (NOT CHECKED)
C NP =        ELEMENT OF NPTS TO BE ADDED TO THE SYSTEM
C I,J =       DO-LOOP INDICES
C IM1,JP1 =   I-1, J+1
C IP1 =       I+1
C L =         NUMBER OF COLUMNS OF A**T TO WHICH A ROTATION
C               IS APPLIED
C SUM =       SUM OF SQUARED EUCLIDEAN DISTANCES BETWEEN
C               NODE K AND THE NODES USED IN THE LEAST
C               SQUARES FIT
C DS =        SQUARED DISTANCE BETWEEN NODE K AND AN ELE-
C               MENT OF NPTS
C R =         DISTANCE BETWEEN NODE K AND NPTS(LNP) OR SOME
C               POINT FURTHER FROM K THAN NPTS(LMAX) IF
C               NPTS(LMAX) IS USED IN THE FIT.  R IS A
C               RADIUS OF INFLUENCE WHICH ENTERS INTO THE
C               WEIGHTS (SEE SUBROUTINE SETRM).
C RS =        R*R
C RTOL =      TOLERANCE FOR DETERMINING R.  IF THE RELATIVE
C               CHANGE IN DS BETWEEN TWO ELEMENTS OF NPTS IS
C               NOT GREATER THAN RTOL THEY ARE TREATED AS
C               BEING THE SAME DISTANCE FROM NODE K
C AVSQ =      AV*AV
C AV =        ROOT-MEAN-SQUARE DISTANCE BETWEEN K AND THE
C               NODES (OTHER THAN K) IN THE LEAST SQUARES
C               FIT.  THE FIRST 3 COLUMNS OF THE SYSTEM ARE
C               SCALED BY 1/AVSQ, THE NEXT 2 BY 1/AV.
C XK,YK,ZK =  COORDINATES AND DATA VALUE ASSOCIATED WITH K
C A =         TRANSPOSE OF THE AUGMENTED REGRESSION MATRIX
C C,S =       COMPONENTS OF THE PLANE ROTATION DETERMINED
C               BY SUBROUTINE SROTG
C DMIN =      MINIMUM OF THE MAGNITUDES OF THE DIAGONAL
C               ELEMENTS OF THE REGRESSION MATRIX AFTER
C               ZEROS ARE INTRODUCED BELOW THE DIAGONAL
C DTOL =      TOLERANCE FOR DETECTING AN ILL-CONDITIONED
C               SYSTEM.  THE SYSTEM IS ACCEPTED WHEN DMIN
C               .GE. DTOL
C SF =        MARQUARDT STABILIZATION FACTOR USED TO DAMP
C               OUT THE FIRST 3 SOLUTION COMPONENTS (SECOND
C               PARTIALS OF THE QUADRATIC) WHEN THE SYSTEM
C               IS ILL-CONDITIONED.  AS SF INCREASES, THE
C               FITTING FUNCTION APPROACHES A LINEAR
C
      NN = N
      KK = K
C
C CHECK FOR ERRORS AND INITIALIZE LMIN, LMAX
C
      IF (NN .LT. 3  .OR.  KK .LT. 1  .OR.  KK .GT. NN)
     .   GO TO 16
      LMIN = MIN0(LMN,NN)
      LMAX = MIN0(LMX,NN)
C
C COMPUTE NPTS, LNP, AVSQ, AV, AND R.
C   SET NPTS TO THE CLOSEST LMIN-1 NODES TO K.
C
      SUM = 0.
      NPTS(1) = KK
      LM1 = LMIN - 1
      DO 1 LNP = 2,LM1
        CALL GETNP (X,Y,IADJ,IEND,LNP, NPTS, DS,IERR)
    1   SUM = SUM + DS
C
C ADD ADDITIONAL NODES TO NPTS UNTIL THE RELATIVE INCREASE
C   IN DS IS AT LEAST RTOL.
C
      DO 2 LNP = LMIN,LMAX
        CALL GETNP (X,Y,IADJ,IEND,LNP, NPTS, RS,IERR)
        IF ((RS-DS)/DS .LE. RTOL) GO TO 2
        IF (LNP .GT. 6) GO TO 3
    2   SUM = SUM + RS
C
C USE ALL LMAX NODES IN THE LEAST SQUARES FIT.  RS IS
C   ARBITRARILY INCREASED BY 10 PER CENT.
C
      RS = 1.1*RS
      LNP = LMAX + 1
C
C THERE ARE LNP-2 EQUATIONS CORRESPONDING TO NODES NPTS(2),
C   ...,NPTS(LNP-1).
C
    3 AVSQ = SUM/FLOAT(LNP-2)
      AV = SQRT(AVSQ)
      R = SQRT(RS)
      XK = X(KK)
      YK = Y(KK)
      ZK = Z(KK)
      IF (LNP .LT. 7) GO TO 12
C
C SET UP THE FIRST 5 EQUATIONS OF THE AUGMENTED REGRESSION
C   MATRIX (TRANSPOSED) AS THE COLUMNS OF A, AND ZERO OUT
C   THE LOWER TRIANGLE (UPPER TRIANGLE OF A) WITH GIVENS
C   ROTATIONS
C
      DO 5 I = 1,5
        NP = NPTS(I+1)
        CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ,
     .              R, A(1,I))
        IF (I .EQ. 1) GO TO 5
        IM1 = I - 1
        DO 4 J = 1,IM1
          JP1 = J + 1
          L = 6 - J
          CALL SROTG (A(J,J),A(J,I),C,S)
    4     CALL SROT (L,A(JP1,J),1,A(JP1,I),1,C,S)
    5   CONTINUE
C
C ADD THE ADDITIONAL EQUATIONS TO THE SYSTEM USING
C   THE LAST COLUMN OF A -- I .LE. LNP.
C
      I = 7
    6   IF (I .EQ. LNP) GO TO 8
        NP = NPTS(I)
        CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ,
     .              R, A(1,6))
        DO 7 J = 1,5
          JP1 = J + 1
          L = 6 - J
          CALL SROTG (A(J,J),A(J,6),C,S)
    7     CALL SROT (L,A(JP1,J),1,A(JP1,6),1,C,S)
        I = I + 1
        GO TO 6
C
C TEST THE SYSTEM FOR ILL-CONDITIONING
C
    8 DMIN = AMIN1( ABS(A(1,1)),ABS(A(2,2)),ABS(A(3,3)),
     .              ABS(A(4,4)),ABS(A(5,5)) )
      IF (DMIN .GE. DTOL) GO TO 15
      IF (LNP .GT. LMAX) GO TO 9
C
C ADD ANOTHER NODE TO THE SYSTEM AND INCREASE R --
C   I .EQ. LNP
C
      LNP = LNP + 1
      IF (LNP .LE. LMAX) CALL GETNP (X,Y,IADJ,IEND,LNP,
     .                               NPTS, RS,IERR)
      R = SQRT(1.1*RS)
      GO TO 6
C
C STABILIZE THE SYSTEM BY DAMPING SECOND PARTIALS --ADD
C   MULTIPLES OF THE FIRST THREE UNIT VECTORS TO THE FIRST
C   THREE EQUATIONS.
C
    9 DO 11 I = 1,3
        A(I,6) = SF
        IP1 = I + 1
        DO 10 J = IP1,6
   10     A(J,6) = 0.
        DO 11 J = I,5
          JP1 = J + 1
          L = 6 - J
          CALL SROTG (A(J,J),A(J,6),C,S)
   11     CALL SROT (L,A(JP1,J),1,A(JP1,6),1,C,S)
      GO TO 14
C
C 4 .LE. LNP .LE. 6 (2, 3, OR 4 EQUATIONS) -- FIT A PLANE TO
C   THE DATA USING THE LAST 3 COLUMNS OF A.
C
   12 NP = NPTS(2)
      CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ,
     .            R, A(1,4))
      NP = NPTS(3)
      CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ,
     .            R, A(1,5))
      CALL SROTG (A(4,4),A(4,5),C,S)
      CALL SROT (2,A(5,4),1,A(5,5),1,C,S)
      IF (LNP .EQ. 4) GO TO 14
C
      LM1 = LNP - 1
      DO 13 I = 4,LM1
        NP = NPTS(I)
        CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ,
     .              R, A(1,6))
        CALL SROTG (A(4,4),A(4,6),C,S)
        CALL SROT (2,A(5,4),1,A(5,6),1,C,S)
        CALL SROTG (A(5,5),A(5,6),C,S)
   13   CALL SROT (1,A(6,5),1,A(6,6),1,C,S)
C
C TEST THE LINEAR FIT FOR ILL-CONDITIONING
C
   14 DMIN = AMIN1( ABS(A(4,4)),ABS(A(5,5)) )
      IF (DMIN .LT. DTOL) GO TO 17
C
C SOLVE THE 2 BY 2 TRIANGULAR SYSTEM FOR THE DERIVATIVES
C
   15 DY = A(6,5)/A(5,5)
      DX = (A(6,4) - A(5,4)*DY)/A(4,4)/AV
      DY = DY/AV
      IER = LNP - 1
      RETURN
C
C N OR K IS OUT OF RANGE
C
   16 IER = -1
      RETURN
C
C NO UNIQUE SOLUTION DUE TO COLLINEAR NODES
C
   17 IER = -2
      RETURN
      END
      SUBROUTINE SETRM (XK,YK,ZK,XI,YI,ZI,S1,S2,R, ROW)
      REAL XK, YK, ZK, XI, YI, ZI, S1, S2, R, ROW(6)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   THIS ROUTINE SETS UP THE I-TH ROW OF AN AUGMENTED RE-
C GRESSION MATRIX FOR A WEIGHTED LEAST-SQUARES FIT OF A
C QUADRATIC FUNCTION Q(X,Y) TO A SET OF DATA VALUES Z WHERE
C Q(XK,YK) = ZK.  THE FIRST 3 COLUMNS (QUADRATIC TERMS) ARE
C SCALED BY 1/S2 AND THE FOURTH AND FIFTH COLUMNS (LINEAR
C TERMS) ARE SCALED BY 1/S1.  THE WEIGHT IS (R-D)/(R*D) IF
C R .GT. D AND 0 IF R .LE. D, WHERE D IS THE DISTANCE
C BETWEEN NODES I AND K.
C
C INPUT PARAMETERS - XK,YK,ZK - COORDINATES AND DATA VALUE
C                               AT NODE K -- INTERPOLATED
C                               BY Q.
C
C                    XI,YI,ZI - COORDINATES AND DATA VALUE
C                               AT NODE I.
C
C                       S1,S2 - INVERSE SCALE FACTORS.
C
C                           R - RADIUS OF INFLUENCE ABOUT
C                               NODE K DEFINING THE WEIGHT.
C
C                         ROW - VECTOR OF LENGTH 6.
C
C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETER - ROW - VECTOR CONTAINING A ROW OF THE
C                          AUGMENTED REGRESSION MATRIX.
C
C MODULES REFERENCED BY SETRM - NONE
C
C INTRINSIC FUNCTION CALLED BY SETRM - SQRT
C
C***********************************************************
C
      INTEGER I
      REAL    DX, DY, DXSQ, DYSQ, D, W, W1, W2
C
C LOCAL PARAMETERS -
C
C I =    DO-LOOP INDEX
C DX =   XI - XK
C DY =   YI - YK
C DXSQ = DX*DX
C DYSQ = DY*DY
C D =    DISTANCE BETWEEN NODES K AND I
C W =    WEIGHT ASSOCIATED WITH THE ROW
C W1 =   W/S1
C W2 =   W/S2
C
      DX = XI - XK
      DY = YI - YK
      DXSQ = DX*DX
      DYSQ = DY*DY
      D = SQRT(DXSQ + DYSQ)
      IF (D .LE. 0.  .OR.  D .GE. R) GO TO 1
      W = (R-D)/R/D
      W1 = W/S1
      W2 = W/S2
      ROW(1) = DXSQ*W2
      ROW(2) = DX*DY*W2
      ROW(3) = DYSQ*W2
      ROW(4) = DX*W1
      ROW(5) = DY*W1
      ROW(6) = (ZI - ZK)*W
      RETURN
C
C NODES K AND I COINCIDE OR NODE I IS OUTSIDE OF THE RADIUS
C   OF INFLUENCE.  SET ROW TO THE ZERO VECTOR.
C
    1 DO 2 I = 1,6
    2   ROW(I) = 0.
      RETURN
      END
      SUBROUTINE GETNP (X,Y,IADJ,IEND,L, NPTS, DS,IER)
      INTEGER IADJ(*), IEND(*), L, NPTS(L), IER
      REAL    X(*), Y(*), DS
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   GIVEN A THIESSEN TRIANGULATION OF N NODES AND AN ARRAY
C NPTS CONTAINING THE INDICES OF L-1 NODES ORDERED BY
C EUCLIDEAN DISTANCE FROM NPTS(1), THIS SUBROUTINE SETS
C NPTS(L) TO THE INDEX OF THE NEXT NODE IN THE SEQUENCE --
C THE NODE, OTHER THAN NPTS(1),...,NPTS(L-1), WHICH IS
C CLOSEST TO NPTS(1).  THUS, THE ORDERED SEQUENCE OF K
C CLOSEST NODES TO N1 (INCLUDING N1) MAY BE DETERMINED BY
C K-1 CALLS TO GETNP WITH NPTS(1) = N1 AND L = 2,3,...,K
C FOR K .GE. 2.
C   THE ALGORITHM USES THE FACT THAT, IN A THIESSEN TRIAN-
C GULATION, THE K-TH CLOSEST NODE TO A GIVEN NODE N1 IS A
C NEIGHBOR OF ONE OF THE K-1 CLOSEST NODES TO N1.
C
C INPUT PARAMETERS - X,Y - VECTORS OF LENGTH N CONTAINING
C                          THE CARTESIAN COORDINATES OF THE
C                          NODES.
C
C                   IADJ - SET OF ADJACENCY LISTS OF NODES
C                          IN THE TRIANGULATION.
C
C                   IEND - POINTERS TO THE ENDS OF ADJACENCY
C                          LISTS FOR EACH NODE IN THE TRI-
C                          ANGULATION.
C
C                      L - NUMBER OF NODES IN THE SEQUENCE
C                          ON OUTPUT.  2 .LE. L .LE. N.
C
C                   NPTS - ARRAY OF LENGTH .GE. L CONTAIN-
C                          ING THE INDICES OF THE L-1 CLOS-
C                          EST NODES TO NPTS(1) IN THE FIRST
C                          L-1 LOCATIONS.
C
C IADJ AND IEND MAY BE CREATED BY SUBROUTINE TRMESH.
C
C INPUT PARAMETERS OTHER THAN NPTS ARE NOT ALTERED BY THIS
C   ROUTINE.
C
C OUTPUT PARAMETERS - NPTS - UPDATED WITH THE INDEX OF THE
C                            L-TH CLOSEST NODE TO NPTS(1) IN
C                            POSITION L UNLESS IER = 1.
C
C                       DS - SQUARED EUCLIDEAN DISTANCE BE-
C                            TWEEN NPTS(1) AND NPTS(L)
C                            UNLESS IER = 1.
C
C                      IER - ERROR INDICATOR
C                            IER = 0 IF NO ERRORS WERE EN-
C                                    COUNTERED.
C                            IER = 1 IF L IS OUT OF RANGE.
C
C MODULES REFERENCED BY GETNP - NONE
C
C INTRINSIC FUNCTION CALLED BY GETNP - IABS
C
C***********************************************************
C
      INTEGER LM1, N1, I, NI, NP, INDF, INDL, INDX, NB
      REAL    X1, Y1, DNP, DNB
C
C LOCAL PARAMETERS -
C
C LM1 =     L - 1
C N1 =      NPTS(1)
C I =       NPTS INDEX AND DO-LOOP INDEX
C NI =      NPTS(I)
C NP =      CANDIDATE FOR NPTS(L)
C INDF =    IADJ INDEX OF THE FIRST NEIGHBOR OF NI
C INDL =    IADJ INDEX OF THE LAST NEIGHBOR OF NI
C INDX =    IADJ INDEX IN THE RANGE INDF,...,INDL
C NB =      NEIGHBOR OF NI AND CANDIDATE FOR NP
C X1,Y1 =   COORDINATES OF N1
C DNP,DNB = SQUARED DISTANCES FROM N1 TO NP AND NB,
C             RESPECTIVELY
C
      LM1 = L - 1
      IF (LM1 .LT. 1) GO TO 4
      IER = 0
      N1 = NPTS(1)
      X1 = X(N1)
      Y1 = Y(N1)
C
C MARK THE ELEMENTS OF NPTS
C
      DO 1 I = 1,LM1
        NI = NPTS(I)
        IEND(NI) = -IEND(NI)
    1   CONTINUE
C
C CANDIDATES FOR NP = NPTS(L) ARE THE UNMARKED NEIGHBORS
C   OF NODES IN NPTS.  NP=0 IS A FLAG TO SET NP TO THE
C   FIRST CANDIDATE ENCOUNTERED.
C
      NP = 0
      DNP = 0.
C
C LOOP ON NODES NI IN NPTS
C
      DO 2 I = 1,LM1
        NI = NPTS(I)
        INDF = 1
        IF (NI .GT. 1) INDF = IABS(IEND(NI-1)) + 1
        INDL = -IEND(NI)
C
C LOOP ON NEIGHBORS NB OF NI
C
        DO 2 INDX = INDF,INDL
          NB = IADJ(INDX)
          IF (NB .EQ. 0  .OR.  IEND(NB) .LT. 0) GO TO 2
C
C NB IS AN UNMARKED NEIGHBOR OF NI.  REPLACE NP IF NB IS
C   CLOSER TO N1 OR IS THE FIRST CANDIDATE ENCOUNTERED.
C
          DNB = (X(NB)-X1)**2 + (Y(NB)-Y1)**2
          IF (NP .NE. 0  .AND.  DNB .GE. DNP) GO TO 2
          NP = NB
          DNP = DNB
    2     CONTINUE
      NPTS(L) = NP
      DS = DNP
C
C UNMARK THE ELEMENTS OF NPTS
C
      DO 3 I = 1,LM1
        NI = NPTS(I)
        IEND(NI) = -IEND(NI)
    3   CONTINUE
      RETURN
C
C L IS OUT OF RANGE
C
    4 IER = 1
      RETURN
      END
      SUBROUTINE SFVAL (N, X, Y, Z, M, XI, YI, ZI, IADJ, IEND,
     *                  ZXZY, IERR)
C-----------------------------------------------------------------------
C                    EVALUATION OF THE SURFACE
C-----------------------------------------------------------------------
      REAL X(N), Y(N), Z(N), XI(M), YI(M), ZI(M), ZXZY(2,N)
      INTEGER IADJ(*), IEND(N)
C
      IF (N .LT. 3 .OR. M .LT. 1) GO TO 20
C
      IST = 1
      DO 10 J = 1,M
         CALL INTRC1 (N, XI(J), YI(J), X, Y, Z, IADJ, IEND,
     *                1, ZXZY, IST, ZI(J), IERR)
         IF (IERR .LT. 0) GO TO 30
   10 CONTINUE
      IERR = 0
      RETURN
C
C     ERROR RETURN
C
   20 IERR = 1
      RETURN
   30 IERR = 2
      RETURN
      END
      SUBROUTINE SFVAL2 (N, X, Y, Z, L, M, NROWS, XI, YI, ZI,
     *                   IADJ, IEND, ZXZY, IERR)
C-----------------------------------------------------------------------
C                EVALUATION OF THE SURFACE OVER A GRID
C-----------------------------------------------------------------------
      REAL X(N), Y(N), Z(N), ZXZY(2,N)
      REAL XI(L), YI(M), ZI(NROWS,M)
      INTEGER IADJ(*), IEND(N)
C
      IF (N .LT. 3 .OR. L .LT. 1 .OR. M .LT. 1 .OR. NROWS .LT. L)
     *   GO TO 30
C
      IST = 1
      DO 20 J = 1,M
         DO 10 I = 1,L
            CALL INTRC1 (N, XI(I), YI(J), X, Y, Z, IADJ, IEND,
     *                   1, ZXZY, IST, ZI(I,J), IERR)
            IF (IERR .LT. 0) GO TO 40
   10    CONTINUE
   20 CONTINUE
      IERR = 0
      RETURN
C
C     ERROR RETURN
C
   30 IERR = 1
      RETURN
   40 IERR = 2
      RETURN
      END
      SUBROUTINE INTRC1 (N,PX,PY,X,Y,Z,IADJ,IEND,IFLAG,
     .                   ZXZY, IST, PZ,IER)
      INTEGER N, IADJ(*), IEND(N), IFLAG, IST, IER
      REAL    PX, PY, X(N), Y(N), Z(N), ZXZY(2,N), PZ
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   GIVEN A TRIANGULATION OF A SET OF POINTS IN THE PLANE,
C THIS ROUTINE DETERMINES A PIECEWISE CUBIC FUNCTION F(X,Y)
C WHICH INTERPOLATES A SET OF DATA VALUES AND PARTIAL
C DERIVATIVES AT THE VERTICES.  F HAS CONTINUOUS FIRST
C DERIVATIVES OVER THE MESH AND EXTENDS BEYOND THE MESH
C BOUNDARY ALLOWING EXTRAPOLATION.  INTERPOLATION IS EXACT
C FOR QUADRATIC DATA.  THE VALUE OF F AT (PX,PY) IS
C RETURNED.  INTRC1 IS PART OF AN INTERPOLATION PACKAGE
C WHICH PROVIDES ROUTINES TO GENERATE, UPDATE AND PLOT THE
C MESH.
C
C INPUT PARAMETERS -     N - NUMBER OF NODES IN THE MESH.
C                            N .GE. 3.
C
C                    PX,PY - COORDINATES OF A POINT AT WHICH
C                            F IS TO BE EVALUATED.
C
C                      X,Y - VECTORS OF COORDINATES OF THE
C                            NODES IN THE MESH.
C
C                        Z - VECTOR OF DATA VALUES AT THE
C                            NODES.
C
C                     IADJ - SET OF ADJACENCY LISTS OF NODES
C                            IN THE MESH.
C
C                     IEND - POINTERS TO THE ENDS OF
C                            ADJACENCY LISTS IN IADJ FOR
C                            EACH NODE IN THE MESH.
C
C                    IFLAG - OPTION INDICATOR
C                            IFLAG = 0 IF INTRC1 IS TO
C                                      PROVIDE DERIVATIVE
C                                      ESTIMATES (FROM
C                                      GRADL1).
C                            IFLAG = 1 IF DERIVATIVES ARE
C                                      USER PROVIDED.
C
C                     ZXZY - 2 BY N ARRAY WHOSE COLUMNS
C                            CONTAIN ESTIMATED PARTIAL DER-
C                            IVATIVES AT THE NODES (X PAR-
C                            TIALS IN THE FIRST ROW) IF
C                            IFLAG = 1, NOT USED IF IFLAG
C                            = 0.
C
C                      IST - INDEX OF THE STARTING NODE IN
C                            THE SEARCH FOR A TRIANGLE CON-
C                            TAINING (PX,PY).  1 .LE. IST
C                            .LE. N.  THE OUTPUT VALUE OF
C                            IST FROM A PREVIOUS CALL MAY
C                            BE A GOOD CHOICE.
C
C IADJ AND IEND MAY BE CREATED BY TRMESH AND DERIVATIVE
C   ESTIMATES MAY BE COMPUTED BY GRADL1 OR GRADG.
C
C INPUT PARAMETERS OTHER THAN IST ARE NOT ALTERED BY THIS
C   ROUTINE.
C
C OUTPUT PARAMETERS - IST - INDEX OF ONE OF THE VERTICES OF
C                           THE TRIANGLE CONTAINING (PX,PY)
C                           UNLESS IER .LT. 0.
C
C                      PZ - VALUE OF F AT (PX,PY), OR 0 IF
C                           IER .LT. 0.
C
C                     IER - ERROR INDICATOR
C                           IER = 0 IF NO ERRORS WERE
C                                   ENCOUNTERED.
C                           IER = 1 IF NO ERRORS WERE EN-
C                                   COUNTERED AND EXTRAPOLA-
C                                   TION WAS PERFORMED.
C                           IER = -1 IF N, IFLAG, OR IST IS
C                                    OUT OF RANGE.
C                           IER = -2 IF THE NODES ARE COL-
C                                    LINEAR.
C
C MODULES REFERENCED BY INTRC1 - TRFIND, TVAL,
C             (AND OPTIONALLY)   GRADL1, GETNP, SETRM,
C                                SROTG, SROT
C
C***********************************************************
C
      INTEGER NN, I1, I2, I3, IERR, N1, N2, INDX
      REAL    XP, YP, ZX1, ZY1, ZX2, ZY2, ZX3, ZY3, X1, Y1,
     .        X2, Y2, X3, Y3, Z1, Z2, Z3, DUM, DP, U, V, XQ,
     .        YQ, R1, R2, A1, A2, B1, B2, C1, C2, F1, F2
C
C LOCAL PARAMETERS -
C
C NN =                      LOCAL COPY OF N
C I1,I2,I3 =                VERTICES DETERMINED BY TRFIND
C IERR =                    ERROR FLAG FOR CALLS TO GRADL1
C                             AND TVAL
C N1,N2 =                   ENDPOINTS OF THE CLOSEST BOUND-
C                             ARY EDGE TO P WHEN P IS OUT-
C                             SIDE OF THE MESH BOUNDARY
C INDX =                    IADJ INDEX OF N1 AS A NEIGHBOR
C                             OF N2
C XP,YP =                   LOCAL COPIES OF THE COORDINATES
C                             OF P=(PX,PY)
C ZX1,ZY1,ZX2,ZY2,ZX3,ZY3 = X AND Y DERIVATIVES AT THE
C                             VERTICES OF A TRIANGLE T WHICH
C                             CONTAINS P OR AT N1 AND N2
C X1,Y1,X2,Y2,X3,Y3 =       X,Y COORDINATES OF THE VERTICES
C                             OF T OR OF N1 AND N2
C Z1,Z2,Z3 =                DATA VALUES AT THE VERTICES OF T
C DUM =                     DUMMY VARIABLE FOR CALL TO TVAL
C DP =                      INNER PRODUCT OF N1-N2 AND P-N2
C U,V =                     X,Y COORDINATES OF THE VECTOR
C                             N2-N1
C XQ,YQ =                   X,Y COORDINATES OF THE CLOSEST
C                             BOUNDARY POINT TO P WHEN P IS
C                             OUTSIDE OF THE MESH BOUNDARY
C R1,R2 =                   BARYCENTRIC COORDINATES OF Q
C                             WITH RESPECT TO THE LINE SEG-
C                             MENT N2-N1 CONTAINING Q
C A1,A2,B1,B2,C1,C2 =       CARDINAL FUNCTIONS FOR EVALUAT-
C                             ING THE INTERPOLATORY SURFACE
C                             AT Q
C F1,F2 =                   CUBIC FACTORS USED TO COMPUTE
C                             THE CARDINAL FUNCTIONS
C
      NN = N
      PZ = 0.
      IF (NN .LT. 3  .OR.  IFLAG .LT. 0  .OR.  IFLAG .GT. 1
     .   .OR.  IST .LT. 1  .OR.  IST .GT. NN) GO TO 11
      XP = PX
      YP = PY
C
C FIND A TRIANGLE CONTAINING P IF P IS WITHIN THE MESH
C   BOUNDARY
C
      CALL TRFIND(IST,XP,YP,X,Y,IADJ,IEND, I1,I2,I3)
      IF (I1 .EQ. 0) GO TO 12
      IST = I1
      IF (I3 .EQ. 0) GO TO 3
      IF (IFLAG .NE. 1) GO TO 1
C
C DERIVATIVES ARE USER PROVIDED
C
      ZX1 = ZXZY(1,I1)
      ZX2 = ZXZY(1,I2)
      ZX3 = ZXZY(1,I3)
      ZY1 = ZXZY(2,I1)
      ZY2 = ZXZY(2,I2)
      ZY3 = ZXZY(2,I3)
      GO TO 2
C
C COMPUTE DERIVATIVE ESTIMATES AT THE VERTICES
C
    1 CALL GRADL1(NN,I1,X,Y,Z,IADJ,IEND, ZX1,ZY1,IERR)
      CALL GRADL1(NN,I2,X,Y,Z,IADJ,IEND, ZX2,ZY2,IERR)
      CALL GRADL1(NN,I3,X,Y,Z,IADJ,IEND, ZX3,ZY3,IERR)
C
C SET LOCAL PARAMETERS FOR CALL TO TVAL
C
    2 X1 = X(I1)
      Y1 = Y(I1)
      X2 = X(I2)
      Y2 = Y(I2)
      X3 = X(I3)
      Y3 = Y(I3)
      Z1 = Z(I1)
      Z2 = Z(I2)
      Z3 = Z(I3)
      CALL TVAL(XP,YP,X1,X2,X3,Y1,Y2,Y3,Z1,Z2,Z3,ZX1,ZX2,
     .          ZX3,ZY1,ZY2,ZY3,0, PZ,DUM,DUM,IERR)
      IF (IERR .NE. 0) GO TO 12
      IER = 0
      RETURN
C
C P IS OUTSIDE OF THE MESH BOUNDARY.  EXTRAPOLATE TO P BY
C   PASSING A LINEAR FUNCTION OF ONE VARIABLE THROUGH THE
C   VALUE AND DIRECTIONAL DERIVATIVE (IN THE DIRECTION
C   P-Q) OF THE INTERPOLATORY SURFACE (TVAL) AT Q WHERE
C   Q IS THE CLOSEST BOUNDARY POINT TO P.
C
C DETERMINE Q BY TRAVERSING THE BOUNDARY STARTING FROM
C   THE RIGHTMOST VISIBLE NODE I1.
C
    3 N2 = I1
C
C SET N1 TO THE LAST NONZERO NEIGHBOR OF N2 AND COMPUTE DP
C
    4 INDX = IEND(N2) - 1
      N1 = IADJ(INDX)
      X1 = X(N1)
      Y1 = Y(N1)
      X2 = X(N2)
      Y2 = Y(N2)
      DP = (X1-X2)*(XP-X2) + (Y1-Y2)*(YP-Y2)
      IF (DP .LE. 0.) GO TO 5
      IF ((XP-X1)*(X2-X1) + (YP-Y1)*(Y2-Y1) .GT. 0.) GO TO 8
      N2 = N1
      GO TO 4
C
C N2 IS THE CLOSEST BOUNDARY POINT TO P.  COMPUTE PARTIAL
C   DERIVATIVES AT N2.
C
    5 IF (IFLAG .NE. 1) GO TO 6
      ZX2 = ZXZY(1,N2)
      ZY2 = ZXZY(2,N2)
      GO TO 7
    6 CALL GRADL1(NN,N2,X,Y,Z,IADJ,IEND, ZX2,ZY2,IERR)
C
C COMPUTE EXTRAPOLATED VALUE AT P
C
    7 PZ = Z(N2) + ZX2*(XP-X2) + ZY2*(YP-Y2)
      IER = 1
      RETURN
C
C THE CLOSEST BOUNDARY POINT Q LIES ON N2-N1.  COMPUTE
C   PARTIALS AT N1 AND N2.
C
    8 IF (IFLAG .NE. 1) GO TO 9
      ZX1 = ZXZY(1,N1)
      ZY1 = ZXZY(2,N1)
      ZX2 = ZXZY(1,N2)
      ZY2 = ZXZY(2,N2)
      GO TO 10
    9 CALL GRADL1(NN,N1,X,Y,Z,IADJ,IEND, ZX1,ZY1,IERR)
      CALL GRADL1(NN,N2,X,Y,Z,IADJ,IEND, ZX2,ZY2,IERR)
C
C COMPUTE Q, ITS BARYCENTRIC COORDINATES, AND THE CARDINAL
C   FUNCTIONS FOR EXTRAPOLATION
C
   10 U = X2-X1
      V = Y2-Y1
      R1 = DP/(U**2 + V**2)
      R2 = 1. - R1
      XQ = R1*X1 + R2*X2
      YQ = R1*Y1 + R2*Y2
      F1 = R1*R1*R2
      F2 = R1*R2*R2
      A1 = R1 + (F1-F2)
      A2 = R2 - (F1-F2)
      B1 = U*F1
      B2 = -U*F2
      C1 = V*F1
      C2 = -V*F2
C
C COMPUTE THE VALUE OF THE INTERPOLATORY SURFACE (TVAL)
C   AT Q
C
      PZ = A1*Z(N1) + A2*Z(N2) + B1*ZX1 + B2*ZX2 +
     .     C1*ZY1 + C2*ZY2
C
C COMPUTE THE EXTRAPOLATED VALUE AT P
C
      PZ = PZ + (R1*ZX1 + R2*ZX2)*(XP-XQ) +
     .          (R1*ZY1 + R2*ZY2)*(YP-YQ)
      IER = 1
      RETURN
C
C N, IFLAG, OR IST OUT OF RANGE
C
   11 IER = -1
      RETURN
C
C NODES ARE COLLINEAR
C
   12 IER = -2
      RETURN
      END
      SUBROUTINE TVAL (X,Y,X1,X2,X3,Y1,Y2,Y3,Z1,Z2,Z3,ZX1,
     .                 ZX2,ZX3,ZY1,ZY2,ZY3,IFLAG, W,WX,WY,
     .                 IER)
      INTEGER IFLAG, IER
      REAL    X, Y, X1, X2, X3, Y1, Y2, Y3, Z1, Z2, Z3,
     .        ZX1, ZX2, ZX3, ZY1, ZY2, ZY3, W, WX, WY
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       OAK RIDGE NATL. LAB.
C                                             (615) 576-5139
C
C   GIVEN FUNCTION VALUES AND FIRST PARTIAL DERIVATIVES AT
C THE THREE VERTICES OF A TRIANGLE, THIS ROUTINE DETERMINES
C A FUNCTION W WHICH AGREES WITH THE GIVEN DATA, RETURNING
C THE VALUE AND (OPTIONALLY) FIRST PARTIAL DERIVATIVES OF W
C AT A POINT (X,Y) IN THE TRIANGLE.  THE INTERPOLATION
C METHOD IS EXACT FOR QUADRATIC POLYNOMIAL DATA.  THE
C TRIANGLE IS PARTITIONED INTO THREE SUBTRIANGLES WITH
C EQUAL AREAS.  W IS CUBIC IN EACH SUBTRIANGLE AND ALONG
C THE EDGES, BUT HAS ONLY ONE CONTINUOUS DERIVATIVE ACROSS
C EDGES.  THE NORMAL DERIVATIVE OF W VARIES LINEARLY ALONG
C EACH OUTER EDGE.  THE VALUES AND PARTIAL DERIVATIVES OF W
C ALONG A TRIANGLE EDGE DEPEND ONLY ON THE DATA VALUES AT
C THE ENDPOINTS OF THE EDGE.  THUS THE METHOD YIELDS C-1
C CONTINUITY WHEN USED TO INTERPOLATE OVER A TRIANGULAR
C GRID.  THIS ALGORITHM IS DUE TO C. L. LAWSON.
C
C INPUT PARAMETERS -   X,Y - COORDINATES OF A POINT AT WHICH
C                            W IS TO BE EVALUATED.
C
C        X1,X2,X3,Y1,Y2,Y3 - COORDINATES OF THE VERTICES OF
C                            A TRIANGLE CONTAINING (X,Y).
C
C                 Z1,Z2,Z3 - FUNCTION VALUES AT THE VERTICES
C                            TO BE INTERPOLATED.
C
C              ZX1,ZX2,ZX3 - X-DERIVATIVE VALUES AT THE
C                            VERTICES.
C
C              ZY1,ZY2,ZY3 - Y-DERIVATIVE VALUES AT THE
C                            VERTICES.
C
C                    IFLAG - OPTION INDICATOR
C                            IFLAG = 0 IF ONLY W IS TO BE
C                                      COMPUTED.
C                            IFLAG = 1 IF W, WX, AND WY ARE
C                                      TO BE RETURNED.
C
C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE.
C
C OUTPUT PARAMETERS -   W - ESTIMATED VALUE OF THE INTERP-
C                           OLATORY FUNCTION AT (X,Y) IF
C                           IER = 0.  OTHERWISE W = 0.
C
C                   WX,WY - PARTIAL DERIVATIVES OF W AT
C                           (X,Y) IF IER = 0 AND IFLAG = 1,
C                           UNCHANGED IF IFLAG .NE. 1, ZERO
C                           IF IER .NE. 0 AND IFLAG = 1.
C
C                     IER - ERROR INDICATOR
C                           IER = 0 IF NO ERRORS WERE
C                                   ENCOUNTERED.
C                           IER = 1 IF THE VERTICES OF THE
C                                   TRIANGLE ARE COLLINEAR.
C
C MODULES REFERENCED BY TVAL - NONE
C
C INTRINSIC FUNCTION CALLED BY TVAL - AMIN1
C
C***********************************************************
C
      INTEGER I, IP1, IP2, IP3
      REAL    U(3), V(3), SL(3), AREA, XP, YP, R(3), RX(3),
     .        RY(3), PHI(3), PHIX(3), PHIY(3), RMIN, C1, C2,
     .        RO(3), ROX(3), ROY(3), F(3), G(3), GX(3),
     .        GY(3), P(3), PX(3), PY(3), Q(3), QX(3), QY(3),
     .        A(3), AX(3), AY(3), B(3), BX(3), BY(3), C(3),
     .        CX(3), CY(3)
C
C LOCAL PARAMETERS -
C
C I =               DO-LOOP INDEX
C IP1,IP2,IP3 =     PERMUTED INDICES FOR COMPUTING RO, ROX,
C                     AND ROY
C U(K) =            X-COMPONENT OF THE VECTOR REPRESENTING
C                     THE SIDE OPPOSITE VERTEX K
C V(K) =            Y-COMPONENT OF THE VECTOR REPRESENTING
C                     THE SIDE OPPOSITE VERTEX K
C SL(K) =           SQUARE OF THE LENGTH OF THE SIDE
C                     OPPOSITE VERTEX K
C AREA =            TWICE THE AREA OF THE TRIANGLE
C XP,YP =           X-X1, Y-Y1
C R(K) =            K-TH BARYCENTRIC COORDINATE
C RX(K),RY(K) =     X,Y PARTIAL DERIVATIVES OF R(K)
C PHI(K)            R(K-1)*R(K+1) -- QUADRATIC
C PHIX(K),PHIY(K) = X,Y PARTIALS OF PHI(K)
C RMIN =            MIN(R1,R2,R3)
C C1,C2 =           FACTORS FOR COMPUTING RO
C RO(K) =           FACTORS FOR COMPUTING G -- CUBIC
C                     CORRECTION TERMS
C ROX(K),ROY(K) =   X,Y PARTIALS OF RO(K)
C F(K) =            FACTORS FOR COMPUTING G, GX, AND GY --
C                     CONSTANT
C G(K) =            FACTORS FOR COMPUTING THE CARDINAL
C                     FUNCTIONS -- CUBIC
C GX(K),GY(K) =     X,Y PARTIALS OF G(K)
C P(K) =            G(K) + PHI(K)
C PX(K),PY(K) =     X,Y PARTIALS OF P(K)
C Q(K) =            G(K) - PHI(K)
C QX(K),QY(K) =     X,Y PARTIALS OF Q(K)
C A(K) =            CARDINAL FUNCTION WHOSE COEFFICIENT IS
C                     Z(K)
C AX(K),AY(K) =     X,Y PARTIALS OF A(K) -- CARDINAL
C                     FUNCTIONS FOR WX AND WY
C B(K) =            TWICE THE CARDINAL FUNCTION WHOSE
C                     COEFFICIENT IS ZX(K)
C BX(K),BY(K) =     X,Y PARTIALS OF B(K)
C C(K) =            TWICE THE CARDINAL FUNCTION WHOSE
C                     COEFFICIENT IS ZY(K)
C CX(K),CY(K) =     X,Y PARTIALS OF C(K)
C
      U(1) = X3 - X2
      U(2) = X1 - X3
      U(3) = X2 - X1
C
      V(1) = Y3 - Y2
      V(2) = Y1 - Y3
      V(3) = Y2 - Y1
C
      DO 1 I = 1,3
        SL(I) = U(I)*U(I) + V(I)*V(I)
    1   CONTINUE
C
C AREA = 3-1 X 3-2
C
      AREA = U(1)*V(2) - U(2)*V(1)
      IF (AREA .EQ. 0.) GO TO 9
C
C R(1) = (2-3 X 2-(X,Y))/AREA, R(2) = (1-(X,Y) X 1-3)/AREA,
C   R(3) = (1-2 X 1-(X,Y))/AREA
C
      R(1) = (U(1)*(Y-Y2) - V(1)*(X-X2))/AREA
      XP = X - X1
      YP = Y - Y1
      R(2) = (U(2)*YP - V(2)*XP)/AREA
      R(3) = (U(3)*YP - V(3)*XP)/AREA
      IER = 0
C
      PHI(1) = R(2)*R(3)
      PHI(2) = R(3)*R(1)
      PHI(3) = R(1)*R(2)
C
      RMIN = AMIN1(R(1),R(2),R(3))
      IF (RMIN .NE. R(1)) GO TO 3
      IP1 = 1
      IP2 = 2
      IP3 = 3
      GO TO 5
    3 IF (RMIN .NE. R(2)) GO TO 4
      IP1 = 2
      IP2 = 3
      IP3 = 1
      GO TO 5
    4 IP1 = 3
      IP2 = 1
      IP3 = 2
C
    5 C1 = RMIN*RMIN/2.
      C2 = RMIN/3.
      RO(IP1) = (PHI(IP1) + 5.*C1/3.)*R(IP1) - C1
      RO(IP2) = C1*(R(IP3) - C2)
      RO(IP3) = C1*(R(IP2) - C2)
C
      F(1) = 3.*(SL(2)-SL(3))/SL(1)
      F(2) = 3.*(SL(3)-SL(1))/SL(2)
      F(3) = 3.*(SL(1)-SL(2))/SL(3)
C
      G(1) = (R(2)-R(3))*PHI(1) + F(1)*RO(1) - RO(2) + RO(3)
      G(2) = (R(3)-R(1))*PHI(2) + F(2)*RO(2) - RO(3) + RO(1)
      G(3) = (R(1)-R(2))*PHI(3) + F(3)*RO(3) - RO(1) + RO(2)
C
      DO 6 I = 1,3
        P(I) = G(I) + PHI(I)
        Q(I) = G(I) - PHI(I)
    6   CONTINUE
C
      A(1) = R(1) + G(3) - G(2)
      A(2) = R(2) + G(1) - G(3)
      A(3) = R(3) + G(2) - G(1)
C
      B(1) = U(3)*P(3) + U(2)*Q(2)
      B(2) = U(1)*P(1) + U(3)*Q(3)
      B(3) = U(2)*P(2) + U(1)*Q(1)
C
      C(1) = V(3)*P(3) + V(2)*Q(2)
      C(2) = V(1)*P(1) + V(3)*Q(3)
      C(3) = V(2)*P(2) + V(1)*Q(1)
C
C W IS A LINEAR COMBINATION OF THE CARDINAL FUNCTIONS
C
      W = A(1)*Z1 + A(2)*Z2 + A(3)*Z3 + (B(1)*ZX1 + B(2)*ZX2
     .    + B(3)*ZX3 + C(1)*ZY1 + C(2)*ZY2 + C(3)*ZY3)/2.
      IF (IFLAG .NE. 1) RETURN
C
C COMPUTE WX AND WY
C
      DO 7 I = 1,3
        RX(I) = -V(I)/AREA
        RY(I) = U(I)/AREA
    7   CONTINUE
      PHIX(1) = R(2)*RX(3) + RX(2)*R(3)
      PHIY(1) = R(2)*RY(3) + RY(2)*R(3)
      PHIX(2) = R(3)*RX(1) + RX(3)*R(1)
      PHIY(2) = R(3)*RY(1) + RY(3)*R(1)
      PHIX(3) = R(1)*RX(2) + RX(1)*R(2)
      PHIY(3) = R(1)*RY(2) + RY(1)*R(2)
C
      ROX(IP1) = RX(IP1)*(PHI(IP1) + 5.*C1) +
     .           R(IP1)*(PHIX(IP1) - RX(IP1))
      ROY(IP1) = RY(IP1)*(PHI(IP1) + 5.*C1) +
     .           R(IP1)*(PHIY(IP1) - RY(IP1))
      ROX(IP2) = RX(IP1)*(PHI(IP2) - C1) + C1*RX(IP3)
      ROY(IP2) = RY(IP1)*(PHI(IP2) - C1) + C1*RY(IP3)
      ROX(IP3) = RX(IP1)*(PHI(IP3) - C1) + C1*RX(IP2)
      ROY(IP3) = RY(IP1)*(PHI(IP3) - C1) + C1*RY(IP2)
C
      GX(1) = (RX(2) - RX(3))*PHI(1) + (R(2) - R(3))*PHIX(1)
     .        + F(1)*ROX(1) - ROX(2) + ROX(3)
      GY(1) = (RY(2) - RY(3))*PHI(1) + (R(2) - R(3))*PHIY(1)
     .        + F(1)*ROY(1) - ROY(2) + ROY(3)
      GX(2) = (RX(3) - RX(1))*PHI(2) + (R(3) - R(1))*PHIX(2)
     .        + F(2)*ROX(2) - ROX(3) + ROX(1)
      GY(2) = (RY(3) - RY(1))*PHI(2) + (R(3) - R(1))*PHIY(2)
     .        + F(2)*ROY(2) - ROY(3) + ROY(1)
      GX(3) = (RX(1) - RX(2))*PHI(3) + (R(1) - R(2))*PHIX(3)
     .        + F(3)*ROX(3) - ROX(1) + ROX(2)
      GY(3) = (RY(1) - RY(2))*PHI(3) + (R(1) - R(2))*PHIY(3)
     .        + F(3)*ROY(3) - ROY(1) + ROY(2)
C
      DO 8 I = 1,3
        PX(I) = GX(I) + PHIX(I)
        PY(I) = GY(I) + PHIY(I)
        QX(I) = GX(I) - PHIX(I)
        QY(I) = GY(I) - PHIY(I)
    8   CONTINUE
C
      AX(1) = RX(1) + GX(3) - GX(2)
      AY(1) = RY(1) + GY(3) - GY(2)
      AX(2) = RX(2) + GX(1) - GX(3)
      AY(2) = RY(2) + GY(1) - GY(3)
      AX(3) = RX(3) + GX(2) - GX(1)
      AY(3) = RY(3) + GY(2) - GY(1)
C
      BX(1) = U(3)*PX(3) + U(2)*QX(2)
      BY(1) = U(3)*PY(3) + U(2)*QY(2)
      BX(2) = U(1)*PX(1) + U(3)*QX(3)
      BY(2) = U(1)*PY(1) + U(3)*QY(3)
      BX(3) = U(2)*PX(2) + U(1)*QX(1)
      BY(3) = U(2)*PY(2) + U(1)*QY(1)
C
      CX(1) = V(3)*PX(3) + V(2)*QX(2)
      CY(1) = V(3)*PY(3) + V(2)*QY(2)
      CX(2) = V(1)*PX(1) + V(3)*QX(3)
      CY(2) = V(1)*PY(1) + V(3)*QY(3)
      CX(3) = V(2)*PX(2) + V(1)*QX(1)
      CY(3) = V(2)*PY(2) + V(1)*QY(1)
C
C WX AND WY ARE LINEAR COMBINATIONS OF THE CARDINAL
C   FUNCTIONS
C
      WX = AX(1)*Z1 + AX(2)*Z2 + AX(3)*Z3 + (BX(1)*ZX1 +
     .     BX(2)*ZX2 + BX(3)*ZX3 + CX(1)*ZY1 + CX(2)*ZY2 +
     .     CX(3)*ZY3)/2.
      WY = AY(1)*Z1 + AY(2)*Z2 + AY(3)*Z3 + (BY(1)*ZX1 +
     .     BY(2)*ZX2 + BY(3)*ZX3 + CY(1)*ZY1 + CY(2)*ZY2 +
     .     CY(3)*ZY3)/2.
      RETURN
C
C VERTICES ARE COLLINEAR
C
    9 IER = 1
      W = 0.
      IF (IFLAG .NE. 1) RETURN
      WX = 0.
      WY = 0.
      RETURN
      END
      SUBROUTINE MFIT(DIMEN,FITDEG,NFPOLS,NFPTS,
     +                FITCDS,NCROWS,FITVLS,WTS,
     +                RESIDS,ERROR,FITIWK,FITDWK,
     +                FIWKLN,FDWKLN,IREQD,DREQD)
C
      INTEGER NFPOLS,FITDEG,NFPTS,DIMEN,FIWKLN,FDWKLN
      INTEGER ERROR,IREQD,DREQD,INDSTT,P,DIMP1,NCROWS
      INTEGER NEWSTT,MAXSTT,ALFSTT,PSISTT,CSTT,SSQSTT,PSIWID,ALFL
      INTEGER FITIWK(FIWKLN)
      REAL    FITDWK(FDWKLN),FITCDS(NCROWS,DIMEN)
      REAL    FITVLS(NFPTS),RESIDS(NFPTS)
      REAL    WTS(NFPTS)
      REAL    SCALE
C
C     ***************
C     PURPOSE
C     -------
C
C     THIS SUBROUTINE CONSTRUCTS A LEAST-SQUARES  MULTINOMIAL  FIT  TO
C     GIVEN DATA USING A BASIS OF ORTHOGONAL MULTINOMIALS.
C
C     THE DATA FOR THE FIT IS GIVEN IN THE ARRAYS FITCDS, FITVLS, AND
C     WTS. FITCDS IS A MATRIX, EACH ROW OF WHICH CONTAINS AN OBSERVA-
C     TION POINT. FITVLS IS A SINGLY-INDEXED ARRAY, EACH ELEMENT OF
C     WHICH CONTAINS A FUNCTION VALUE CORRESPONDING TO AN OBSERVATION
C     POINT. WTS IS A SINGLY-INDEXED ARRAY, EACH ELEMENT OF WHICH IS
C     A NONNEGATIVE WEIGHT FOR THE CORRESPONDING OBSERVATION.
C
C     THE FIT WHICH IS PRODUCED IS A MULTINOMIAL EXPRESSED IN THE FORM
C
C      C  PSI  (X ,...,X     ) +...+ C       PSI       (X ,...,X     )
C       1    1   1      DIMEN         NFPOLS    NFPOLS   1      DIMEN
C
C     WHERE THE VALUE OF  NFPOLS  WILL BE AS GIVEN (IF  FITDEG .LT. 0)
C     OR  AS  COMPUTED  BY  MFIT  TO GIVE A FULL-DEGREE FIT (IN CASE
C     FITDEG  IS SPECIFIED .GE. 0).  THE ELEMENTS
C
C         PSI  (X ,...,X     )
C            K   1      DIMEN
C
C     FORM A BASIS FOR THE MULTINOMIALS WHICH IS ORTHOGONAL WITH
C     RESPECT TO THE WEIGHTS AND OBSERVATION POINTS.
C
C     THE EXTENT OF THE FIT CAN BE SPECIFIED IN ONE OF TWO WAYS.
C         IF THE PARAMETER FITDEG IS SET .GE. 0, THEN A COMPLETE BASIS
C         FOR THE MULTINOMIALS OF DEGREE =  FITDEG  WILL BE USED.  (AN
C         ERROR WILL BE  FLAGGED  IF  THIS  WILL  REQUIRE  MORE  BASIS
C         MULTINOMIALS  THAN  THE  NUMBER  OF  DATA  POINTS WHICH WERE
C         GIVEN.)
C         IF THE PARAMETER  FITDEG  IS .LT.  0, THEN  NFPOLS  WILL  BE
C         TAKEN AS THE COUNT OF THE NUMBER OF BASIS MULTINOMIALS TO BE
C         USED FOR A PARTIAL-DEGREE FIT.  (AN ERROR WILL BE FLAGGED IF
C         NFPOLS  .LT. 0.)
C
C     VARIABLES
C     ---------
C
C      DIMEN  -- (INTEGER) -- (PASSED)
C         THE NUMBER OF VARIABLES.
C      FITDEG  - (INTEGER) -- (PASSED/RETURNED)
C         IGNORED IF .LT. 0.
C         IF FITDEG .GE. 0 THEN  FITDEG  IS  CHECKED  AGAINST  NFPTS .
C         THE VALUE OF  FITDEG  WILL BE REDUCED IF THERE IS A BASIS OF
C         MULTINOMIALS, ALL OF  DEGREE  .LE. FITDEG ,  OF  CARDINALITY
C         NFPTS .  SEE  ERROR  BELOW.
C      NFPOLS  - (INTEGER) -- (PASSED/RETURNED)
C         IGNORED IF  FITDEG  .GE. 0.
C         IF  FITDEG .LT. 0 THEN THE VALUE OF NFPOLS WILL BE TAKEN  AS
C         THE SIZE OF THE BASIS OF MULTINOMIALS TO BE USED IN THE FIT.
C         NFPOLS  MUST SATISFY  NFPOLS  .LT. NFPTS  AND NFPOLS .GE. 1
C         SEE  ERROR  BELOW.
C      NFPTS  --- (INTEGER) -- (PASSED)
C         THE NUMBER OF DATA POINTS TO BE USED IN THE FIT.
C         NFPTS  MUST BE .GE. 1.  SEE  ERROR  BELOW.
C      FITCDS  -- (REAL 2-SUBSCRIPT ARRAY) -- (PASSED)
C         FITCDS (P,K) IS THE VALUE OF THE K-TH VARIABLE AT THE  P-TH
C         DATA POINT.
C      NCROWS  -- (INTEGER) -- (PASSED)
C         THE ROW DIMENSION  DECLARED  FOR   FITCDS   IN  THE  CALLING
C         PROGRAM.
C      FITVLS  -- (REAL 1-SUBSCRIPT ARRAY) -- (PASSED)
C         FITVLS (P) IS THE OBSERVED FUNCTION VALUE OF THE P-TH  DATA
C         POINT.
C      WTS  ----- (REAL 1-SUBSCRIPT ARRAY) -- (PASSED)
C         WTS (P) IS THE WEIGHT ATTACHED TO THE P-TH DATA POINT.
C      RESIDS  -- (REAL 1-SUBSCRIPT ARRAY) -- (RETURNED)
C         RESIDS (P) IS THE DIFFERENCE BETWEEN THE FITTED FUNCTION AT
C         POINT P AND  FITVLS (P).
C      ERROR  -- (INTEGER) -- (RETURNED)
C       0 THE DESIRED LEAST SQUARE MULTINOMIAL FIT WAS OBTAINED.
C      -1 ONLY THE FIRST NFPOLS BASIS POLYNOMIALS WERE OBTAINED.
C         FITDEG IS THE DEGREE OF THE FIT.
C       1 IF  FITDEG  .GE. 0 BUT THERE IS AN INTERPOLATING MULTINOMIAL
C         OF SMALLER DEGREE OR IF FITDEG .LT. 0 AND NFPOLS .GT. NFPTS.
C       2 IF  FITDEG  .LT. 0 AND  NFPOLS  .LE. 0.
C       3 IF  NFPTS  .LT. 1 AND/OR  DIMEN  .LT. 1.
C       4 IF  IWKLEN  AND/OR  DWKLEN  IS TOO SMALL.  (SET  IWKLEN   TO
C         THE VALUE RETURNED IN  IREQD , AND SET  DWKLEN  TO THE VALUE
C         RETURNED IN  DREQD  TO RESOLVE THIS PROBLEM.)
C      FITIWK  -- (INTEGER, 1-SUBSCRIPT ARRAY) -- (RETURNED)
C         AN INTEGER WORK ARRAY OF LENGTH  FIWKLN .  UPON RETURN  FROM
C         MFIT, FITIWK CONTAINS DIMENSION AND ARRAY LENGTH INFORMATION.
C      FITDWK  -- (REAL 1-SUBSCRIPT ARRAY) -- (RETURNED)
C         A REAL ARRAY OF LENGTH  FDWKLN  CONTAINING THE COEFFICIENTS
C         NEEDED FOR COMPUTING THE MULTINOMIAL FIT AT A POINT.
C      FIWKLN  -- (INTEGER) -- (PASSED)
C         THE LENGTH OF THE ARRAY  FITIWK .
C      FDWKLN  -- (INTEGER) -- (PASSED)
C         THE LENGTH OF THE ARRAY  FITDWK .
C      IREQD  -- (INTEGER) -- (RETURNED)
C         THE LENGTH WHICH THE ARRAY  FITIWK  REALLY NEEDS TO BE.
C      DREQD  -- (INTEGER) -- (RETURNED)
C         THE LENGTH WHICH THE ARRAY  FITDWK  REALLY NEEDS TO BE.
C
C
C     NOTE. THE 20 LOOP DEPENDS ON THE SCALING SCHEME BEING USED. THE
C     RESIDUAL SCALING MUST BE CONSISTENT WITH THAT DEFINED BY SCALPM
C     AND SCALDN.
C
C     MFIT  CALLS  ALLOT  AND  GNRTP.
C     ****************
C
      DIMP1 = DIMEN + 1
C
C     ***************
C
      CALL ALLOT(FITDEG,NFPOLS,NFPTS,DIMEN,FITIWK,FIWKLN,IREQD,DREQD,
     +           ERROR)
      IF ( ERROR .GE. 2 ) RETURN
C
      IF ( FDWKLN .GE. DREQD ) GO TO 10
         ERROR = 4
         RETURN
   10 CONTINUE
C
      PSIWID = FITIWK(3)
      ALFL = FITIWK(4)
      INDSTT = 1
      NEWSTT = 4 * NFPOLS + INDSTT
      MAXSTT = 1
      ALFSTT = MAXSTT + DIMP1
      CSTT = ALFSTT + ALFL
      SSQSTT = CSTT + NFPOLS
      PSISTT = SSQSTT + NFPOLS
C
C     ***************
C
         CALL GNRTP(FITDEG,FITDWK(ALFSTT),
     +              FITDWK(PSISTT),FITIWK(INDSTT),
     +              FITIWK(NEWSTT),FITDWK(SSQSTT),FITCDS,
     +              NCROWS,NFPOLS,DIMEN,NFPTS,FITVLS,RESIDS,
     +              FITDWK(CSTT),PSIWID,WTS,ALFL,DIMP1,
     +              FITDWK(MAXSTT),ERROR)
C
C     ***************
C     STORE THE NUMBER OF BASIS POLYNOMIALS ACTUALLY COMPUTED
C     BY THE MODIFIED ROUTINE INCDG CALLED BY GNRTP.
C     ***************
C
      FITIWK(1) = NFPOLS
C
C     ***************
C     UNSCALE THE RESIDUALS FOR THE BENEFIT OF THE USER.
C     ***************
C
      SCALE = FITDWK(DIMEN + 1)
      DO 20 P = 1,NFPTS
        RESIDS(P) = RESIDS(P) * SCALE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE ALLOT(DEGREE,NPOLYS,NPTS,DIMEN,IWORK,IWKLEN,
     +                 IREQD,DREQD,ERROR)
C
      INTEGER IREQD,DREQD,ALFL,ERROR,NPOLYS,DEGREE,DIMEN,NPTS
      INTEGER NEWSTT,PSIWID,KMXBAS,STARTJ,KJP1D2,INDEX,IWKLEN
      INTEGER NPLYT4
      INTEGER IWORK(IWKLEN)
C
C     ***************
C     PURPOSE
C     -------
C
C      ALLOT  CHECKS FOR SUFFICIENCY THE DECLARED  DIMENSIONS  OF  THE
C     WORK  ARRAYS  USED BY THE SUBROUTINE  MFIT .  VARIOUS SIZES OF
C     SUB-ARRAYS ARE COMPUTED AND REPORTED.
C
C     THIS ROUTINE IS CALLED BY  MFIT .  IT IS NOT  CALLED  DIRECTLY
C     BY THE USER.
C
C     THIS ROUTINE CALLS   BASIZ   AND   MTABLE   FOR  THE  SUBSTANTIVE
C     COMPUTATIONS.
C
C     VARIABLES
C     ---------
C
C      DEGREE  - (PASSED/RETURNED)
C         IGNORED IF .LT. 0.
C         IF  DEGREE  .GE. 0 THEN  DEGREE IS CHECKED  AGAINST   NPTS .
C         THE VALUE OF  DEGREE  WILL BE REDUCED IF THERE IS A BASIS OF
C         MULTINOMIALS, ALL OF  DEGREE .LE.  DEGREE ,  OF  CARDINALITY
C          NPTS
C      NPOLYS  - (PASSED/RETURNED)
C         IGNORED IF  DEGREE  .GE. 0.
C         IF DEGREE .LT. 0 THEN THE VALUE OF NPOLYS WILL BE TAKEN  AS
C         THE SIZE OF THE BASIS OF MULTINOMIALS TO BE USED IN THE FIT.
C         NPOLYS  MUST SATISFY NPOLYS .LT.  NPTS  AND  NPOLYS  .GE. 1
C      NPTS  --- (PASSED)
C         THE NUMBER OF DATA POINTS TO BE USED IN THE FIT.
C          NPTS  MUST BE .GE. 1.
C      DIMEN  -- (PASSED)
C         THE NUMBER OF VARIABLES.
C      IWORK  -- (RETURNED)
C         AN INTEGER WORK ARRAY OF LENGTH AT LEAST
C            IF  DEGREE  .GE. 0 THEN
C               4*BINOMIAL( DIMEN + DEGREE , DIMEN )
C                  +( DIMEN )*( DEGREE )
C            ELSE
C               4*BINOMIAL( DIMEN +D,D)+( DIMEN )*D
C         WHERE D IS THE MINIMUM CARDINALITY  OF  A  BASIS  OF  DEGREE
C          DEGREE  SUCH THAT
C            BINOMIAL( DIMEN +ABS( DEGREE ), DIMEN ) .GE.  NPOLYS
C      IWKLEN  - (PASSED)
C         THE LENGTH OF  IWORK
C      IREQD  -- (RETURNED)
C         THE SIZE OF THE INTEGER WORK ARRAY REQUIRED BY  MFIT   FOR
C         THE FIT SPECIFIED BY THE 4 INPUT PARAMETERS.
C      DREQD  -- (RETURNED)
C         THE SIZE OF THE DOUBLE  PRECISION  WORK  ARRAY  REQUIRED  BY
C          MFIT  FOR THE FIT SPECIFIED BY THE 4 INPUT PARAMETERS.
C      ERROR  -- (RETURNED)
C       0 IF  NPOLYS ,  DIMEN ,   DEGREE ,   NPTS   AND   IWKLEN   ARE
C         VALID AND CONSISTENT WITH EACH OTHER.
C       1 IF  DEGREE  .GE. 0 BUT THERE IS AN INTERPOLATING MULTINOMIAL
C         OF SMALLER DEGREE OR IF  DEGREE .LT. 0 AND  NPOLYS .GT. NPTS
C       2 IF  DEGREE  .LT. 0 AND  NPOLYS  .LE. 0
C       3 IF  NPTS  .LT. 1 AND/OR  DIMEN  .LT. 1
C       4 IF  IWKLEN  IS TOO SMALL (SET  IWKLEN  TO THE VALUE RETURNED
C         IN  IREQD  TO RESOLVE THIS PROBLEM)
C
C     NOTE THAT  DEGREE ,  NPOLYS ,  PSIWID  AND  ALFL   ARE  RETURNED
C     IN  IWORK (1-4), RESPECTIVELY.
C
C     DATE LAST MODIFIED
C     ---- ---- --------
C     DECEMBER 10, 1984
C     ****************
C
C     ***************
C     BASIZ  COMPUTES THE SIZE OF THE BASIS (AND AUXILIARY SIZES)
C     BASED PRIMARILY UPON THE DEGREE, NUMBER OF  FITTING POINTS,
C     AND THE DIMENSION.
C     ***************
C
      CALL BASIZ(DEGREE,NPTS,DIMEN,NPOLYS,ERROR)
      IF ( ERROR .GE. 2 ) RETURN
      IREQD = 4 * NPOLYS + DEGREE * DIMEN
      IF ( IWKLEN .GE. IREQD ) GO TO 5
         ERROR = 4
         RETURN
 5    NEWSTT = 4 * NPOLYS + 1
C
C     ***************
C     SET UP USEFUL INDEXING ARRAYS
C          IWORK(1) ,..., IWORK(NEWSTT-1)
C     AND
C          IWORK(NEWSTT ,..., IWORK(NEWSTT+DIMEN*DEGREE)
C     ***************
C
      CALL MTABLE(DEGREE,DIMEN,NPOLYS,IWORK,IWORK(NEWSTT),ALFL)
      IWORK(1) = DEGREE
      IWORK(2) = NPOLYS
C
C     ***************
C     FORCE  ALFL  TO BE AT LEAST 1 SO THAT DIMENSION STATEMENTS
C     USING  ALFL  DO NOT BOMB.
C     ***************
C
      IF ( ALFL .GT. 1 ) ALFL = ALFL - 1
      IWORK(4) = ALFL
C
C     ***************
C     THE FOLLOWING IS A SECTION OF CODE FOR SETTING UP THE
C     STORAGE  MANAGEMENT OF THE  PSI  ARRAY.  THERE  IS  A
C     COMPLICATED DOVETAILING FORMULA USED TO PACK INFORMATION
C     INTO  PSI  WITHOUT LEAVING GAPS.
C
C     ARRAY          LENGTH
C     -----          ------
C      MAXABS         DIMEN  + 1
C      ALPHA          ALFL
C      C              NPOLYS
C      SUMSQS         NPOLYS
C
C     THE NUMBER OF COLUMNS IN  PSI ,  PSIWID , IS DETERMINED BY
C     PSIWID  =  NPOLYS  + 1 - (THE SMALLEST M SUCH THAT ALPHA(J,M)
C                                   IS NONZERO AND J .GE. NPOLYS)
C     THIS INSURES THAT IF THE USER EXTENDS THE BASIS, ALL THE  PSI
C     REQUIRED WILL CERTAINLY BE STORED
C
C     IF DEGREE( NPOLYS ) .LE. 2 THEN                      (CASE 1)
C       PSIWID  =  NPOLYS
C     ELSE
C       IF K =  DIMEN  THEN                                (CASE 2)
C         PSIWID  =  NPOLYS
C                    -  NEWKJ( 1 , DEGREE(NPOLYS)-1 )  + 1
C       ELSE
C            PSIWID  =  NPOLYS
C                      + 1
C                      - (
C                         THE SMALLER OF
C                           NEWKJ(K+1,DEGREE(NPOLYS)-2)    (CASE 3)
C                         AND
C                           INDEXS(3,NPOLYS)               (CASE 4)
C                        )
C
      IF ( DEGREE .GT. 2 ) GO TO 10
C
C     ***************
C     CASE 1
C     ***************
C
         PSIWID = NPOLYS
      GO TO 40
 10      NPLYT4 = 4 * NPOLYS
C
C     ***************
C     KMXBAS  IS K
C                 NPOLYS
C     ***************
C
         KMXBAS = IWORK(NPLYT4 - 2)
C
         IF ( KMXBAS .NE. DIMEN ) GO TO 20
C
C     ***************
C     CASE 2
C     ***************
C
            PSIWID = NPOLYS - IWORK(4 * NPOLYS - 1)
         GO TO 40
C
C     ***************
C     INDEX =  NEWKJ( K      + 1 , DEGREE(NPOLYS-2) )
C                      NPOLYS
C     ***************
C
 20         INDEX = NPLYT4 + (DEGREE - 3) * DIMEN + KMXBAS + 1
            KJP1D2 = IWORK(INDEX)
C
C     ***************
C     STARTJ  =  INDEXS(3,NPOLYS)
C     ***************
C
            STARTJ = IWORK(NPLYT4 - 1)
            IF ( STARTJ .GT. KJP1D2 ) GO TO 30
C
C     ***************
C     CASE 4
C     ***************
C
               PSIWID = NPOLYS - STARTJ + 1
            GO TO 40
C
C     ***************
C     CASE 3
C     ***************
C
 30            PSIWID = NPOLYS - KJP1D2 + 1
 40   IWORK(3) = PSIWID
      DREQD = 2 * NPOLYS + DIMEN + 1 + NPTS * PSIWID + ALFL
      RETURN
      END
      SUBROUTINE BASIZ(DEGREE,NPTS,DIMEN,NPOLYS,ERROR)
C
      INTEGER TOP,BOT,DEGREE,NPTS,DIMEN,NPOLYS,ERROR,I,ROWLEN
C
C     ***************
C     PURPOSE
C     -------
C
C     IF  DEGREE  .GE. 0 THEN
C       FIND THE SIZE OF A BASIS REQUIRED EITHER TO
C       1) APPROXIMATE THE DATA WITH A POLYNOMIAL OF DEGREE
C          GIVEN BY THE PARAMETER  DEGREE
C       OR TO
C       2) SPAN THE SPACE OF POLYNOMIALS OF DEGREE .LE. THE
C          SMALLEST DEGREE OF POLYNOMIAL WHICH INTERPOLATES THE
C          DATA.
C       IN CASE 1  ERROR  = 0.
C       IN CASE 2  ERROR  = 1.
C     ELSE
C       IF  NPOLYS  .GE. 1 THEN
C          IF NPOLYS .GT. NPTS THEN
C             SET  NPOLYS  =  NPTS , FIND THE SMALLEST DEGREE OF A
C             POLYNOMIAL  WHICH  INTERPOLATES  THE  DATA,  AND SET
C              ERROR  = 1.
C          ELSE
C             FIND THE LARGEST DEGREE  DEGREE  OF A POLYNOMIAL  IN
C             A  BASIS OF  NPOLYS  POLYNOMIALS GENERATED ACCORDING
C             TO OUR ORDERING AND SET  ERROR  = 0.
C       ELSE
C           ERROR  = 2
C
C     THIS SUBROUTINE IS CALLED BY  ALLOT .  IT IS NOT  CALLED  BY
C     THE USER DIRECTLY.
C
C     DATE LAST MODIFIED
C     ---- ---- --------
C     OCTOBER 16, 1984
C     ****************
C
      ERROR = 0
      IF ( NPTS .GE. 1 .AND. DIMEN .GE. 1 ) GO TO 10
         ERROR = 3
         RETURN
C
 10   CONTINUE
      IF ( DEGREE .LT. 0 ) GO TO 30
C
        ROWLEN = 1
        NPOLYS = 1
        TOP = DIMEN - 1
        BOT = 0
        IF ( DEGREE .LT. 1 )  GO TO 30
          DO 20 I=1,DEGREE
            TOP = TOP + 1
            BOT = BOT + 1
            ROWLEN = (ROWLEN*TOP)/BOT
            NPOLYS = NPOLYS + ROWLEN
   20     CONTINUE
C
   30 CONTINUE
      IF ( NPOLYS .GE. 1 ) GO TO 40
            ERROR = 2
            RETURN
   40 CONTINUE
      IF ( NPOLYS .LT. NPTS ) GO TO 50
            NPOLYS = NPTS
            ERROR = 1
   50 CONTINUE
      ROWLEN = 1
      I = 1
      DEGREE = 0
      TOP = DIMEN - 1
      BOT = 0
   60 CONTINUE
      IF ( I .GE. NPOLYS )  GO TO 70
          TOP = TOP + 1
          BOT = BOT + 1
          ROWLEN = (ROWLEN*TOP)/BOT
          I = I + ROWLEN
          DEGREE = DEGREE + 1
          IF ( I .LT. NPOLYS )  GO TO 60
   70 CONTINUE
      RETURN
      END
      SUBROUTINE MTABLE(DEGREE,DIMEN,NPOLYS,INDEXS,NEWKJ,ALFLP1)
C
      INTEGER J,KJ,CURDEG,JPRIME,NWITHK,I,CURM1,RALEN,DIMM1,DIMM2
      INTEGER NPOLYS,DIMEN,DEGREE,ALFLP1,DIMP1
      INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE)
C
C     ***************
C     PURPOSE
C     -------
C
C     TABULATE  JP  AND  KJ  FOR EACH  J
C
C     VARIABLES
C     ---------
C
C      ALFLP1  -- (INTEGER) -- (PASSED)
C         THE LENGTH REQUIRED FOR ARRAY  ALPHA , PLUS ONE
C      DEGREE  -- (INTEGER) -- (PASSED)
C         THE DEGREE OF THE POLYNOMIAL TO BE FITTED
C      DIMEN  -- (INTEGER) -- (PASSED)
C         NUMBER OF INDEPENDENT VARIABLES
C      INDEXS  -- (INTEGER, 2-SUBSCRIPT ARRAY) -- (RETURNED)
C          INDEXS (1, J )   IS    JP ,    INDEXS (2, J )   IS     KJ ,
C          INDEXS (3, J )  IS THE FIRST NONZERO RECURRENCE COEFFICIENT
C         IN  ALPHA  AND  INDEXS (4, J ) IS ITS LOCATION IN  ALPHA .
C      NEWKJ  -- (INTEGER, 2-SUBSCRIPT ARRAY) -- (RETURNED)
C          NEWKJ ( K , D ) IS THE FIRST MONOMIAL OF DEGREE  D   HAVING
C          KJ = K .
C      NPOLYS  -- (INTEGER) -- (PASSED)
C         NUMBER  OF  MONOMIALS  OF  DEGREE  .LE.  ORDER  IN   DIMEN
C         INDEPENDENT VARIABLES.
C
C     THIS SUBPROGRAM CAN BE CODED (EXCLUDING THE PART FOR CALCULATING
C      INDEXS (3, J )  AND   INDEXS (4, J )) MENTALLY MORE EFFICIENTLY
C     BUT COMPUTATIONALLY LESS EFFICIENTLY AS
C
C         J = 2
C         DO 5 KJ = 1,DIMEN
C           NEWKJ(KJ,1) = KJ + 1
C           INDEXS(1,J) = 1
C           INDEXS(2,J) = KJ
C           J = J + 1
C      5  CONTINUE
C         DO 10 CURDEG = 2,DEGREE
C           DO 10 KJ = 1,DIMEN
C             JPRIME = NEWKJ(KJ,CURDEG - 1)
C             NEWKJ(KJ,CURDEG) = J
C             NWITHK = COMB(DIMEN + CURDEG - KJ - 1,CURDEG - 1)
C             DO 10 I = 1,NWITHK
C               INDEXS(1,J) = JPRIME
C               INDEXS(2,J) = KJ
C               JPRIME = JPRIME + 1
C               J = J + 1
C     10  CONTINUE
C
C     WHERE COMB(N,KJ) IS N-FACTORIAL / ((N-KJ)-FACTORIAL * KJ-FACTORIAL
C     HERE WE MAKE USE OF THE RECURRENCE RELATIONS
C
C       COMB(DIMEN+CURDEG-2,CURDEG-1)
C
C            (DIMEN+CURDEG-2)*COMB(DIMEN+CURDEG-3,CURDEG-2)
C          = ----------------------------------------------
C                              (CURDEG-1)
C
C     AND
C
C       COMB(DIMEN+CURDEG-KJ-1,CURDEG-1)
C
C            (DIMEN-KJ+1)*COMB(DIMEN+CURDEG-KJ,CURDEG-1)
C          = -------------------------------------------
C                         (DIMEN+CURDEG-KJ)
C
C
C     DATE LAST MODIFIED
C     ---- ---- --------
C     OCTOBER 16, 1984
C     ****************
C
      ALFLP1 = 1
C
C     ***************
C     SET  INDEXS (4,1) TO 1 SO THAT  ALFL - INDEXS (4,1)+1 IS THE
C     NUMBER OF COLUMNS REQUIRED FOR  PSI  FOR  NPOLYS =1  ( ALFL
C     IS DEFINED IN THE MAINLINE TO BE  ALFLP1 -1 IF ALFLP1 .GT. 1
C     AND  ALFLP1  OTHERWISE.
C     ***************
C
      INDEXS(4,1) = 1
C
      IF ( NPOLYS .EQ. 1 ) RETURN
      J = 2
      DO 10 KJ = 1,DIMEN
         NEWKJ(KJ,1) = KJ + 1
         INDEXS(1,J) = 1
         INDEXS(2,J) = KJ
         INDEXS(3,J) = 1
         INDEXS(4,J) = ALFLP1
         ALFLP1 = ALFLP1 + J - 1
         IF ( J .EQ. NPOLYS ) RETURN
10       J = J + 1
      IF ( DEGREE .EQ. 1 ) RETURN
      RALEN = 1
      DIMM1 = DIMEN - 1
      DIMM2 = DIMEN - 2
      DIMP1 = DIMEN + 1
      DO 70 CURDEG = 2,DEGREE
         CURM1 = CURDEG - 1
         RALEN = (RALEN * (DIMM2 + CURDEG)) / CURM1
         NWITHK = RALEN
         KJ = 1
20       JPRIME = NEWKJ(KJ,CURM1)
         NEWKJ(KJ,CURDEG) = J
         IF ( KJ .EQ. DIMEN ) GO TO 60
            DO 50 I = 1,NWITHK
               INDEXS(1,J) = JPRIME
               INDEXS(2,J) = KJ
C
C     ***************
C     CALCULATE  INDEXS (3, J ),  INDEXS (4, J )
C     ***************
C
               IF ( KJ .LT. INDEXS(2,JPRIME) ) GO TO 30
                  INDEXS(3,J) = INDEXS(1,JPRIME)
                  GO TO 40
 30            INDEXS(3,J) = NEWKJ(1,CURDEG - 1)
 40            INDEXS(4,J) = ALFLP1
               ALFLP1 = ALFLP1 + J - INDEXS(3,J)
               IF ( J .EQ. NPOLYS ) RETURN
C
               JPRIME = JPRIME + 1
 50            J = J + 1
            KJ = KJ + 1
            NWITHK = (NWITHK * (DIMP1 - KJ)) / (DIMEN + CURDEG - KJ)
            GO TO 20
 60      INDEXS(1,J) = JPRIME
         INDEXS(2,J) = DIMEN
         INDEXS(3,J) = INDEXS(1,JPRIME)
         INDEXS(4,J) = ALFLP1
         ALFLP1 = ALFLP1 + J - INDEXS(3,J)
         IF ( J .EQ. NPOLYS ) RETURN
 70      J = J + 1
      RETURN
      END
      SUBROUTINE GNRTP(DEGREE,ALPHA,PSI,INDEXS,
     +                 NEWKJ,SUMSQS,COORD,NCROWS,NPOLYS,
     +                 DIMEN,NPTS,F,Z,C,PSIWID,WEIGHT,
     +                 ALFL,DIMP1,MAXABS,ERROR)
C
      INTEGER DEGREE,DIMEN,NPOLYS,NPTS,K,PSIWID,ALFL,P,STTDEG,ONPLYS
      INTEGER ERROR,DIMP1
      INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE)
      REAL    PSI(NPTS,PSIWID),ALPHA(ALFL),F(NPTS)
      REAL    COORD(NCROWS,DIMEN),MAXABS(DIMP1),WEIGHT(NPTS)
      REAL    Z(NPTS),SUMSQS(NPOLYS),C(NPOLYS)
      REAL    RUNTOT,RNTOT1
C
C     ***************
C     PURPOSE
C     -------
C
C     THE MULTINOMIAL FIT IS GENERATED INCREMENTALLY, A BASIS  ELEMENT
C     AT A TIME.  THIS SUBROUTINE STARTS THE PROCESS OFF BY SETTING UP
C     THE FIRST BASIS ELEMENT, SCALING THE  DATA,  FINDING  THE  FIRST
C     COEFFICIENT,  AND  INITIALIZING  THE  WORK ARRAY Z.  GNRTP  THEN
C     CALLS  INCDG  IF MORE THAN ONE BASIS ELEMENT IS REQUIRED.
C
C     THIS SUBROUTINE IS CALLED BY  MFIT .  IT IS NOT CALLED BY  THE
C     USER.
C
C     THIS SUBROUTINE CALLS  SCALPM ,  SCALDN , AND  INCDG .
C
C
C     MODIFIED BY A.H. MORRIS (NSWC)
C     ****************
C
C     ***************
C     SET UP THE SCALING.
C     ***************
C
      DO 10 K = 1,DIMEN
         CALL SCALPM(COORD(1,K),NPTS,MAXABS(K))
 10      CALL SCALDN(COORD(1,K),NPTS,MAXABS(K))
      CALL SCALPM(F,NPTS,MAXABS(DIMP1))
      CALL SCALDN(F,NPTS,MAXABS(DIMP1))
C
C     ***************
C      SUMSQS (1) = (1,1)
C     C  = (F,1) / (1,1)
C      1
C     ***************
C
      RUNTOT = 0.0
      RNTOT1 = 0.0
      DO 20 P = 1,NPTS
         PSI(P,1) = 1.0
         RNTOT1 = RNTOT1 + WEIGHT(P)
 20      RUNTOT = RUNTOT + F(P) * WEIGHT(P)
      SUMSQS(1) = RNTOT1
      C(1) = RUNTOT / RNTOT1
C
C     ***************
C     Z = F - C
C              1
C     ***************
C
      DO 30 P = 1,NPTS
 30      Z(P) = F(P) - C(1)
C
      IF ( NPOLYS .EQ. 1 ) RETURN
      STTDEG = 1
      ONPLYS = 1
C
      CALL INCDG(DEGREE,ALPHA,PSI,INDEXS,NEWKJ,SUMSQS,
     +           COORD,NCROWS,NPOLYS,DIMEN,NPTS,F,Z,C,PSIWID,
     +           WEIGHT,ALFL,ONPLYS,STTDEG,ERROR)
      RETURN
      END
      SUBROUTINE INCDG(DEGREE,ALPHA,PSI,INDEXS,NEWKJ,
     +                 SUMSQS,COORD,NCROWS,NPOLYS,
     +                 DIMEN,NPTS,F,Z,C,PSIWID,WEIGHT,
     +                 ALFL,ONPLYS,STTDEG,ERROR)
C
      INTEGER JPRIME,P,J,CURDEG,KJ,KJP,L,JPM1,JM1
      INTEGER M,START,JINDEX,JPINDX,Q,J3,J1,J1MJ2,ERROR
      INTEGER J0MJ1,J1M1,STARTA,ONPLYS,ONPP1,STTDEG,INDEX1,INDEX2
      INTEGER DEGREE,NPOLYS,NPTS,DIMEN,PSIWID,ALFL
      INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE)
      REAL    ALPHA(ALFL),COORD(NCROWS,DIMEN),PSI(NPTS,PSIWID)
      REAL    SUMSQS(NPOLYS),C(NPOLYS),F(NPTS),WEIGHT(NPTS)
      REAL    Z(NPTS)
      REAL    ARC,RUNTOT,RNTOT1,RNTOT2
C
C     ***************
C     PURPOSE
C     -------
C
C     THE MULTINOMIAL FIT IS GENERATED INCREMENTALLY, A BASIS  ELEMENT
C     AT A TIME.  THIS SUBROUTINE CONTINUES THE PROCESS STARTED OFF BY
C      GNRTP .
C
C     THIS SUBROUTINE IS CALLED BY  GNRTP  AND NOT BY THE USER.
C
C
C     MODIFIED BY A.H. MORRIS (NSWC)
C
C     ****************
C
      IF ( ONPLYS .GE. 1 .AND. STTDEG .GE. 1 ) GO TO 10
         ERROR = 6
      RETURN
 10      IF ( INDEXS(2,ONPLYS) .EQ. DIMEN ) GO TO 20
            CURDEG = STTDEG
         GO TO 30
 20         CURDEG = STTDEG + 1
 30   ONPP1 = ONPLYS + 1
      DO 170 J = ONPP1,NPOLYS
         JPRIME = INDEXS(1,J)
         JINDEX = J - ((J - 1) / PSIWID) * PSIWID
         JPINDX = JPRIME - ((JPRIME - 1) / PSIWID) * PSIWID
         KJ = INDEXS(2,J)
         START = INDEXS(3,J)
         M = START
         STARTA = INDEXS(4,J) - START
         IF ( CURDEG .EQ. 1 ) GO TO 100
         KJP = INDEXS(2,JPRIME)
         J1 = NEWKJ(KJ,CURDEG - 1)
C
C     ***************
C     CALCULATE THOSE  ALPHA ( J , M ) THAT CAN BE CALCULATED FROM
C     PREVIOUSLY CALCULATED ALPHAS.
C     ***************
C
         IF ( KJ .LT. KJP ) GO TO 50
C
C     ***************
C     FIRST CALCULATE THOSE BETWEEN  JPP  AND THE END OF 2 ROWS BACK.
C     CALCULATE  ALPHA ( J , JPP )
C     ***************
C
         INDEX1 = INDEXS(4,J)
         ALPHA(INDEX1) = SUMSQS(JPRIME) / SUMSQS(START)
C
         M = START + 1
         J3 = NEWKJ(1,CURDEG - 1) - 1
         IF ( M .GT. J3 ) GO TO 50
C
C     ***************
C     CURDEG .GT. 2 IF CONTROL HAS PASSED THE BRANCHES IN THE 3-RD
C     PREVIOUS AND 8-TH PREVIOUS STATEMENTS.
C     ***************
C
            J1MJ2 = J1 - NEWKJ(KJ,CURDEG - 2)
C
            DO 40 L = M,J3
               Q = J1MJ2 + L
               INDEX1 = STARTA + L
               INDEX2 = INDEXS(4,Q) - INDEXS(3,Q) + JPRIME
 40            ALPHA(INDEX1) = ALPHA(INDEX2) * SUMSQS(JPRIME) /
     +         SUMSQS(L)
C
C     ***************
C     CALCULATE  ALPHA ( J , M ) FOR  M  BETWEEN THE 2
C     RANGES CALCULATED BEFORE USING
C
C        ALPHA ( J , L ) = (X  *  PSI  ,PSI )  / (PSI ,PSI )
C                             K      JP    L         L    L
C                              J
C     ***************
C
         M = J3 + 1
 50      IF ( JPRIME .EQ. J1 ) GO TO 100
            IF ( KJ .EQ. 1 ) GO TO 80
            J1M1 = J1 - 1
            DO 70 L = M,J1M1
               RUNTOT = 0.0
               DO 60 P = 1,NPTS
                  INDEX1 = L - ((L - 1) / PSIWID) * PSIWID
 60               RUNTOT = RUNTOT + COORD(P,KJ) * PSI(P,JPINDX) *
     +            PSI(P,INDEX1) * WEIGHT(P)
               INDEX1 = STARTA + L
 70            ALPHA(INDEX1) = RUNTOT / SUMSQS(L)
C
C     ***************
C     CALCULATE  ALPHA ( J , M ) FOR  M  BETWEEN
C      NEWKJ ( KJ , CURDEG  - 1)  AND
C      JP  - 1.
C     ***************
C
 80         J0MJ1 = NEWKJ(KJ,CURDEG) - J1
            JPM1 = JPRIME - 1
            DO 90 L = J1,JPM1
               Q = J0MJ1 + L
               INDEX1 = STARTA + L
               INDEX2 = INDEXS(4,Q) - INDEXS(3,Q) + JPRIME
 90            ALPHA(INDEX1) = ALPHA(INDEX2) * SUMSQS(JPRIME) /
     +         SUMSQS(L)
            M = JPRIME
C
C     ***************
C     CALCULATE THE REMAINING  ALPHA ( J , M ) FROM
C
C      ALPHA ( J , L ) = (X   * PSI  ,PSI ) / (PSI ,PSI )
C                          K       JP    L        L    L
C                           J
C     ***************
C
 100     JM1 = J - 1
         DO 120 L = M,JM1
            RUNTOT = 0.0
            DO 110 P = 1,NPTS
               INDEX1 = L - ((L - 1) / PSIWID) * PSIWID
 110           RUNTOT = RUNTOT + COORD(P,KJ) * PSI(P,JPINDX) *
     +         PSI(P,INDEX1) * WEIGHT(P)
            INDEX1 = STARTA + L
 120        ALPHA(INDEX1) = RUNTOT / SUMSQS(L)
C
C     ***************
C     NOW CALCULATE THE  PSI (P,J),  SUMSQS (J) AND  C (J) USING
C
C                          J-1
C     PSI  = X  * PSI   -  SUM   ALPHA(J,L) * PSI
C        J    K      JP    L=JPP                 L
C
C     SUMSQS  = (PSI ,PSI )
C           J       J    J
C
C     C  = (Z,PSI )
C      J         J
C     ***************
C
 130      JM1 = J - 1
          ARC = 0.0
          RNTOT1 = 0.0
          RNTOT2 = 0.0
          DO 150 P = 1,NPTS
              RUNTOT = COORD(P,KJ) * PSI(P,JPINDX)
              DO 140 L = START,JM1
                 INDEX1 = STARTA + L
                 INDEX2 = L - ((L - 1) / PSIWID) * PSIWID
 140             RUNTOT = RUNTOT - ALPHA(INDEX1) * PSI(P,INDEX2)
              PSI(P,JINDEX) = RUNTOT
              ARC = ARC + PSI(P,INDEX2) * PSI(P,JINDEX) *
     +                          WEIGHT(P)
              RNTOT1 = RNTOT1 + PSI(P,JINDEX) * PSI(P,JINDEX) *
     +                          WEIGHT(P)
 150          RNTOT2 = RNTOT2 + Z(P) * PSI(P,JINDEX) * WEIGHT(P)
          IF (ARC * ARC .GE. SUMSQS(JM1) * RNTOT1 * 1.E-03)
     +        GO TO 200
          SUMSQS(J) = RNTOT1
          C(J) = RNTOT2 / RNTOT1
C
C     ***************
C     CALCULATE THE NEW  Z ( P ) AND THE NEW  SSRES  USING
C
C     Z = Z - C  * PSI
C              J      J
C     ***************
C
          DO 160 P = 1,NPTS
 160          Z(P) = Z(P) - C(J) * PSI(P,JINDEX)
          STTDEG = CURDEG
 170      IF ( KJ .EQ. DIMEN ) CURDEG = CURDEG + 1
      RETURN
C
C     ***************
C     THE J-TH BASIS MULTINOMIAL CANNOT BE COMPUTED ACCURATELY.
C     ONLY J - 1 BASIS MULTINOMIALS ARE GENERATED.
C     ***************
C
 200  ERROR = -1
      DEGREE = STTDEG
      NPOLYS = JM1
      RETURN
      END
      SUBROUTINE SCALPM(COORD,NPTS,MAXABS)
C
      INTEGER NPTS,P
      REAL    MAXABS,A
      REAL    COORD(NPTS)
C
C     ***************
C     PURPOSE
C     -------
C
C     FIND SCALING PARAMETER(S) FOR THE PROBLEM. IF THE SCALING SCHEME
C     IS CHANGED, ALL FOUR OF THE FOLLOWING WOULD HAVE TO BE CHANGED
C
C     1)  SCALPM  - FIND THE SCALING PARAMETERS
C     2)  SCALDN  - SCALE THE PROBLEM DATA
C     3)  THE SCALING OF THE RESIDUALS IN  MFIT
C     4)  THE SCALING PERFORMED IN  MEVAL1
C
C     THIS SUBROUTINE IS CALLED BY  GNRTP .  IT IS NOT CALLED  BY  THE
C     USER.
C
C     THE SCALING WHICH  IT  DEFINES  MUST  BE  COORDINATED  WITH  THE
C     SCALING  OF RESIDUALS WHICH IS CARRIED OUT TOWARD THE END OF THE
C     SUBROUTINE  MFIT.  THE SCALING MUST ALSO BE COORDINATED WITH THE
C     SCALING PERFORMED IN THE 10 LOOP  AND  AT STATEMENTS 40 AND 50
C     (WITH THE SCALE FACTOR MAXABS(DIMP1)) IN  MEVAL1.
C
C     ****************
C
      MAXABS = 0.0
      DO 10 P = 1,NPTS
         A = ABS(COORD(P))
   10    IF ( A .GT. MAXABS ) MAXABS = A
      RETURN
      END
      SUBROUTINE SCALDN(COORD,NPTS,MAXABS)
C
      INTEGER NPTS,P
      REAL    MAXABS
      REAL    COORD(NPTS)
C
C     ***************
C     PURPOSE
C     -------
C
C     CARRY OUT THE DATA-SCALING WHICH IS DEFINED  BY  THE  SUBROUTINE
C     SCALPM .
C
C     THIS SUBROUTINE IS CALLED BY  GNRTP .  IT IS NOT CALLED  BY  THE
C     USER.
C
C     THE SCALING WHICH THIS ROUTINE CARRIES OUT  MUST  BE  CONSISTENT
C     WITH THE SCALING IN THE SUBROUTINES MFIT AND MEVAL1.
C
C     ****************
C
      IF ( MAXABS .EQ. 0.0E+00 ) RETURN
         DO 10 P = 1,NPTS
   10       COORD(P) = COORD(P) / MAXABS
         RETURN
      END
      SUBROUTINE MEVAL(DIMEN,EVLDEG,NEPOLS,NEPTS,EVLCDS,NEROWS,EVLVLS,
     +                 ERROR,FITIWK,FITDWK,FIWKLN,FDWKLN,TEMP)
C
      INTEGER FIWKLN,FDWKLN,NEPOLS,NEPTS,DIMEN,ERROR,MAXSTT,ALFSTT,CSTT
      INTEGER GBASIZ,ALFL,DIMP1,EVLDEG,TOP,BOT,CURDEG,PSISTT
      INTEGER FITIWK(FIWKLN)
      REAL    FITDWK(FDWKLN),EVLCDS(NEROWS,DIMEN)
      REAL    EVLVLS(NEPTS),TEMP(DIMEN)
C
C     ***************
C     PURPOSE
C     -------
C
C     THIS SUBROUTINE  EVALUATES  THE  LEAST-SQUARES  MULTINOMIAL  FIT
C     WHICH HAS BEEN PREVIOUSLY PRODUCED BY  MFIT .  EITHER THE FULL
C     MULTINOMIAL AS PRODUCED MAY BE EVALUATED,  OR  ONLY  AN  INITIAL
C     SEGMENT THEREOF.  AS IN THE CASE WITH  MFIT , IT IS POSSIBLE
C     (1) TO SPECIFY MULTINOMIALS OF A FULL GIVEN DEGREE, OR
C     (2) TO SPECIFY  THE  NUMBER  OF  ORTHOGONAL  BASIS  ELEMENTS  TO
C         ACHIEVE A PARTIAL-DEGREE FIT.
C
C     IN CASE (1), THE  DESIRED  DEGREE  IS  GIVEN  AS  THE  VALUE  OF
C     EVLDEG   (WHICH  MUST  BE  NONNEGATIVE AND NOT GREATER THAN THE
C     VALUE USED FOR  FITDEG  IN  MFIT ), AND THE PARAMETER  NEPOLS
C     WILL  BE  SET  BY  MEVAL  TO SPECIFY THE NUMBER OF BASIS ELEMENTS
C     REQUIRED. IF  EVLDEG  .LT.  FITDEG   IS  GIVEN,  THEN  ONLY  THE
C     INITIAL  PORTION OF THE FITTING MULTINOMIAL (OF DEGREE  EVLDEG )
C     WILL BE EVALUATED.
C
C     IN CASE (2),  EVLDEG  IS TO BE SET NEGATIVE, IN WHICH  CASE  THE
C     VALUE  OF   NEPOLS  (WHICH MUST BE POSITIVE AND NOT GREATER THAN
C     THE VALUE USED FOR   NFPOLS   IN   MFIT )  WILL  BE  TAKEN  AS
C     DEFINING  THE  INITIAL  PORTION OF THE FITTING MULTINOMIAL TO BE
C     EVALUATED.
C
C     IF  NEPOLS  =  NFPOLS  (WITH  EVLDEG  .LT.  0),  OR   EVLDEG   =
C     FITDEG  (WITH   EVLDEG   .GT.  0),  THEN  THE  FULL  MULTINOMIAL
C     GENERATED BY  MFIT  WILL BE EVALUATED.
C
C     THE  EVALUATION  WILL  TAKE  PLACE  FOR  EACH  OF   THE   POINTS
C     (COLLECTION  OF  VARIABLE  VALUES)  GIVEN AS A ROW OF THE MATRIX
C      EVLCDS .  THE  VALUES  PRODUCED  FROM  THE  FULL,  OR  PARTIAL,
C     MULTINOMIAL WILL BE PLACED IN THE ARRAY  EVLVLS .
C
C     VARIABLES
C     ---------
C
C      DIMEN  -- (INTEGER) -- (PASSED)
C         THE NUMBER OF VARIABLES.
C      EVLDEG  -- (INTEGER) -- (PASSED)
C         IF  EVLDEG  .LT. 0, THEN THIS PARAMETER WILL BE IGNORED.
C         IF  EVLDEG  .GE. 0, THEN THE VALUE OF  EVLDEG  MUST  SATISFY
C         EVLDEG  .LE. (THE  DEGREE  OF THE APPROXIMATING MULTINOMIAL
C         GENERATED IN  MFIT ).  IN THIS CASE  EVLDEG  WILL  SPECIFY
C         THE DEGREE OF THE INITIAL PORTION OF THE FITTING MULTINOMIAL
C         TO BE EVALUATED.
C      NEPOLS  -- (INTEGER) -- (PASSED/RETURNED)
C         IF  EVLDEG  .GE. 0, THEN THIS PARAMETER WILL BE IGNORED.
C         IF EVLDEG .LT. 0, THEN THE PARTIAL MULTINOMIAL INVOLVING THE
C         FIRST   NEPOLS  ORTHOGONAL BASIS FUNCTIONS WILL BE EVALUATED
C         AT THE POINTS GIVEN BY  EVLCDS .  THE RESULTING VALUES  WILL
C         BE STORED IN  EVLVLS .
C         THE VALUE OF NEPOLS MUST BE .GE. 1 AND .LE. (THE SIZE OF THE
C         BASIS  GENERATED  IN   MFIT ),  WHICH  WAS RETURNED AS THE
C         VALUE OF  NFPOLS .
C         NEPOLS  WILL BE CHANGED IF EVLDEG .GT. 0 TO GIVE THE SIZE OF
C         BASIS REQUIRED FOR THE MULTINOMIAL OF DEGREE  EVLDEG .
C      NEPTS  -- (INTEGER) -- (PASSED)
C         THE NUMBER OF EVALUATION POINTS.
C      EVLCDS  -- (REAL 2-SUBSCRIPT ARRAY) -- (PASSED)
C         EVLCDS (P,K) IS THE VALUE OF THE K-TH VARIABLE AT THE  P-TH
C         EVALUATION POINT.
C      NEROWS  -- (INTEGER) -- (PASSED)
C         THE ROW DIMENSION DECLARED FOR EVLCDS IN THE CALLING PROGRAM.
C      EVLVLS  -- (INTEGER) -- (RETURNED)
C         EVLVLS (P) IS THE VALUE OF THE EVALUATED MULTINOMIAL AT THE
C         P-TH EVALUATION POINT.
C      ERROR  -- (INTEGER) -- (RETURNED)
C          0 .........  IF NO ERRORS
C         -1 .........  IF  NEPOLS  .GT.  NFPOLS  OR  NEPOLS  .LT. 1
C         -2 .........  IF  NEPTS  .LT. 1 OR  DIMEN  .LT. 1
C      FITIWK  -- (INTEGER, 1-SUBSCRIPT ARRAY) -- (PASSED)
C         THE INTEGER WORK ARRAY OF LENGTH  FIWKLN  THAT WAS  USED  IN
C          MFIT .
C      FITDWK  -- (REAL 2-SUBSCRIPT ARRAY) -- (PASSED)
C         THE REAL WORK ARRAY OF LENGTH  FDWKLN  THAT WAS
C         USED IN  MFIT .
C      FIWKLN  -- (INTEGER) -- (PASSED)
C         THE LENGTH OF  FITIWK .
C      FDWKLN  -- (INTEGER) -- (PASSED)
C         THE LENGTH OF  FITDWK .
C      TEMP    -- (REAL 1-SUBSCRIPT ARRAY)
C         A WORK ARRAY OF LENGTH  DIMEN  (OR LONGER).
C
C     THE SUBROUTINE  MEVAL1  IS CALLED TO DO THE ACTUAL EVALUATION.
C
C     MODIFIED BY A.H. MORRIS (NSWC)
C
C     ****************
C
C
C     ***************
C     SET UP INDEX POINTERS TO THE BEGINNING OF EACH ROW OF
C     THE MTABLE -- THIS SETS THE BEGINNING POINT FOR EACH
C     FULL MULTINOMIAL DEGREE.
C     ***************
C
      IF (NEPTS .LT. 1 .OR. DIMEN .LT. 1) GO TO 110
      IF (EVLDEG) 40,10,20
C
   10 NEPOLS = 1
      GO TO 50
C
   20 TOP = 1
      BOT = 1
      DO 30 CURDEG = 1,EVLDEG
         TOP = TOP * (DIMEN + CURDEG)
   30    BOT = BOT * CURDEG
      NEPOLS = TOP / BOT
C
   40 GBASIZ = FITIWK(1)
      IF (NEPOLS .GT. GBASIZ .OR. NEPOLS .LT. 1) GO TO 100
C
   50 ERROR = 0
      DIMP1 = DIMEN + 1
      ALFL = FITIWK(4)
      MAXSTT = 1
      ALFSTT = DIMP1 + MAXSTT
      CSTT = ALFSTT + ALFL
      PSISTT = CSTT + FITIWK(2)
C
C     ***************
C     THE ACTUAL EVALUATION IS DONE INSIDE  MEVAL1.
C     ***************
C
      CALL MEVAL1 (EVLCDS,NEROWS,FITDWK(CSTT),NEPTS,DIMEN,NEPOLS,
     +             FITDWK(ALFSTT),FITIWK,FITDWK(PSISTT),
     +             EVLVLS,ALFL,FITDWK(MAXSTT),TEMP,DIMP1)
      RETURN
C
C     ***************
C     ERROR RETURN
C     ***************
C
  100 ERROR = -1
      RETURN
  110 ERROR = -2
      RETURN
      END
      SUBROUTINE MEVAL1 (COORD,NCROWS,C,NEPTS,DIMEN,NPOLYS,ALPHA,
     +                   INDEXS,PSI,F,ALFL,MAXABS,X,DIMP1)
C
      INTEGER DIMEN,NEPTS,NPOLYS,ALFL,DIMP1
      INTEGER JM1,JPRIME,M,P,K,I,J,INDEX
      INTEGER INDEXS(4,NPOLYS)
      REAL    ALPHA(ALFL),COORD(NCROWS,DIMEN),PSI(NPOLYS)
      REAL    C(NPOLYS),F(NEPTS),MAXABS(DIMP1),X(DIMEN)
      REAL    RUNTOT,RNTOT1
C
C     ***************
C     PURPOSE
C     -------
C
C     THIS SUBROUTINE PERFORMS THE MAIN WORK OF EVALUATING THE
C     FITTING MULTINOMIAL (OR THE INITIAL PORTION OF IT  WHICH
C     IS REQUESTED BY THE SETTING OF  NEPOLS ,  EVLDEG  IN THE
C     CALL TO SUBROUTINE  MEVAL .
C
C     THIS SUBROUTINE IS CALLED BY  MEVAL .  IT IS  NOT  CALLED
C     DIRECTLY BY THE USER.
C
C     THE BODY OF THIS SUBROUTINE FOLLOWS THE EXPLANATION
C     GIVEN IN
C          LEAST SQUARES FITTING USING
C          ORTHOGONAL MULTINOMIALS
C     BY
C          BARTELS AND JEZIORANSKI
C     IN
C          ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE
C
C
C     MODIFIED BY A.H. MORRIS (NSWC)
C
C     ****************
C
      IF (NPOLYS .EQ. 1) GO TO 50
C
      PSI(1) = 1.0
      DO 40 P = 1,NEPTS
C
C     ***************
C     SCALE THE COORDINATES OF THE P-TH POINT
C     ***************
C
         DO 10 K = 1,DIMEN
              X(K) = COORD(P,K)
              IF (MAXABS(K) .NE. 0.0) X(K) = X(K) / MAXABS(K)
 10      CONTINUE
C
C     ***************
C     USE THE  BASIS FUNCTION COEFFICIENTS  C  AND RECURRENCE
C     COEFFICIENTS  ALPHA  TO EVALUATE THE FITTED MULTINOMIAL
C     AT THE P-TH POINT.
C     ***************
C
         RNTOT1 = C(1)
         DO 30 J = 2,NPOLYS
              K = INDEXS(2,J)
              JPRIME = INDEXS(1,J)
              RUNTOT = X(K) * PSI(JPRIME)
              I = INDEXS(3,J)
              JM1 = J - 1
              DO 20 M = I,JM1
                 INDEX = INDEXS(4,J) + M - I
 20              RUNTOT = RUNTOT - PSI(M) * ALPHA(INDEX)
              PSI(J) = RUNTOT
 30           RNTOT1 = RNTOT1 + C(J) * PSI(J)
 40       F(P) = RNTOT1 * MAXABS(DIMP1)
      RETURN
C
C     ***************
C     COMPUTE THE DEGREE 0 POLYNOMIAL
C     ***************
C
 50   RUNTOT = C(1) * MAXABS(DIMP1)
      DO 60 P = 1,NEPTS
 60      F(P) = RUNTOT
      RETURN
      END
      SUBROUTINE DMFIT(DIMEN,FITDEG,NFPOLS,NFPTS,
     +                 FITCDS,NCROWS,FITVLS,WTS,
     +                 RESIDS,ERROR,FITIWK,FITDWK,
     +                 FIWKLN,FDWKLN,IREQD,DREQD)
C
      INTEGER NFPOLS,FITDEG,NFPTS,DIMEN,FIWKLN,FDWKLN
      INTEGER ERROR,IREQD,DREQD,INDSTT,P,DIMP1,NCROWS
      INTEGER NEWSTT,MAXSTT,ALFSTT,PSISTT,CSTT,SSQSTT,PSIWID,ALFL
      INTEGER FITIWK(FIWKLN)
      DOUBLE PRECISION FITDWK(FDWKLN),FITCDS(NCROWS,DIMEN)
      DOUBLE PRECISION FITVLS(NFPTS),RESIDS(NFPTS)
      DOUBLE PRECISION WTS(NFPTS),SCALE
C
C     ***************
C     PURPOSE
C     -------
C
C     THIS SUBROUTINE CONSTRUCTS A LEAST-SQUARES  MULTINOMIAL  FIT  TO
C     GIVEN DATA USING A BASIS OF ORTHOGONAL MULTINOMIALS. THE COMPUTA-
C     TION IS PERFORMED IN DOUBLE PRECISION.
C
C     THE DATA FOR THE FIT IS GIVEN IN THE ARRAYS FITCDS, FITVLS, AND
C     WTS. FITCDS IS A MATRIX, EACH ROW OF WHICH CONTAINS AN OBSERVA-
C     TION POINT. FITVLS IS A SINGLY-INDEXED ARRAY, EACH ELEMENT OF
C     WHICH CONTAINS A FUNCTION VALUE CORRESPONDING TO AN OBSERVATION
C     POINT. WTS IS A SINGLY-INDEXED ARRAY, EACH ELEMENT OF WHICH IS
C     A NONNEGATIVE WEIGHT FOR THE CORRESPONDING OBSERVATION.
C
C     THE FIT WHICH IS PRODUCED IS A MULTINOMIAL EXPRESSED IN THE FORM
C
C      C  PSI  (X ,...,X     ) +...+ C       PSI       (X ,...,X     )
C       1    1   1      DIMEN         NFPOLS    NFPOLS   1      DIMEN
C
C     WHERE THE VALUE OF  NFPOLS  WILL BE AS GIVEN (IF  FITDEG .LT. 0)
C     OR  AS  COMPUTED  BY  DMFIT  TO GIVE A FULL-DEGREE FIT (IN CASE
C     FITDEG  IS SPECIFIED .GE. 0).  THE ELEMENTS
C
C         PSI  (X ,...,X     )
C            K   1      DIMEN
C
C     FORM A BASIS FOR THE MULTINOMIALS WHICH IS ORTHOGONAL WITH
C     RESPECT TO THE WEIGHTS AND OBSERVATION POINTS.
C
C     THE EXTENT OF THE FIT CAN BE SPECIFIED IN ONE OF TWO WAYS.
C         IF THE PARAMETER FITDEG IS SET .GE. 0, THEN A COMPLETE BASIS
C         FOR THE MULTINOMIALS OF DEGREE =  FITDEG  WILL BE USED.  (AN
C         ERROR WILL BE  FLAGGED  IF  THIS  WILL  REQUIRE  MORE  BASIS
C         MULTINOMIALS  THAN  THE  NUMBER  OF  DATA  POINTS WHICH WERE
C         GIVEN.)
C         IF THE PARAMETER  FITDEG  IS .LT.  0, THEN  NFPOLS  WILL  BE
C         TAKEN AS THE COUNT OF THE NUMBER OF BASIS MULTINOMIALS TO BE
C         USED FOR A PARTIAL-DEGREE FIT.  (AN ERROR WILL BE FLAGGED IF
C         NFPOLS  .LT. 0.)
C
C     VARIABLES
C     ---------
C
C      DIMEN  -- (INTEGER) -- (PASSED)
C         THE NUMBER OF VARIABLES.
C      FITDEG  - (INTEGER) -- (PASSED/RETURNED)
C         IGNORED IF .LT. 0.
C         IF FITDEG .GE. 0 THEN  FITDEG  IS  CHECKED  AGAINST  NFPTS .
C         THE VALUE OF  FITDEG  WILL BE REDUCED IF THERE IS A BASIS OF
C         MULTINOMIALS, ALL OF  DEGREE  .LE. FITDEG ,  OF  CARDINALITY
C         NFPTS .  SEE  ERROR  BELOW.
C      NFPOLS  - (INTEGER) -- (PASSED/RETURNED)
C         IGNORED IF  FITDEG  .GE. 0.
C         IF  FITDEG .LT. 0 THEN THE VALUE OF NFPOLS WILL BE TAKEN  AS
C         THE SIZE OF THE BASIS OF MULTINOMIALS TO BE USED IN THE FIT.
C         NFPOLS  MUST SATISFY  NFPOLS  .LT. NFPTS  AND NFPOLS .GE. 1
C         SEE  ERROR  BELOW.
C      NFPTS  --- (INTEGER) -- (PASSED)
C         THE NUMBER OF DATA POINTS TO BE USED IN THE FIT.
C         NFPTS  MUST BE .GE. 1.  SEE  ERROR  BELOW.
C      FITCDS  -- (DOUBLE PRECISION 2-SUBSCRIPT ARRAY) -- (PASSED)
C         FITCDS (P,K) IS THE VALUE OF THE K-TH VARIABLE AT THE  P-TH
C         DATA POINT.
C      NCROWS  -- (INTEGER) -- (PASSED)
C         THE ROW DIMENSION  DECLARED  FOR   FITCDS   IN  THE  CALLING
C         PROGRAM.
C      FITVLS  -- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY) -- (PASSED)
C         FITVLS (P) IS THE OBSERVED FUNCTION VALUE OF THE P-TH  DATA
C         POINT.
C      WTS  ----- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY) -- (PASSED)
C         WTS (P) IS THE WEIGHT ATTACHED TO THE P-TH DATA POINT.
C      RESIDS  -- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY) -- (RETURNED)
C         RESIDS (P) IS THE DIFFERENCE BETWEEN THE FITTED FUNCTION AT
C         POINT P AND  FITVLS (P).
C      ERROR  -- (INTEGER) -- (RETURNED)
C       0 THE DESIRED LEAST SQUARE MULTINOMIAL FIT WAS OBTAINED.
C      -1 ONLY THE FIRST NFPOLS BASIS POLYNOMIALS WERE OBTAINED.
C         FITDEG IS THE DEGREE OF THE FIT.
C       1 IF  FITDEG  .GE. 0 BUT THERE IS AN INTERPOLATING MULTINOMIAL
C         OF SMALLER DEGREE OR IF FITDEG .LT. 0 AND NFPOLS .GT. NFPTS.
C       2 IF  FITDEG  .LT. 0 AND  NFPOLS  .LE. 0.
C       3 IF  NFPTS  .LT. 1 AND/OR  DIMEN  .LT. 1.
C       4 IF  IWKLEN  AND/OR  DWKLEN  IS TOO SMALL.  (SET  IWKLEN   TO
C         THE VALUE RETURNED IN  IREQD , AND SET  DWKLEN  TO THE VALUE
C         RETURNED IN  DREQD  TO RESOLVE THIS PROBLEM.)
C      FITIWK  -- (INTEGER, 1-SUBSCRIPT ARRAY) -- (RETURNED)
C         AN INTEGER WORK ARRAY OF LENGTH  FIWKLN .  UPON RETURN  FROM
C         DMFIT, FITIWK CONTAINS DIMENSION AND ARRAY LENGTH INFORMATION.
C      FITDWK  -- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY) -- (RETURNED)
C         AN ARRAY OF LENGTH  FDWKLN  CONTAINING THE COEFFICIENTS
C         NEEDED FOR COMPUTING THE MULTINOMIAL FIT AT A POINT.
C      FIWKLN  -- (INTEGER) -- (PASSED)
C         THE LENGTH OF THE ARRAY  FITIWK .
C      FDWKLN  -- (INTEGER) -- (PASSED)
C         THE LENGTH OF THE ARRAY  FITDWK .
C      IREQD  -- (INTEGER) -- (RETURNED)
C         THE LENGTH WHICH THE ARRAY  FITIWK  REALLY NEEDS TO BE.
C      DREQD  -- (INTEGER) -- (RETURNED)
C         THE LENGTH WHICH THE ARRAY  FITDWK  REALLY NEEDS TO BE.
C
C
C     NOTE. THE 20 LOOP DEPENDS ON THE SCALING SCHEME BEING USED. THE
C     RESIDUAL SCALING MUST BE CONSISTENT WITH THAT DEFINED BY DSCALP
C     AND DSCALD.
C
C     DMFIT  CALLS  ALLOT  AND  DGNRTP.
C     ****************
C
      DIMP1 = DIMEN + 1
C
C     ***************
C
      CALL ALLOT(FITDEG,NFPOLS,NFPTS,DIMEN,FITIWK,FIWKLN,IREQD,DREQD,
     +           ERROR)
      IF ( ERROR .GE. 2 ) RETURN
C
      IF ( FDWKLN .GE. DREQD ) GO TO 10
         ERROR = 4
         RETURN
   10 CONTINUE
C
      PSIWID = FITIWK(3)
      ALFL = FITIWK(4)
      INDSTT = 1
      NEWSTT = 4 * NFPOLS + INDSTT
      MAXSTT = 1
      ALFSTT = MAXSTT + DIMP1
      CSTT = ALFSTT + ALFL
      SSQSTT = CSTT + NFPOLS
      PSISTT = SSQSTT + NFPOLS
C
C     ***************
C
         CALL DGNRTP(FITDEG,FITDWK(ALFSTT),
     +               FITDWK(PSISTT),FITIWK(INDSTT),
     +               FITIWK(NEWSTT),FITDWK(SSQSTT),FITCDS,
     +               NCROWS,NFPOLS,DIMEN,NFPTS,FITVLS,RESIDS,
     +               FITDWK(CSTT),PSIWID,WTS,ALFL,DIMP1,
     +               FITDWK(MAXSTT),ERROR)
C
C     ***************
C     STORE THE NUMBER OF BASIS POLYNOMIALS ACTUALLY COMPUTED
C     BY THE MODIFIED ROUTINE DINCDG CALLED BY DGNRTP.
C     ***************
C
      FITIWK(1) = NFPOLS
C
C     ***************
C     UNSCALE THE RESIDUALS FOR THE BENEFIT OF THE USER.
C     ***************
C
      SCALE = FITDWK(DIMEN + 1)
      DO 20 P = 1,NFPTS
        RESIDS(P) = RESIDS(P) * SCALE
   20 CONTINUE
      RETURN
      END
      SUBROUTINE DGNRTP(DEGREE,ALPHA,PSI,INDEXS,
     +                  NEWKJ,SUMSQS,COORD,NCROWS,NPOLYS,
     +                  DIMEN,NPTS,F,Z,C,PSIWID,WEIGHT,
     +                  ALFL,DIMP1,MAXABS,ERROR)
C
      INTEGER DEGREE,DIMEN,NPOLYS,NPTS,K,PSIWID,ALFL,P,STTDEG,ONPLYS
      INTEGER ERROR,DIMP1
      INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE)
      DOUBLE PRECISION PSI(NPTS,PSIWID),ALPHA(ALFL),F(NPTS)
      DOUBLE PRECISION COORD(NCROWS,DIMEN),MAXABS(DIMP1),WEIGHT(NPTS)
      DOUBLE PRECISION Z(NPTS),SUMSQS(NPOLYS),C(NPOLYS)
      DOUBLE PRECISION RUNTOT,RNTOT1
C
C     ***************
C     PURPOSE
C     -------
C
C     THE MULTINOMIAL FIT IS GENERATED INCREMENTALLY, A BASIS  ELEMENT
C     AT A TIME.  THIS SUBROUTINE STARTS THE PROCESS OFF BY SETTING UP
C     THE FIRST BASIS ELEMENT, SCALING THE  DATA,  FINDING  THE  FIRST
C     COEFFICIENT,  AND  INITIALIZING  THE  WORK ARRAY Z.  DGNRTP THEN
C     CALLS  DINCDG  IF MORE THAN ONE BASIS ELEMENT IS REQUIRED.
C
C     THIS SUBROUTINE IS CALLED BY  DMFIT .  IT IS NOT CALLED BY  THE
C     USER.
C
C     THIS SUBROUTINE CALLS  DSCALP ,  DSCALD , AND  DINCDG .
C
C
C     MODIFIED BY A.H. MORRIS (NSWC)
C     ****************
C
C     ***************
C     SET UP THE SCALING.
C     ***************
C
      DO 10 K = 1,DIMEN
         CALL DSCALP(COORD(1,K),NPTS,MAXABS(K))
 10      CALL DSCALD(COORD(1,K),NPTS,MAXABS(K))
      CALL DSCALP(F,NPTS,MAXABS(DIMP1))
      CALL DSCALD(F,NPTS,MAXABS(DIMP1))
C
C     ***************
C      SUMSQS (1) = (1,1)
C     C  = (F,1) / (1,1)
C      1
C     ***************
C
      RUNTOT = 0.D0
      RNTOT1 = 0.D0
      DO 20 P = 1,NPTS
         PSI(P,1) = 1.D0
         RNTOT1 = RNTOT1 + WEIGHT(P)
 20      RUNTOT = RUNTOT + F(P) * WEIGHT(P)
      SUMSQS(1) = RNTOT1
      C(1) = RUNTOT / RNTOT1
C
C     ***************
C     Z = F - C
C              1
C     ***************
C
      DO 30 P = 1,NPTS
 30      Z(P) = F(P) - C(1)
C
      IF ( NPOLYS .EQ. 1 ) RETURN
      STTDEG = 1
      ONPLYS = 1
C
      CALL DINCDG(DEGREE,ALPHA,PSI,INDEXS,NEWKJ,SUMSQS,
     +            COORD,NCROWS,NPOLYS,DIMEN,NPTS,F,Z,C,PSIWID,
     +            WEIGHT,ALFL,ONPLYS,STTDEG,ERROR)
      RETURN
      END
      SUBROUTINE DINCDG(DEGREE,ALPHA,PSI,INDEXS,NEWKJ,
     +                  SUMSQS,COORD,NCROWS,NPOLYS,
     +                  DIMEN,NPTS,F,Z,C,PSIWID,WEIGHT,
     +                  ALFL,ONPLYS,STTDEG,ERROR)
C
      INTEGER JPRIME,P,J,CURDEG,KJ,KJP,L,JPM1,JM1
      INTEGER M,START,JINDEX,JPINDX,Q,J3,J1,J1MJ2,ERROR
      INTEGER J0MJ1,J1M1,STARTA,ONPLYS,ONPP1,STTDEG,INDEX1,INDEX2
      INTEGER DEGREE,NPOLYS,NPTS,DIMEN,PSIWID,ALFL
      INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE)
      DOUBLE PRECISION ALPHA(ALFL),COORD(NCROWS,DIMEN),PSI(NPTS,PSIWID)
      DOUBLE PRECISION SUMSQS(NPOLYS),C(NPOLYS),F(NPTS),WEIGHT(NPTS)
      DOUBLE PRECISION Z(NPTS)
      DOUBLE PRECISION ARC,RUNTOT,RNTOT1,RNTOT2
C
C     ***************
C     PURPOSE
C     -------
C
C     THE MULTINOMIAL FIT IS GENERATED INCREMENTALLY, A BASIS  ELEMENT
C     AT A TIME.  THIS SUBROUTINE CONTINUES THE PROCESS STARTED OFF BY
C      DGNRTP .
C
C     THIS SUBROUTINE IS CALLED BY  DGNRTP  AND NOT BY THE USER.
C
C
C     MODIFIED BY A.H. MORRIS (NSWC)
C
C     ****************
C
      IF ( ONPLYS .GE. 1 .AND. STTDEG .GE. 1 ) GO TO 10
         ERROR = 6
      RETURN
 10      IF ( INDEXS(2,ONPLYS) .EQ. DIMEN ) GO TO 20
            CURDEG = STTDEG
         GO TO 30
 20         CURDEG = STTDEG + 1
 30   ONPP1 = ONPLYS + 1
      DO 170 J = ONPP1,NPOLYS
         JPRIME = INDEXS(1,J)
         JINDEX = J - ((J - 1) / PSIWID) * PSIWID
         JPINDX = JPRIME - ((JPRIME - 1) / PSIWID) * PSIWID
         KJ = INDEXS(2,J)
         START = INDEXS(3,J)
         M = START
         STARTA = INDEXS(4,J) - START
         IF ( CURDEG .EQ. 1 ) GO TO 100
         KJP = INDEXS(2,JPRIME)
         J1 = NEWKJ(KJ,CURDEG - 1)
C
C     ***************
C     CALCULATE THOSE  ALPHA ( J , M ) THAT CAN BE CALCULATED FROM
C     PREVIOUSLY CALCULATED ALPHAS.
C     ***************
C
         IF ( KJ .LT. KJP ) GO TO 50
C
C     ***************
C     FIRST CALCULATE THOSE BETWEEN  JPP  AND THE END OF 2 ROWS BACK.
C     CALCULATE  ALPHA ( J , JPP )
C     ***************
C
         INDEX1 = INDEXS(4,J)
         ALPHA(INDEX1) = SUMSQS(JPRIME) / SUMSQS(START)
C
         M = START + 1
         J3 = NEWKJ(1,CURDEG - 1) - 1
         IF ( M .GT. J3 ) GO TO 50
C
C     ***************
C     CURDEG .GT. 2 IF CONTROL HAS PASSED THE BRANCHES IN THE 3-RD
C     PREVIOUS AND 8-TH PREVIOUS STATEMENTS.
C     ***************
C
            J1MJ2 = J1 - NEWKJ(KJ,CURDEG - 2)
C
            DO 40 L = M,J3
               Q = J1MJ2 + L
               INDEX1 = STARTA + L
               INDEX2 = INDEXS(4,Q) - INDEXS(3,Q) + JPRIME
 40            ALPHA(INDEX1) = ALPHA(INDEX2) * SUMSQS(JPRIME) /
     +         SUMSQS(L)
C
C     ***************
C     CALCULATE  ALPHA ( J , M ) FOR  M  BETWEEN THE 2
C     RANGES CALCULATED BEFORE USING
C
C        ALPHA ( J , L ) = (X  *  PSI  ,PSI )  / (PSI ,PSI )
C                             K      JP    L         L    L
C                              J
C     ***************
C
         M = J3 + 1
 50      IF ( JPRIME .EQ. J1 ) GO TO 100
            IF ( KJ .EQ. 1 ) GO TO 80
            J1M1 = J1 - 1
            DO 70 L = M,J1M1
               RUNTOT = 0.D0
               DO 60 P = 1,NPTS
                  INDEX1 = L - ((L - 1) / PSIWID) * PSIWID
 60               RUNTOT = RUNTOT + COORD(P,KJ) * PSI(P,JPINDX) *
     +            PSI(P,INDEX1) * WEIGHT(P)
               INDEX1 = STARTA + L
 70            ALPHA(INDEX1) = RUNTOT / SUMSQS(L)
C
C     ***************
C     CALCULATE  ALPHA ( J , M ) FOR  M  BETWEEN
C      NEWKJ ( KJ , CURDEG  - 1)  AND
C      JP  - 1.
C     ***************
C
 80         J0MJ1 = NEWKJ(KJ,CURDEG) - J1
            JPM1 = JPRIME - 1
            DO 90 L = J1,JPM1
               Q = J0MJ1 + L
               INDEX1 = STARTA + L
               INDEX2 = INDEXS(4,Q) - INDEXS(3,Q) + JPRIME
 90            ALPHA(INDEX1) = ALPHA(INDEX2) * SUMSQS(JPRIME) /
     +         SUMSQS(L)
            M = JPRIME
C
C     ***************
C     CALCULATE THE REMAINING  ALPHA ( J , M ) FROM
C
C      ALPHA ( J , L ) = (X   * PSI  ,PSI ) / (PSI ,PSI )
C                          K       JP    L        L    L
C                           J
C     ***************
C
 100     JM1 = J - 1
         DO 120 L = M,JM1
            RUNTOT = 0.D0
            DO 110 P = 1,NPTS
               INDEX1 = L - ((L - 1) / PSIWID) * PSIWID
 110           RUNTOT = RUNTOT + COORD(P,KJ) * PSI(P,JPINDX) *
     +         PSI(P,INDEX1) * WEIGHT(P)
            INDEX1 = STARTA + L
 120        ALPHA(INDEX1) = RUNTOT / SUMSQS(L)
C
C     ***************
C     NOW CALCULATE THE  PSI (P,J),  SUMSQS (J) AND  C (J) USING
C
C                          J-1
C     PSI  = X  * PSI   -  SUM   ALPHA(J,L) * PSI
C        J    K      JP    L=JPP                 L
C
C     SUMSQS  = (PSI ,PSI )
C           J       J    J
C
C     C  = (Z,PSI )
C      J         J
C     ***************
C
 130      JM1 = J - 1
          ARC = 0.D0
          RNTOT1 = 0.D0
          RNTOT2 = 0.D0
          DO 150 P = 1,NPTS
              RUNTOT = COORD(P,KJ) * PSI(P,JPINDX)
              DO 140 L = START,JM1
                 INDEX1 = STARTA + L
                 INDEX2 = L - ((L - 1) / PSIWID) * PSIWID
 140             RUNTOT = RUNTOT - ALPHA(INDEX1) * PSI(P,INDEX2)
              PSI(P,JINDEX) = RUNTOT
              ARC = ARC + PSI(P,INDEX2) * PSI(P,JINDEX) *
     +                          WEIGHT(P)
              RNTOT1 = RNTOT1 + PSI(P,JINDEX) * PSI(P,JINDEX) *
     +                          WEIGHT(P)
 150          RNTOT2 = RNTOT2 + Z(P) * PSI(P,JINDEX) * WEIGHT(P)
          IF (ARC * ARC .GE. SUMSQS(JM1) * RNTOT1 * 1.D-06)
     +        GO TO 200
          SUMSQS(J) = RNTOT1
          C(J) = RNTOT2 / RNTOT1
C
C     ***************
C     CALCULATE THE NEW  Z ( P ) AND THE NEW  SSRES  USING
C
C     Z = Z - C  * PSI
C              J      J
C     ***************
C
          DO 160 P = 1,NPTS
 160          Z(P) = Z(P) - C(J) * PSI(P,JINDEX)
          STTDEG = CURDEG
 170      IF ( KJ .EQ. DIMEN ) CURDEG = CURDEG + 1
      RETURN
C
C     ***************
C     THE J-TH BASIS MULTINOMIAL CANNOT BE COMPUTED ACCURATELY.
C     ONLY J - 1 BASIS MULTINOMIALS ARE GENERATED.
C     ***************
C
 200  ERROR = -1
      DEGREE = STTDEG
      NPOLYS = JM1
      RETURN
      END
      SUBROUTINE DSCALP(COORD,NPTS,MAXABS)
C
      INTEGER NPTS,P
      DOUBLE PRECISION MAXABS,A
      DOUBLE PRECISION COORD(NPTS)
C
C     ***************
C     PURPOSE
C     -------
C
C     FIND SCALING PARAMETER(S) FOR THE PROBLEM. IF THE SCALING SCHEME
C     IS CHANGED, ALL FOUR OF THE FOLLOWING WOULD HAVE TO BE CHANGED
C
C     1)  DSCALP  - FIND THE SCALING PARAMETERS
C     2)  DSCALD  - SCALE THE PROBLEM DATA
C     3)  THE SCALING OF THE RESIDUALS IN  DMFIT
C     4)  THE SCALING PERFORMED IN  DMEVL1
C
C     THIS SUBROUTINE IS CALLED BY  DGNRTP .  IT IS NOT CALLED  BY  THE
C     USER.
C
C     THE SCALING WHICH  IT  DEFINES  MUST  BE  COORDINATED  WITH  THE
C     SCALING  OF RESIDUALS WHICH IS CARRIED OUT TOWARD THE END OF THE
C     SUBROUTINE  DMFIT.  THE SCALING MUST ALSO BE COORDINATED WITH THE
C     SCALING PERFORMED IN THE 10 LOOP  AND  AT STATEMENTS 40 AND 50
C     (WITH THE SCALE FACTOR MAXABS(DIMP1)) IN  DMEVL1.
C
C     ****************
C
      MAXABS = 0.D0
      DO 10 P = 1,NPTS
         A = DABS(COORD(P))
   10    IF ( A .GT. MAXABS ) MAXABS = A
      RETURN
      END
      SUBROUTINE DSCALD(COORD,NPTS,MAXABS)
C
      INTEGER NPTS,P
      DOUBLE PRECISION MAXABS
      DOUBLE PRECISION COORD(NPTS)
C
C     ***************
C     PURPOSE
C     -------
C
C     CARRY OUT THE DATA-SCALING WHICH IS DEFINED  BY  THE SUBROUTINE
C     DSCALP .
C
C     THIS SUBROUTINE IS CALLED BY  DGNRTP .  IT IS NOT CALLED BY THE
C     USER.
C
C     THE SCALING WHICH THIS ROUTINE CARRIES OUT MUST  BE  CONSISTENT
C     WITH THE SCALING IN THE SUBROUTINES DMFIT AND DMEVL1.
C
C     ****************
C
      IF ( MAXABS .EQ. 0.0D+00 ) RETURN
         DO 10 P = 1,NPTS
   10       COORD(P) = COORD(P) / MAXABS
         RETURN
      END
      SUBROUTINE DMEVAL(DIMEN,EVLDEG,NEPOLS,NEPTS,EVLCDS,NEROWS,EVLVLS,
     +                  ERROR,FITIWK,FITDWK,FIWKLN,FDWKLN,TEMP)
C
      INTEGER FIWKLN,FDWKLN,NEPOLS,NEPTS,DIMEN,ERROR,MAXSTT,ALFSTT,CSTT
      INTEGER GBASIZ,ALFL,DIMP1,EVLDEG,TOP,BOT,CURDEG,PSISTT
      INTEGER FITIWK(FIWKLN)
      DOUBLE PRECISION FITDWK(FDWKLN),EVLCDS(NEROWS,DIMEN)
      DOUBLE PRECISION EVLVLS(NEPTS),TEMP(DIMEN)
C
C     ***************
C     PURPOSE
C     -------
C
C     THIS SUBROUTINE  EVALUATES  THE  LEAST-SQUARES  MULTINOMIAL  FIT
C     WHICH HAS BEEN PREVIOUSLY PRODUCED BY  DMFIT .  THE COMPUTATION
C     IS PERFORMED IN DOUBLE PRECISION. EITHER THE FULL
C     MULTINOMIAL AS PRODUCED MAY BE EVALUATED,  OR  ONLY  AN  INITIAL
C     SEGMENT THEREOF.  AS IN THE CASE WITH  DMFIT , IT IS POSSIBLE
C     (1) TO SPECIFY MULTINOMIALS OF A FULL GIVEN DEGREE, OR
C     (2) TO SPECIFY  THE  NUMBER  OF  ORTHOGONAL  BASIS  ELEMENTS  TO
C         ACHIEVE A PARTIAL-DEGREE FIT.
C
C     IN CASE (1), THE  DESIRED  DEGREE  IS  GIVEN  AS  THE  VALUE  OF
C     EVLDEG   (WHICH  MUST  BE  NONNEGATIVE AND NOT GREATER THAN THE
C     VALUE USED FOR  FITDEG  IN  DMFIT ), AND THE PARAMETER  NEPOLS
C     WILL BE SET  BY  DMEVAL  TO SPECIFY THE NUMBER OF BASIS ELEMENTS
C     REQUIRED. IF  EVLDEG  .LT.  FITDEG   IS  GIVEN,  THEN  ONLY  THE
C     INITIAL  PORTION OF THE FITTING MULTINOMIAL (OF DEGREE  EVLDEG )
C     WILL BE EVALUATED.
C
C     IN CASE (2),  EVLDEG  IS TO BE SET NEGATIVE, IN WHICH  CASE  THE
C     VALUE  OF   NEPOLS  (WHICH MUST BE POSITIVE AND NOT GREATER THAN
C     THE VALUE USED FOR   NFPOLS   IN   DMFIT )  WILL  BE  TAKEN  AS
C     DEFINING  THE  INITIAL  PORTION OF THE FITTING MULTINOMIAL TO BE
C     EVALUATED.
C
C     IF  NEPOLS  =  NFPOLS  (WITH  EVLDEG  .LT.  0),  OR   EVLDEG   =
C     FITDEG  (WITH   EVLDEG   .GT.  0),  THEN  THE  FULL  MULTINOMIAL
C     GENERATED BY  DMFIT  WILL BE EVALUATED.
C
C     THE  EVALUATION  WILL  TAKE  PLACE  FOR  EACH  OF   THE   POINTS
C     (COLLECTION  OF  VARIABLE  VALUES)  GIVEN AS A ROW OF THE MATRIX
C      EVLCDS .  THE  VALUES  PRODUCED  FROM  THE  FULL,  OR  PARTIAL,
C     MULTINOMIAL WILL BE PLACED IN THE ARRAY  EVLVLS .
C
C     VARIABLES
C     ---------
C
C      DIMEN  -- (INTEGER) -- (PASSED)
C         THE NUMBER OF VARIABLES.
C      EVLDEG  -- (INTEGER) -- (PASSED)
C         IF  EVLDEG  .LT. 0, THEN THIS PARAMETER WILL BE IGNORED.
C         IF  EVLDEG  .GE. 0, THEN THE VALUE OF  EVLDEG  MUST  SATISFY
C         EVLDEG  .LE. (THE  DEGREE  OF THE APPROXIMATING MULTINOMIAL
C         GENERATED IN  DMFIT ).  IN THIS CASE  EVLDEG  WILL  SPECIFY
C         THE DEGREE OF THE INITIAL PORTION OF THE FITTING MULTINOMIAL
C         TO BE EVALUATED.
C      NEPOLS  -- (INTEGER) -- (PASSED/RETURNED)
C         IF  EVLDEG  .GE. 0, THEN THIS PARAMETER WILL BE IGNORED.
C         IF EVLDEG .LT. 0, THEN THE PARTIAL MULTINOMIAL INVOLVING THE
C         FIRST   NEPOLS  ORTHOGONAL BASIS FUNCTIONS WILL BE EVALUATED
C         AT THE POINTS GIVEN BY  EVLCDS .  THE RESULTING VALUES  WILL
C         BE STORED IN  EVLVLS .
C         THE VALUE OF NEPOLS MUST BE .GE. 1 AND .LE. (THE SIZE OF THE
C         BASIS  GENERATED  IN   DMFIT ),  WHICH  WAS RETURNED AS THE
C         VALUE OF  NFPOLS .
C         NEPOLS  WILL BE CHANGED IF EVLDEG .GT. 0 TO GIVE THE SIZE OF
C         BASIS REQUIRED FOR THE MULTINOMIAL OF DEGREE  EVLDEG .
C      NEPTS  -- (INTEGER) -- (PASSED)
C         THE NUMBER OF EVALUATION POINTS.
C      EVLCDS  -- (DOUBLE PRECISION 2-SUBSCRIPT ARRAY) -- (PASSED)
C         EVLCDS (P,K) IS THE VALUE OF THE K-TH VARIABLE AT THE  P-TH
C         EVALUATION POINT.
C      NEROWS  -- (INTEGER) -- (PASSED)
C         THE ROW DIMENSION DECLARED FOR EVLCDS IN THE CALLING PROGRAM.
C      EVLVLS  -- (INTEGER) -- (RETURNED)
C         EVLVLS (P) IS THE VALUE OF THE EVALUATED MULTINOMIAL AT THE
C         P-TH EVALUATION POINT.
C      ERROR  -- (INTEGER) -- (RETURNED)
C          0 .........  IF NO ERRORS
C         -1 .........  IF  NEPOLS  .GT.  NFPOLS  OR  NEPOLS  .LT. 1
C         -2 .........  IF  NEPTS  .LT. 1 OR  DIMEN  .LT. 1
C      FITIWK  -- (INTEGER, 1-SUBSCRIPT ARRAY) -- (PASSED)
C         THE INTEGER WORK ARRAY OF LENGTH  FIWKLN  THAT WAS  USED  IN
C          DMFIT .
C      FITDWK  -- (DOUBLE PRECISION 2-SUBSCRIPT ARRAY) -- (PASSED)
C         THE REAL WORK ARRAY OF LENGTH  FDWKLN  THAT WAS
C         USED IN  DMFIT .
C      FIWKLN  -- (INTEGER) -- (PASSED)
C         THE LENGTH OF  FITIWK .
C      FDWKLN  -- (INTEGER) -- (PASSED)
C         THE LENGTH OF  FITDWK .
C      TEMP    -- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY)
C         A WORK ARRAY OF LENGTH  DIMEN  (OR LONGER).
C
C     THE SUBROUTINE  DMEVL1  IS CALLED TO DO THE ACTUAL EVALUATION.
C
C     MODIFIED BY A.H. MORRIS (NSWC)
C
C     ****************
C
C
C     ***************
C     SET UP INDEX POINTERS TO THE BEGINNING OF EACH ROW OF
C     THE MTABLE -- THIS SETS THE BEGINNING POINT FOR EACH
C     FULL MULTINOMIAL DEGREE.
C     ***************
C
      IF (NEPTS .LT. 1 .OR. DIMEN .LT. 1) GO TO 110
      IF (EVLDEG) 40,10,20
C
   10 NEPOLS = 1
      GO TO 50
C
   20 TOP = 1
      BOT = 1
      DO 30 CURDEG = 1,EVLDEG
         TOP = TOP * (DIMEN + CURDEG)
   30    BOT = BOT * CURDEG
      NEPOLS = TOP / BOT
C
   40 GBASIZ = FITIWK(1)
      IF (NEPOLS .GT. GBASIZ .OR. NEPOLS .LT. 1) GO TO 100
C
   50 ERROR = 0
      DIMP1 = DIMEN + 1
      ALFL = FITIWK(4)
      MAXSTT = 1
      ALFSTT = DIMP1 + MAXSTT
      CSTT = ALFSTT + ALFL
      PSISTT = CSTT + FITIWK(2)
C
C     ***************
C     THE ACTUAL EVALUATION IS DONE INSIDE  DMEVL1.
C     ***************
C
      CALL DMEVL1 (EVLCDS,NEROWS,FITDWK(CSTT),NEPTS,DIMEN,NEPOLS,
     +             FITDWK(ALFSTT),FITIWK,FITDWK(PSISTT),
     +             EVLVLS,ALFL,FITDWK(MAXSTT),TEMP,DIMP1)
      RETURN
C
C     ***************
C     ERROR RETURN
C     ***************
C
  100 ERROR = -1
      RETURN
  110 ERROR = -2
      RETURN
      END
      SUBROUTINE DMEVL1 (COORD,NCROWS,C,NEPTS,DIMEN,NPOLYS,ALPHA,
     +                   INDEXS,PSI,F,ALFL,MAXABS,X,DIMP1)
C
      INTEGER DIMEN,NEPTS,NPOLYS,ALFL,DIMP1
      INTEGER JM1,JPRIME,M,P,K,I,J,INDEX
      INTEGER INDEXS(4,NPOLYS)
      DOUBLE PRECISION ALPHA(ALFL),COORD(NCROWS,DIMEN),PSI(NPOLYS)
      DOUBLE PRECISION C(NPOLYS),F(NEPTS),MAXABS(DIMP1),X(DIMEN)
      DOUBLE PRECISION RUNTOT,RNTOT1
C
C     ***************
C     PURPOSE
C     -------
C
C     THIS SUBROUTINE PERFORMS THE MAIN WORK OF EVALUATING THE
C     FITTING MULTINOMIAL (OR THE INITIAL PORTION OF IT  WHICH
C     IS REQUESTED BY THE SETTING OF  NEPOLS ,  EVLDEG  IN THE
C     CALL TO SUBROUTINE  DMEVAL .
C
C     THIS SUBROUTINE IS CALLED BY  DMEVAL .  IT IS  NOT  CALLED
C     DIRECTLY BY THE USER.
C
C     THE BODY OF THIS SUBROUTINE FOLLOWS THE EXPLANATION
C     GIVEN IN
C          LEAST SQUARES FITTING USING
C          ORTHOGONAL MULTINOMIALS
C     BY
C          BARTELS AND JEZIORANSKI
C     IN
C          ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE
C
C
C     MODIFIED BY A.H. MORRIS (NSWC)
C
C     ****************
C
      IF (NPOLYS .EQ. 1) GO TO 50
C
      PSI(1) = 1.D0
      DO 40 P = 1,NEPTS
C
C     ***************
C     SCALE THE COORDINATES OF THE P-TH POINT
C     ***************
C
         DO 10 K = 1,DIMEN
              X(K) = COORD(P,K)
              IF (MAXABS(K) .NE. 0.D0) X(K) = X(K) / MAXABS(K)
 10      CONTINUE
C
C     ***************
C     USE THE  BASIS FUNCTION COEFFICIENTS  C  AND RECURRENCE
C     COEFFICIENTS  ALPHA  TO EVALUATE THE FITTED MULTINOMIAL
C     AT THE P-TH POINT.
C     ***************
C
         RNTOT1 = C(1)
         DO 30 J = 2,NPOLYS
              K = INDEXS(2,J)
              JPRIME = INDEXS(1,J)
              RUNTOT = X(K) * PSI(JPRIME)
              I = INDEXS(3,J)
              JM1 = J - 1
              DO 20 M = I,JM1
                 INDEX = INDEXS(4,J) + M - I
 20              RUNTOT = RUNTOT - PSI(M) * ALPHA(INDEX)
              PSI(J) = RUNTOT
 30           RNTOT1 = RNTOT1 + C(J) * PSI(J)
 40       F(P) = RNTOT1 * MAXABS(DIMP1)
      RETURN
C
C     ***************
C     COMPUTE THE DEGREE 0 POLYNOMIAL
C     ***************
C
 50   RUNTOT = C(1) * MAXABS(DIMP1)
      DO 60 P = 1,NEPTS
 60      F(P) = RUNTOT
      RETURN
      END
      REAL FUNCTION QSUBA (F, A, B, EPSIL, MCOUNT, RELERR, IND)
C-----------------------------------------------------------------------
C
C                INTEGRATION OVER A FINITE INTERVAL
C
C                          ----------
C
C     QSUBA COMPUTES THE INTEGRAL OF F(X) FROM A TO B WHERE THE
C     RELATIVE ERROR DOES NOT EXCEED EPSIL.
C
C     MCOUNT IS THE MAXIMUM NUMBER OF POINTS AT WHICH F(X) MAY BE
C     EVALUATED.
C
C     RELERR IS A VARIABLE. WHEN QSUBA TERMINATES, IF THE VALUE
C     OF THE INTEGRAL IS NONZERO THEN RELERR IS A CRUDE ESTIMATE
C     OF THE RELATIVE ERROR OF THE VALUE. OTHERWISE, IF QSUBA = 0
C     THEN RELERR IS AN ESTIMATE OF THE ABSOLUTE ERROR.
C
C     IND IS A VARIABLE. WHEN QSUBA TERMINATES, IND HAS ONE OF THE
C     FOLLOWING VALUES ...
C
C     IND=0   QSUBA IS SATISFIED THAT THE INTEGRAL HAS BEEN
C             COMPUTED TO THE DESIRED ACCURACY.
C     IND=1   THE INTEGRAL HAS BEEN COMPUTED, BUT QSUBA IS
C             NOT CERTAIN OF THE ACCURACY OF THE RESULT.
C     IND=2   THE INTEGRAND HAS BEEN EVALUATED AT MCOUNT
C             POINTS. IF MORE EVALUATIONS ARE NEEDED THEN
C             QSUBA TERMINATES.
C     IND=3   QSUBA CANNOT COMPUTE THE INTEGRAL TO THE DESIRED
C             ACCURACY. IND IS SET TO 3 WHENEVER THE STACK OF
C             INTERVALS BECOMES FULL (IT CURRENTLY CAN HOLD 50
C             INTERVALS). A RESULT IS OBTAINED BY CONTINUING
C             THE INTEGRATION IGNORING CONVERGENCE FAILURES
C             WHICH CANNOT BE ACCOMMODATED ON THE STACK.
C
C     THE RELIABILITY OF THE ALGORITHM DECREASES FOR LARGE VALUES
C     OF EPSIL. IT IS RECOMMENDED THAT EPSIL BE LESS THAN 0.001.
C
C-----------------------------------------------------------------------
      DIMENSION RESULT(8), STACK(100)
      EXTERNAL F
      DATA ISMAX/100/
C-----------------------------------------------------------------------
C
C     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
C            SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0.
C
                      EPS = SPMPAR(1)
C
C-----------------------------------------------------------------------
      QSUBA = 0.0
      RELERR = 0.0
      IND = 0
      IF (A .EQ. B) RETURN
C
C     APPLY QUAD TO THE ENTIRE INTERVAL
C
      SUB1 = AMIN1(A,B)
      SUB3 = AMAX1(A,B)
      TOL = AMAX1(EPSIL, 10.0*EPS)
      CALL QUAD (SUB1, SUB3, RESULT, K, TOL, NPTS, ICHECK, F)
      IF (ICHECK .EQ. 0) GO TO 100
      IS = 1
C
C     SUBDIVIDE THE INTERVAL (SUB1,SUB3) INTO THE SUBINTERVALS
C     (SUB1,SUB2) AND (SUB2,SUB3). CALL QUAD FOR (SUB1,SUB2).
C
   10 IF (NPTS .GE. MCOUNT) GO TO 110
      SUB2 = 0.5*(SUB1 + SUB3)
      CALL QUAD (SUB1, SUB2, RESULT, K, TOL, NF, ICHECK, F)
      NPTS = NPTS + NF
      ERR = ABS(RESULT(K) - RESULT(K-1))
      SUM = QSUBA + RESULT(K)
      IF (ICHECK .EQ. 0 .OR. ERR .LE. ABS(TOL*SUM)) GO TO 30
C
C        STACK THE SUBINTERVAL (SUB1,SUB2) FOR FURTHER
C        EXAMINATION IF THERE IS SUFFICIENT STORAGE.
C
         IF (IS .GE. ISMAX) GO TO 20
            STACK(IS) = SUB1
            IS = IS + 1
            STACK(IS) = SUB2
            IS = IS + 1
            GO TO 40
   20    IND = 3
C
C     UPDATE QSUBA AND CHECK IF ANY SIGNIFICANT DIGITS ARE LOST
C
   30 X = QSUBA
      QSUBA = SUM
      RELERR = RELERR + ERR
      IF (IND .NE. 0 .OR. X*RESULT(K) .GE. 0.0) GO TO 40
      X = 0.1*AMIN1(ABS(X),ABS(RESULT(K)))
      IF (ABS(QSUBA) .LE. X) IND = 1
C
C     CALL QUAD FOR THE INTERVAL (SUB2,SUB3)
C
   40 IF (NPTS .GE. MCOUNT) GO TO 110
      CALL QUAD (SUB2, SUB3, RESULT, K, TOL, NF, ICHECK, F)
      NPTS = NPTS + NF
      ERR = ABS(RESULT(K) - RESULT(K-1))
      SUM = QSUBA + RESULT(K)
      IF (ICHECK .EQ. 0 .OR. ERR .LE. ABS(TOL*SUM)) GO TO 50
C
C        SUBDIVIDE THE INTERVAL (SUB2,SUB3)
C
         SUB1 = SUB2
         GO TO 10
C
C     UPDATE QSUBA AND CHECK IF ANY SIGNIFICANT DIGITS ARE LOST
C
   50 X = QSUBA
      QSUBA = SUM
      RELERR = RELERR + ERR
      IF (IND .NE. 0 .OR. X*RESULT(K) .GE. 0.0) GO TO 60
      X = 0.1*AMIN1(ABS(X),ABS(RESULT(K)))
      IF (ABS(QSUBA) .LE. X) IND = 1
C
C     SUBDIVIDE THE INTERVAL LAST STACKED
C
   60 IF (IS .EQ. 1) GO TO 120
      IS = IS - 1
      SUB3 = STACK(IS)
      IS = IS - 1
      SUB1 = STACK(IS)
      GO TO 10
C
C     TERMINATION WHEN SUBDIVISION IS NOT NEEDED
C
  100 QSUBA = RESULT(K)
      IF (A .GT. B) QSUBA = -QSUBA
      RELERR = ABS(RESULT(K) - RESULT(K-1))
      IF (QSUBA .NE. 0.0) RELERR = RELERR/ABS(QSUBA)
      RETURN
C
C     SUBDIVISION RESULT
C
  110 IND = 2
  120 IF (A .GT. B) QSUBA = -QSUBA
      IF (QSUBA .NE. 0.0) RELERR = RELERR/ABS(QSUBA)
      RETURN
      END
      SUBROUTINE QUAD(A, B, RESULT, K, EPSIL, NPTS, ICHECK, F)
C     --------------------
C THIS SUBROUTINE ATTEMPTS TO CALCULATE THE INTEGRAL OF F(X)
C OVER THE INTERVAL *A* TO *B* WITH RELATIVE ERROR NOT
C EXCEEDING *EPSIL*.
C THE RESULT IS OBTAINED USING A SEQUENCE OF 1,3,7,15,31,63,
C 127, AND 255 POINT INTERLACING FORMULAE(NO INTEGRAND
C EVALUATIONS ARE WASTED) OF RESPECTIVE DEGREE 1,5,11,23,
C 47,95,191 AND 383. THE FORMULAE ARE BASED ON THE OPTIMAL
C EXTENSION OF THE 3-POINT GAUSS FORMULA.  DETAILS OF
C THE FORMULAE ARE GIVEN IN *THE OPTIMUM ADDITION OF POINTS
C TO QUADRATURE FORMULAE* BY T.N.L. PATTERSON,MATHS.COMP.
C VOL 22,847-856,1968.
C                     *** INPUT ***
C A       LOWER LIMIT OF INTEGRATION.
C B       UPPER LIMIT OF INTEGRATION.
C EPSIL   RELATIVE ACCURACY REQUIRED. WHEN THE RELATIVE
C         DIFFERENCE OF TWO SUCCESSIVE FORMULAE DOES NOT
C         EXCEED *EPSIL* THE LAST FORMULA COMPUTED IS TAKEN
C         AS THE RESULT.
C F       F(X) IS THE INTEGRAND.
C                     *** OUTPUT ***
C RESULT  THIS ARRAY,WHICH SHOULD BE DECLARED TO HAVE AT
C         LEAST 8 ELEMENTS, HOLDS THE RESULTS OBTAINED BY
C         THE 1,3,7, ETC., POINT FORMULAE. THE NUMBER OF
C         FORMULAE COMPUTED DEPENTS ON *EPSIL*.
C K       RESULT(K) HOLDS THE VALUE OF THE INTEGRAL TO THE
C         SPECIFIED RELATIVE ACCURACY.
C NPTS    NUMBER INTEGRAND EVALUATIONS.
C ICHECK  ON EXIT NORMALLY ICHECK=0. HOWEVER IF CONVERGENCE
C         TO THE ACCURACY REQUESTED IS NOT ACHIEVED ICHECK=1
C         ON EXIT.
C ABSCISSAE AND WEIGHTS OF QUADRATURE RULES ARE STACKED IN
C ARRAY *P* IN THE ORDER IN WHICH THEY ARE NEEDED.
C     --------------------
      DIMENSION FUNCT(127), P(381), RESULT(*)
      EXTERNAL F
      DATA
     * P( 1),P( 2),P( 3),P( 4),P( 5),P( 6),P( 7),
     * P( 8),P( 9),P(10),P(11),P(12),P(13),P(14),
     * P(15),P(16),P(17),P(18),P(19),P(20),P(21),
     * P(22),P(23),P(24),P(25),P(26),P(27),P(28)/
     *  0.77459666924148337704E 00,0.55555555555555555556E 00,
     *  0.88888888888888888889E 00,0.26848808986833344073E 00,
     *  0.96049126870802028342E 00,0.10465622602646726519E 00,
     *  0.43424374934680255800E 00,0.40139741477596222291E 00,
     *  0.45091653865847414235E 00,0.13441525524378422036E 00,
     *  0.51603282997079739697E-01,0.20062852937698902103E 00,
     *  0.99383196321275502221E 00,0.17001719629940260339E-01,
     *  0.88845923287225699889E 00,0.92927195315124537686E-01,
     *  0.62110294673722640294E 00,0.17151190913639138079E 00,
     *  0.22338668642896688163E 00,0.21915685840158749640E 00,
     *  0.22551049979820668739E 00,0.67207754295990703540E-01,
     *  0.25807598096176653565E-01,0.10031427861179557877E 00,
     *  0.84345657393211062463E-02,0.46462893261757986541E-01,
     *  0.85755920049990351154E-01,0.10957842105592463824E 00/
      DATA
     * P(29),P(30),P(31),P(32),P(33),P(34),P(35),
     * P(36),P(37),P(38),P(39),P(40),P(41),P(42),
     * P(43),P(44),P(45),P(46),P(47),P(48),P(49),
     * P(50),P(51),P(52),P(53),P(54),P(55),P(56)/
     *  0.99909812496766759766E 00,0.25447807915618744154E-02,
     *  0.98153114955374010687E 00,0.16446049854387810934E-01,
     *  0.92965485742974005667E 00,0.35957103307129322097E-01,
     *  0.83672593816886873550E 00,0.56979509494123357412E-01,
     *  0.70249620649152707861E 00,0.76879620499003531043E-01,
     *  0.53131974364437562397E 00,0.93627109981264473617E-01,
     *  0.33113539325797683309E 00,0.10566989358023480974E 00,
     *  0.11248894313318662575E 00,0.11195687302095345688E 00,
     *  0.11275525672076869161E 00,0.33603877148207730542E-01,
     *  0.12903800100351265626E-01,0.50157139305899537414E-01,
     *  0.42176304415588548391E-02,0.23231446639910269443E-01,
     *  0.42877960025007734493E-01,0.54789210527962865032E-01,
     *  0.12651565562300680114E-02,0.82230079572359296693E-02,
     *  0.17978551568128270333E-01,0.28489754745833548613E-01/
      DATA
     * P(57),P(58),P(59),P(60),P(61),P(62),P(63),
     * P(64),P(65),P(66),P(67),P(68),P(69),P(70),
     * P(71),P(72),P(73),P(74),P(75),P(76),P(77),
     * P(78),P(79),P(80),P(81),P(82),P(83),P(84)/
     *  0.38439810249455532039E-01,0.46813554990628012403E-01,
     *  0.52834946790116519862E-01,0.55978436510476319408E-01,
     *  0.99987288812035761194E 00,0.36322148184553065969E-03,
     *  0.99720625937222195908E 00,0.25790497946856882724E-02,
     *  0.98868475754742947994E 00,0.61155068221172463397E-02,
     *  0.97218287474858179658E 00,0.10498246909621321898E-01,
     *  0.94634285837340290515E 00,0.15406750466559497802E-01,
     *  0.91037115695700429250E 00,0.20594233915912711149E-01,
     *  0.86390793819369047715E 00,0.25869679327214746911E-01,
     *  0.80694053195021761186E 00,0.31073551111687964880E-01,
     *  0.73975604435269475868E 00,0.36064432780782572640E-01,
     *  0.66290966002478059546E 00,0.40715510116944318934E-01,
     *  0.57719571005204581484E 00,0.44914531653632197414E-01,
     *  0.48361802694584102756E 00,0.48564330406673198716E-01/
      DATA
     * P( 85),P( 86),P( 87),P( 88),P( 89),P( 90),P( 91),
     * P( 92),P( 93),P( 94),P( 95),P( 96),P( 97),P( 98),
     * P( 99),P(100),P(101),P(102),P(103),P(104),P(105),
     * P(106),P(107),P(108),P(109),P(110),P(111),P(112)/
     *  0.38335932419873034692E 00,0.51583253952048458777E-01,
     *  0.27774982202182431507E 00,0.53905499335266063927E-01,
     *  0.16823525155220746498E 00,0.55481404356559363988E-01,
     *  0.56344313046592789972E-01,0.56277699831254301273E-01,
     *  0.56377628360384717388E-01,0.16801938574103865271E-01,
     *  0.64519000501757369228E-02,0.25078569652949768707E-01,
     *  0.21088152457266328793E-02,0.11615723319955134727E-01,
     *  0.21438980012503867246E-01,0.27394605263981432516E-01,
     *  0.63260731936263354422E-03,0.41115039786546930472E-02,
     *  0.89892757840641357233E-02,0.14244877372916774306E-01,
     *  0.19219905124727766019E-01,0.23406777495314006201E-01,
     *  0.26417473395058259931E-01,0.27989218255238159704E-01,
     *  0.18073956444538835782E-03,0.12895240826104173921E-02,
     *  0.30577534101755311361E-02,0.52491234548088591251E-02/
      DATA
     * P(113),P(114),P(115),P(116),P(117),P(118),P(119),
     * P(120),P(121),P(122),P(123),P(124),P(125),P(126),
     * P(127),P(128),P(129),P(130),P(131),P(132),P(133),
     * P(134),P(135),P(136),P(137),P(138),P(139),P(140)/
     *  0.77033752332797418482E-02,0.10297116957956355524E-01,
     *  0.12934839663607373455E-01,0.15536775555843982440E-01,
     *  0.18032216390391286320E-01,0.20357755058472159467E-01,
     *  0.22457265826816098707E-01,0.24282165203336599358E-01,
     *  0.25791626976024229388E-01,0.26952749667633031963E-01,
     *  0.27740702178279681994E-01,0.28138849915627150636E-01,
     *  0.99998243035489159858E 00,0.50536095207862517625E-04,
     *  0.99959879967191068325E 00,0.37774664632698466027E-03,
     *  0.99831663531840739253E 00,0.93836984854238150079E-03,
     *  0.99572410469840718851E 00,0.16811428654214699063E-02,
     *  0.99149572117810613240E 00,0.25687649437940203731E-02,
     *  0.98537149959852037111E 00,0.35728927835172996494E-02,
     *  0.97714151463970571416E 00,0.46710503721143217474E-02,
     *  0.96663785155841656709E 00,0.58434498758356395076E-02/
      DATA
     * P(141),P(142),P(143),P(144),P(145),P(146),P(147),
     * P(148),P(149),P(150),P(151),P(152),P(153),P(154),
     * P(155),P(156),P(157),P(158),P(159),P(160),P(161),
     * P(162),P(163),P(164),P(165),P(166),P(167),P(168)/
     *  0.95373000642576113641E 00,0.70724899954335554680E-02,
     *  0.93832039777959288365E 00,0.83428387539681577056E-02,
     *  0.92034002547001242073E 00,0.96411777297025366953E-02,
     *  0.89974489977694003664E 00,0.10955733387837901648E-01,
     *  0.87651341448470526974E 00,0.12275830560082770087E-01,
     *  0.85064449476835027976E 00,0.13591571009765546790E-01,
     *  0.82215625436498040737E 00,0.14893641664815182035E-01,
     *  0.79108493379984836143E 00,0.16173218729577719942E-01,
     *  0.75748396638051363793E 00,0.17421930159464173747E-01,
     *  0.72142308537009891548E 00,0.18631848256138790186E-01,
     *  0.68298743109107922809E 00,0.19795495048097499488E-01,
     *  0.64227664250975951377E 00,0.20905851445812023852E-01,
     *  0.59940393024224289297E 00,0.21956366305317824939E-01,
     *  0.55449513263193254887E 00,0.22940964229387748761E-01/
      DATA
     * P(169),P(170),P(171),P(172),P(173),P(174),P(175),
     * P(176),P(177),P(178),P(179),P(180),P(181),P(182),
     * P(183),P(184),P(185),P(186),P(187),P(188),P(189),
     * P(190),P(191),P(192),P(193),P(194),P(195),P(196)/
     *  0.50768775753371660215E 00,0.23854052106038540080E-01,
     *  0.45913001198983233287E 00,0.24690524744487676909E-01,
     *  0.40897982122988867241E 00,0.25445769965464765813E-01,
     *  0.35740383783153215238E 00,0.26115673376706097680E-01,
     *  0.30457644155671404334E 00,0.26696622927450359906E-01,
     *  0.25067873030348317661E 00,0.27185513229624791819E-01,
     *  0.19589750271110015392E 00,0.27579749566481873035E-01,
     *  0.14042423315256017459E 00,0.27877251476613701609E-01,
     *  0.84454040083710883710E-01,0.28076455793817246607E-01,
     *  0.28184648949745694339E-01,0.28176319033016602131E-01,
     *  0.28188814180192358694E-01,0.84009692870519326354E-02,
     *  0.32259500250878684614E-02,0.12539284826474884353E-01,
     *  0.10544076228633167722E-02,0.58078616599775673635E-02,
     *  0.10719490006251933623E-01,0.13697302631990716258E-01/
      DATA
     * P(197),P(198),P(199),P(200),P(201),P(202),P(203),
     * P(204),P(205),P(206),P(207),P(208),P(209),P(210),
     * P(211),P(212),P(213),P(214),P(215),P(216),P(217),
     * P(218),P(219),P(220),P(221),P(222),P(223),P(224)/
     *  0.31630366082226447689E-03,0.20557519893273465236E-02,
     *  0.44946378920320678616E-02,0.71224386864583871532E-02,
     *  0.96099525623638830097E-02,0.11703388747657003101E-01,
     *  0.13208736697529129966E-01,0.13994609127619079852E-01,
     *  0.90372734658751149261E-04,0.64476204130572477933E-03,
     *  0.15288767050877655684E-02,0.26245617274044295626E-02,
     *  0.38516876166398709241E-02,0.51485584789781777618E-02,
     *  0.64674198318036867274E-02,0.77683877779219912200E-02,
     *  0.90161081951956431600E-02,0.10178877529236079733E-01,
     *  0.11228632913408049354E-01,0.12141082601668299679E-01,
     *  0.12895813488012114694E-01,0.13476374833816515982E-01,
     *  0.13870351089139840997E-01,0.14069424957813575318E-01,
     *  0.25157870384280661489E-04,0.18887326450650491366E-03,
     *  0.46918492424785040975E-03,0.84057143271072246365E-03/
      DATA
     * P(225),P(226),P(227),P(228),P(229),P(230),P(231),
     * P(232),P(233),P(234),P(235),P(236),P(237),P(238),
     * P(239),P(240),P(241),P(242),P(243),P(244),P(245),
     * P(246),P(247),P(248),P(249),P(250),P(251),P(252)/
     *  0.12843824718970101768E-02,0.17864463917586498247E-02,
     *  0.23355251860571608737E-02,0.29217249379178197538E-02,
     *  0.35362449977167777340E-02,0.41714193769840788528E-02,
     *  0.48205888648512683476E-02,0.54778666939189508240E-02,
     *  0.61379152800413850435E-02,0.67957855048827733948E-02,
     *  0.74468208324075910174E-02,0.80866093647888599710E-02,
     *  0.87109650797320868736E-02,0.93159241280693950932E-02,
     *  0.98977475240487497440E-02,0.10452925722906011926E-01,
     *  0.10978183152658912470E-01,0.11470482114693874380E-01,
     *  0.11927026053019270040E-01,0.12345262372243838455E-01,
     *  0.12722884982732382906E-01,0.13057836688353048840E-01,
     *  0.13348311463725179953E-01,0.13592756614812395910E-01,
     *  0.13789874783240936517E-01,0.13938625738306850804E-01,
     *  0.14038227896908623303E-01,0.14088159516508301065E-01/
      DATA
     * P(253),P(254),P(255),P(256),P(257),P(258),P(259),
     * P(260),P(261),P(262),P(263),P(264),P(265),P(266),
     * P(267),P(268),P(269),P(270),P(271),P(272),P(273),
     * P(274),P(275),P(276),P(277),P(278),P(279),P(280)/
     *  0.99999759637974846462E 00,0.69379364324108267170E-05,
     *  0.99994399620705437576E 00,0.53275293669780613125E-04,
     *  0.99976049092443204733E 00,0.13575491094922871973E-03,
     *  0.99938033802502358193E 00,0.24921240048299729402E-03,
     *  0.99874561446809511470E 00,0.38974528447328229322E-03,
     *  0.99780535449595727456E 00,0.55429531493037471492E-03,
     *  0.99651414591489027385E 00,0.74028280424450333046E-03,
     *  0.99483150280062100052E 00,0.94536151685852538246E-03,
     *  0.99272134428278861533E 00,0.11674841174299594077E-02,
     *  0.99015137040077015918E 00,0.14049079956551446427E-02,
     *  0.98709252795403406719E 00,0.16561127281544526052E-02,
     *  0.98351865757863272876E 00,0.19197129710138724125E-02,
     *  0.97940628167086268381E 00,0.21944069253638388388E-02,
     *  0.97473445975240266776E 00,0.24789582266575679307E-02/
      DATA
     * P(281),P(282),P(283),P(284),P(285),P(286),P(287),
     * P(288),P(289),P(290),P(291),P(292),P(293),P(294),
     * P(295),P(296),P(297),P(298),P(299),P(300),P(301),
     * P(302),P(303),P(304),P(305),P(306),P(307),P(308)/
     *  0.96948465950245923177E 00,0.27721957645934509940E-02,
     *  0.96364062156981213252E 00,0.30730184347025783234E-02,
     *  0.95718821610986096274E 00,0.33803979910869203823E-02,
     *  0.95011529752129487656E 00,0.36933779170256508183E-02,
     *  0.94241156519108305981E 00,0.40110687240750233989E-02,
     *  0.93406843615772578800E 00,0.43326409680929828545E-02,
     *  0.92507893290707565236E 00,0.46573172997568547773E-02,
     *  0.91543758715576504064E 00,0.49843645647655386012E-02,
     *  0.90514035881326159519E 00,0.53130866051870565663E-02,
     *  0.89418456833555902286E 00,0.56428181013844441585E-02,
     *  0.88256884024734190684E 00,0.59729195655081658049E-02,
     *  0.87029305554811390585E 00,0.63027734490857587172E-02,
     *  0.85735831088623215653E 00,0.66317812429018878941E-02,
     *  0.84376688267270860104E 00,0.69593614093904229394E-02/
      DATA
     * P(309),P(310),P(311),P(312),P(313),P(314),P(315),
     * P(316),P(317),P(318),P(319),P(320),P(321),P(322),
     * P(323),P(324),P(325),P(326),P(327),P(328),P(329),
     * P(330),P(331),P(332),P(333),P(334),P(335),P(336)/
     *  0.82952219463740140018E 00,0.72849479805538070639E-02,
     *  0.81462878765513741344E 00,0.76079896657190565832E-02,
     *  0.79909229096084140180E 00,0.79279493342948491103E-02,
     *  0.78291939411828301639E 00,0.82443037630328680306E-02,
     *  0.76611781930376009072E 00,0.85565435613076896192E-02,
     *  0.74869629361693660282E 00,0.88641732094824942641E-02,
     *  0.73066452124218126133E 00,0.91667111635607884067E-02,
     *  0.71203315536225203459E 00,0.94636899938300652943E-02,
     *  0.69281376977911470289E 00,0.97546565363174114611E-02,
     *  0.67301883023041847920E 00,0.10039172044056840798E-01,
     *  0.65266166541001749610E 00,0.10316812330947621682E-01,
     *  0.63175643771119423041E 00,0.10587167904885197931E-01,
     *  0.61031811371518640016E 00,0.10849844089337314099E-01,
     *  0.58836243444766254143E 00,0.11104461134006926537E-01/
      DATA
     * P(337),P(338),P(339),P(340),P(341),P(342),P(343),
     * P(344),P(345),P(346),P(347),P(348),P(349),P(350),
     * P(351),P(352),P(353),P(354),P(355),P(356),P(357),
     * P(358),P(359),P(360),P(361),P(362),P(363),P(364)/
     *  0.56590588542365442262E 00,0.11350654315980596602E-01,
     *  0.54296566649831149049E 00,0.11588074033043952568E-01,
     *  0.51955966153745702199E 00,0.11816385890830235763E-01,
     *  0.49570640791876146017E 00,0.12035270785279562630E-01,
     *  0.47142506587165887693E 00,0.12244424981611985899E-01,
     *  0.44673538766202847374E 00,0.12443560190714035263E-01,
     *  0.42165768662616330006E 00,0.12632403643542078765E-01,
     *  0.39621280605761593918E 00,0.12810698163877361967E-01,
     *  0.37042208795007823014E 00,0.12978202239537399286E-01,
     *  0.34430734159943802278E 00,0.13134690091960152836E-01,
     *  0.31789081206847668318E 00,0.13279951743930530650E-01,
     *  0.29119514851824668196E 00,0.13413793085110098513E-01,
     *  0.26424337241092676194E 00,0.13536035934956213614E-01,
     *  0.23705884558982972721E 00,0.13646518102571291428E-01/
      DATA
     * P(365),P(366),P(367),P(368),P(369),P(370),P(371),
     * P(372),P(373),P(374),P(375),P(376),P(377),P(378),
     * P(379),P(380),P(381)/
     *  0.20966523824318119477E 00,0.13745093443001896632E-01,
     *  0.18208649675925219825E 00,0.13831631909506428676E-01,
     *  0.15434681148137810869E 00,0.13906019601325461264E-01,
     *  0.12647058437230196685E 00,0.13968158806516938516E-01,
     *  0.98482396598119202090E-01,0.14017968039456608810E-01,
     *  0.70406976042855179063E-01,0.14055382072649964277E-01,
     *  0.42269164765363603212E-01,0.14080351962553661325E-01,
     *  0.14093886410782462614E-01,0.14092845069160408355E-01,
     *  0.14094407090096179347E-01/
      ICHECK = 0
C CHECK FOR TRIVIAL CASE.
      IF (A.EQ.B) GO TO 70
C SCALE FACTORS.
      SUM = (B+A)/2.0
      DIFF = (B-A)/2.0
C 1-POINT GAUSS
      FZERO = F(SUM)
      RESULT(1) = 2.0*FZERO*DIFF
      I = 0
      IOLD = 0
      INEW = 1
      K = 2
      ACUM = 0.0
      GO TO 30
   10 IF (K.EQ.8) GO TO 50
      K = K + 1
      ACUM = 0.0
C CONTRIBUTION FROM FUNCTION VALUES ALREADY COMPUTED.
      DO 20 J=1,IOLD
        I = I + 1
        ACUM = ACUM + P(I)*FUNCT(J)
   20 CONTINUE
C CONTRIBUTION FROM NEW FUNCTION VALUES.
   30 IOLD = IOLD + INEW
      DO 40 J=INEW,IOLD
        I = I + 1
        X = P(I)*DIFF
        FUNCT(J) = F(SUM+X) + F(SUM-X)
        I = I + 1
        ACUM = ACUM + P(I)*FUNCT(J)
   40 CONTINUE
      INEW = IOLD + 1
      I = I + 1
      RESULT(K) = (ACUM+P(I)*FZERO)*DIFF
C CHECK FOR CONVERGENCE.
      IF (ABS(RESULT(K)-RESULT(K-1))-EPSIL*ABS(RESULT(K))) 60,
     * 60, 10
C CONVERGENCE NOT ACHIEVED.
   50 ICHECK = 1
C NORMAL TERMINATION.
   60 NPTS = INEW + IOLD
      RETURN
C TRIVIAL CASE
   70 K = 2
      RESULT(1) = 0.0
      RESULT(2) = 0.0
      NPTS = 0
      RETURN
      END
      SUBROUTINE QAGS (F, A, B, EPSABS, EPSREL, RESULT, ABSERR,
     *                 NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK)
C-----------------------------------------------------------------------
C
C                 COMPUTATION OF A DEFINITE INTEGRAL
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           DEFINITE INTEGRAL   I = INTEGRAL OF  F  OVER (A,B),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - REAL
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - REAL
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - REAL
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - REAL
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - REAL
C                     RELATIVE ACCURACY REQUESTED
C
C         ON RETURN
C            RESULT - REAL
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - REAL
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A
C                             LOCAL DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE SUB-
C                             RANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME  POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             IT IS PRESUMED THAT THE REQUESTED
C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT THE
C                             RETURNED RESULT IS THE BEST WHICH CAN BE
C                             OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED
C                             THAT DIVERGENCE CAN OCCUR WITH ANY OTHER
C                             VALUE OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE, LIMIT .LT. 1,
C                             OR LENW .LT. 4 * LIMIT.
C                             RESULT, ABSERR, NEVAL, LAST ARE
C                             SET TO ZERO.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LIMIT DETERMINES THE MAXIMUM NUMBER
C                    OF SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                    INTEGRATION INTERVAL (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH
C                    IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*4.
C                    IF LENW.LT.LIMIT*4, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF
C                    SUBINTERVALS PRODUCED IN THE SUBDIVISION
C                    PROCESS, WHICH DETERMINES THE NUMBER OF
C                    SIGNIFICANT ELEMENTS ACTUALLY IN THE WORK
C                    ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                    ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                    K = LIMIT+1-LAST OTHERWISE
C
C            WORK  - REAL
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST)
C                     CONTAIN THE INTEGRAL APPROXIMATIONS OVER
C                     THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE ERROR ESTIMATES.
C
C         SUBROUTINES OR FUNCTIONS NEEDED
C              - QAGSE
C              - QK21F
C              - QPSRT
C              - QELG
C              - F (USER-PROVIDED FUNCTION)
C              - SPMPAR
C
C-----------------------------------------------------------------------
      REAL WORK(LENW)
      INTEGER IWORK(LIMIT)
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0
      ABSERR = 0.0
      IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN
C
C         PREPARE CALL FOR QAGSE.
C
      L1 = LIMIT + 1
      L2 = LIMIT + L1
      L3 = LIMIT + L2
C
      CALL QAGSE (F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,
     *        IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
      RETURN
      END
      SUBROUTINE QAGSE (F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *              NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
C-----------------------------------------------------------------------
C
C                 COMPUTATION OF A DEFINITE INTEGRAL
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           DEFINITE INTEGRAL   I = INTEGRAL OF  F  OVER (A,B),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - REAL
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - REAL
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - REAL
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - REAL
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - REAL
C                     RELATIVE ACCURACY REQUESTED
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPERBOUND ON THE NUMBER OF
C                     SUBINTERVALS IN THE PARTITION OF (A,B)
C
C         ON RETURN
C            RESULT - REAL
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - REAL
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C
C                         = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A
C                             LOCAL DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE SUB-
C                             RANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME  POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             IT IS PRESUMED THAT THE REQUESTED
C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT THE
C                             RETURNED RESULT IS THE BEST WHICH CAN BE
C                             OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED
C                             THAT DIVERGENCE CAN OCCUR WITH ANY OTHER
C                             VALUE OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE.
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
C                             IORD(1) AND ELIST(1) ARE SET TO ZERO.
C                             ALIST(1) AND BLIST(1) ARE SET TO A AND B
C                             RESPECTIVELY.
C
C            ALIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE GIVEN INTEGRATION RANGE (A,B)
C
C            BLIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE GIVEN INTEGRATION RANGE (A,B)
C
C            RLIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI
C                     OF THE ABSOLUTE ERROR ESTIMATES ON THE
C                     SUBINERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE ERROR
C                     ESTIMATES OVER THE SUBINTERVALS, SUCH
C                     THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE
C                     SUBDIVISION PROCESS
C
C         SUBROUTINES OR FUNCTIONS NEEDED
C              - QK21F
C              - QPSRT
C              - QELG
C              - F (USER-PROVIDED FUNCTION)
C              - SPMPAR
C
C-----------------------------------------------------------------------
      REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,
     *  B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES,ELIST,
     *  EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX,
     *  ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS,
     *  RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,SPMPAR,T,UFLOW
      INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
     *  KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2
      LOGICAL EXTRAP,NOEXT
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     * RES3LA(3),RLIST(LIMIT),RLIST2(52)
C
      EXTERNAL F
C
C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
C            LIMEXP IN SUBROUTINE QELG (RLIST2 SHOULD BE OF DIMENSION
C            (LIMEXP+2) AT LEAST).
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           RLIST2    - ARRAY OF DIMENSION AT LEAST LIMEXP+2
C                       CONTAINING THE PART OF THE EPSILON TABLE
C                       WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
C                       ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT INTERVAL
C           *****2    - VARIABLE FOR THE RIGHT INTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
C           NUMRL2    - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN
C                       APPROPRIATE APPROXIMATION TO THE COMPOUNDED
C                       INTEGRAL HAS BEEN OBTAINED IT IS PUT IN
C                       RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED
C                       BY ONE.
C           SMALL     - LENGTH OF THE SMALLEST INTERVAL CONSIDERED
C                       UP TO NOW, MULTIPLIED BY 1.5
C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION
C                       I.E. BEFORE SUBDIVIDING THE SMALLEST INTERVAL
C                       WE TRY TO DECREASE THE VALUE OF ERLARG.
C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION
C                       IS NO LONGER ALLOWED (TRUE VALUE)
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
      EPMACH = SPMPAR(1)
      UFLOW = SPMPAR(2)
      OFLOW = SPMPAR(3)
C
C            CHECK EPSABS AND EPSREL
C            -----------------------
C
      NEVAL = 0
      LAST = 0
      RESULT = 0.0
      ABSERR = 0.0
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.0
      ELIST(1) = 0.0
      IER = 6
      IF (EPSABS .LT. 0.0 .OR. EPSREL .LT. 0.0) GO TO 999
      IER = 0
      RERR = AMAX1(EPSREL, 50.0*EPMACH, 0.5E-14)
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
      IERRO = 0
      CALL QK21F (F, A, B, RESULT, ABSERR, DEFABS, RESABS,
     *            EPMACH, UFLOW, ID)
      IF (ID .NE. 0) GO TO 999
      NEVAL = 21
C
C           TEST ON ACCURACY.
C
      DRES = ABS(RESULT)
      ERRBND = AMAX1(EPSABS,RERR*DRES)
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      IF (ABSERR .LE. 100.0*EPMACH*DEFABS .AND. ABSERR .GT.
     *    ERRBND) IER = 2
      IF (LIMIT .EQ. 1) IER = 1
      IF (IER .NE. 0) GO TO 999
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      CORREC = 0.0
      NRMAX = 1
      NRES = 0
      NUMRL2 = 2
      KTMIN = 0
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF (DRES .GE. (1.0 - 50.0*EPMACH)*DEFABS) KSGN = 1
      T = 1.0 + 100.0*EPMACH
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST
C           ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5*(ALIST(MAXERR) + BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL QK21F (F, A1, B1, AREA1, ERROR1, RESABS, DEFAB1,
     *              EPMACH, UFLOW, IER)
        IF (IER .NE. 0) GO TO 100
        CALL QK21F (F, A2, B2, AREA2, ERROR2, RESABS, DEFAB2,
     *              EPMACH, UFLOW, IER)
        NEVAL = NEVAL + 42
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1 + AREA2
        ERRO12 = ERROR1 + ERROR2
        ERRSUM = ERRSUM + ERRO12 - ERRMAX
        AREA = AREA + AREA12 - RLIST(MAXERR)
        IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15
        IF (ABS(RLIST(MAXERR) - AREA12) .GT. 0.1E-04*ABS(AREA12)
     *     .OR. ERRO12 .LT. 0.99*ERRMAX) GO TO 10
        IF (EXTRAP) IROFF2 = IROFF2 + 1
        IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1
   10   IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = AMAX1(EPSABS,RERR*ABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY
C           SET ERROR FLAG.
C
        IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2
        IF (IROFF2 .GE. 5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
C           SUBINTERVALS EQUALS LIMIT.
C
        IF (LAST .EQ. LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE.
C
        IF (AMAX1(ABS(A1),ABS(B2)) .LE.
     *      T*(ABS(A2) + 0.1E+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF (ERROR2 .GT. ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE
C           SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE
C           BISECTED NEXT).
C
   30   CALL QPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF (ERRSUM .LE. ERRBND) GO TO 115
C ***JUMP OUT OF DO-LOOP
        IF (IER .NE. 0) GO TO 100
        IF (LAST .EQ. 2) GO TO 80
        IF (NOEXT) GO TO 90
        ERLARG = ERLARG - ERLAST
        IF (ABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12
        IF (EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
   40   IF (IERRO .EQ. 3 .OR. ERLARG .LE. ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS
C           OVER THE LARGER INTERVALS (ERLARG) AND PERFORM
C           EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
C ***JUMP OUT OF DO-LOOP
          IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
          NRMAX = NRMAX + 1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2 + 1
        RLIST2(NUMRL2) = AREA
        CALL QELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES,
     *             EPMACH, OFLOW)
        KTMIN = KTMIN + 1
        IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1E-02*ERRSUM) IER = 5
        IF (ABSEPS .GE. ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = AMAX1(EPSABS,RERR*ABS(RESEPS))
C ***JUMP OUT OF DO-LOOP
        IF (ABSERR .LE. ERTEST) GO TO 100
C
C           PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF (NUMRL2 .EQ. 1) NOEXT = .TRUE.
        IF (IER .EQ. 5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = ABS(B - A)*0.375
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF (ABSERR .EQ. OFLOW) GO TO 115
      IF (IER + IERRO .EQ. 0) GO TO 110
      IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC
      IF (IER .EQ. 0) IER = 3
      IF (RESULT .NE. 0.0 .AND. AREA .NE. 0.0) GO TO 105
      IF (ABSERR .GT. ERRSUM) GO TO 115
      IF (AREA .EQ. 0.0) GO TO 130
      GO TO 110
  105 IF (ABSERR/ABS(RESULT) .GT. ERRSUM/ABS(AREA)) GO TO 115
C
C           TEST ON DIVERGENCE.
C
  110 IF (KSGN .EQ. -1 .AND. AMAX1(ABS(RESULT),ABS(AREA)) .LE.
     *    DEFABS*0.1E-01) GO TO 130
      IF (0.1E-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1E+03
     *    .OR. ERRSUM .GT. ABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.0
      DO 120 K = 1,LAST
         RESULT = RESULT + RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 IF (IER .GT. 2) IER = IER - 1
  999 RETURN
      END
      SUBROUTINE QK21F (F, A, B, RESULT, ABSERR, RESABS, RESASC,
     *                  EPMACH, UFLOW, ISIG)
C-----------------------------------------------------------------------
C
C 1.        PURPOSE
C              TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
C                             ESTIMATE
C                         J = INTEGRAL OF ABS(F) OVER (A,B)
C
C 2.        PARAMETERS
C            ON ENTRY
C              F      - REAL
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS
C                       TO BE DECLARED E X T E R N A L IN THE
C                       CALLING PROGRAM.
C
C              A      - REAL
C                       LOWER LIMIT OF INTEGRATION
C
C              B      - REAL
C                       UPPER LIMIT OF INTEGRATION
C
C              EPMACH - REAL
C                       THE RELATIVE PRECISION OF THE FLOATING
C                       ARITHMETIC BEING USED.
C
C              UFLOW  - REAL
C                       THE SMALLEST POSITIVE MAGNITUDE.
C
C            ON RETURN
C              RESULT - REAL
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE 21-POINT
C                       KRONROD RULE (RESK) OBTAINED BY OPTIMAL
C                       ADDITION OF ABSCISSAE TO THE 10-POINT GAUSS
C                       RULE (RESG).
C
C              ABSERR - REAL
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD NOT EXCEED ABS(I-RESULT)
C
C              RESABS - REAL
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - REAL
C                       APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
C                       OVER (A,B)
C
C              ISIG   - INTEGER
C                       ISIG=0  THE INTEGRAL WAS APPROXIMATED.
C                       ISIG=5  THE INTERVAL (A,B) IS TOO SHORT.
C                               THE INTEGRAL CANNOT BE COMPUTED.
C
C 3.        SUBROUTINES OR FUNCTIONS NEEDED
C                 - F (USER-PROVIDED FUNCTION)
C
C-----------------------------------------------------------------------
      REAL FV1(10), FV2(10), WG(5), WGK(11), XGK(11)
      EXTERNAL F
C
C           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
C           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
C           CORRESPONDING WEIGHTS ARE GIVEN.
C
C           XGK    - ABSCISSAE OF THE 21-POINT KRONROD RULE
C                    XGK(2), XGK(4), ...  ABSCISSAE OF THE 10-POINT
C                    GAUSS RULE
C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
C                    ADDED TO THE 10-POINT GAUSS RULE
C
C           WGK    - WEIGHTS OF THE 21-POINT KRONROD RULE
C
C           WG     - WEIGHTS OF THE 10-POINT GAUSS RULE
C
      DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),
     *  XGK(8),XGK(9),XGK(10),XGK(11)/
     *     0.9956571630258081E+00,     0.9739065285171717E+00,
     *     0.9301574913557082E+00,     0.8650633666889845E+00,
     *     0.7808177265864169E+00,     0.6794095682990244E+00,
     *     0.5627571346686047E+00,     0.4333953941292472E+00,
     *     0.2943928627014602E+00,     0.1488743389816312E+00,
     *     0.0000000000000000E+00/
C
      DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),
     *  WGK(8),WGK(9),WGK(10),WGK(11)/
     *     0.1169463886737187E-01,     0.3255816230796473E-01,
     *     0.5475589657435200E-01,     0.7503967481091995E-01,
     *     0.9312545458369761E-01,     0.1093871588022976E+00,
     *     0.1234919762620659E+00,     0.1347092173114733E+00,
     *     0.1427759385770601E+00,     0.1477391049013385E+00,
     *     0.1494455540029169E+00/
C
      DATA WG(1),WG(2),WG(3),WG(4),WG(5)/
     *     0.6667134430868814E-01,     0.1494513491505806E+00,
     *     0.2190863625159820E+00,     0.2692667193099964E+00,
     *     0.2955242247147529E+00/
C
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTERVAL
C           ABSC   - ABSCISSA
C           FVAL*  - FUNCTION VALUE
C           RESG   - RESULT OF THE 10-POINT GAUSS FORMULA
C           RESK   - RESULT OF THE 21-POINT KRONROD FORMULA
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
C                    I.E. TO I/(B-A)
C
C
      CENTR = 0.5*(A + B)
      HLGTH = 0.5*(B - A)
      DHLGTH = ABS(HLGTH)
C
C             CHECK IF THE INTERVAL (A,B) IS TOO SHORT
C
      ISIG = 5
      ABSC = ABS(CENTR) + DHLGTH*0.14
      IF (ABSC .EQ. ABS(CENTR)) RETURN
C
C           COMPUTE THE 21-POINT KRONROD APPROXIMATION TO
C           THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
C
      ISIG = 0
      RESG = 0.0
      FC = F(CENTR)
      RESK = WGK(11)*FC
      RESABS = ABS(RESK)
      DO 10 J = 1,5
        JTW = 2*J
        ABSC = HLGTH*XGK(JTW)
        FVAL1 = F(CENTR - ABSC)
        FVAL2 = F(CENTR + ABSC)
        FV1(JTW) = FVAL1
        FV2(JTW) = FVAL2
        FSUM = FVAL1 + FVAL2
        RESG = RESG + WG(J)*FSUM
        RESK = RESK + WGK(JTW)*FSUM
        RESABS = RESABS + WGK(JTW)*(ABS(FVAL1) + ABS(FVAL2))
   10 CONTINUE
      DO 15 J = 1,5
        JTWM1 = 2*J - 1
        ABSC = HLGTH*XGK(JTWM1)
        FVAL1 = F(CENTR - ABSC)
        FVAL2 = F(CENTR + ABSC)
        FV1(JTWM1) = FVAL1
        FV2(JTWM1) = FVAL2
        FSUM = FVAL1 + FVAL2
        RESK = RESK + WGK(JTWM1)*FSUM
        RESABS = RESABS + WGK(JTWM1)*(ABS(FVAL1) + ABS(FVAL2))
   15 CONTINUE
      RESKH = RESK*0.5
      RESASC = WGK(11)*ABS(FC - RESKH)
      DO 20 J = 1,10
        RESASC = RESASC + WGK(J)*(ABS(FV1(J)-RESKH) + ABS(FV2(J)-RESKH))
   20 CONTINUE
      RESULT = RESK*HLGTH
      RESABS = RESABS*DHLGTH
      RESASC = RESASC*DHLGTH
      ABSERR = ABS((RESK - RESG)*HLGTH)
      IF (RESASC .NE. 0.0 .AND. ABSERR .NE. 0.0)
     *   ABSERR = RESASC*AMIN1(1.0,
     *   (0.2E+03*ABSERR/RESASC)**1.5)
      TOL = EPMACH*0.5E+02
      IF (RESABS .GT. UFLOW/TOL) ABSERR = AMAX1(ABSERR,TOL*RESABS)
      RETURN
      END
      SUBROUTINE QAGI (F, BOUND, INF, EPSABS, EPSREL, RESULT, ABSERR,
     *                 NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK)
C-----------------------------------------------------------------------
C
C                   INTEGRATION OVER INFINITE INTERVALS
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           INTEGRAL    I = INTEGRAL OF  F  OVER (BOUND,+INFINITY)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,BOUND)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,+INFINITY),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - REAL
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            BOUND  - REAL
C                     FINITE BOUND OF INTEGRATION RANGE
C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
C
C            INF    - INTEGER
C                     INDICATING THE KIND OF INTEGRATION RANGE
C                     INVOLVED
C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
C                     INF = -1            TO  (-INFINITY,BOUND),
C                     INF = 2             TO (-INFINITY,+INFINITY).
C
C            EPSABS - REAL
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - REAL
C                     RELATIVE ACCURACY REQUESTED
C
C         ON RETURN
C            RESULT - REAL
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - REAL
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                   - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS NOT BEEN ACHIEVED.
C
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE
C                             OF LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A LOCAL
C                             DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE
C                             SUBRANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE, LIMIT .LT. 1,
C                             OR LENW .LT. 4 * LIMIT.
C                             RESULT, ABSERR, NEVAL, LAST ARE
C                             SET TO ZERO.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LIMIT DETERMINES THE MAXIMUM NUMBER
C                    OF SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                    INTEGRATION INTERVAL (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH
C                    IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*4.
C                    IF LENW.LT.LIMIT*4, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF
C                    SUBINTERVALS PRODUCED IN THE SUBDIVISION
C                    PROCESS, WHICH DETERMINES THE NUMBER OF SIGNIFICANT
C                    ELEMENTS ACTUALLY IN THE WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                    K ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS,
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                    K = LIMIT+1-LAST OTHERWISE
C
C            WORK  - REAL
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST)
C                     CONTAIN THE INTEGRAL APPROXIMATIONS OVER
C                     THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE ERROR ESTIMATES.
C
C        SUBROUTINES OR FUNCTIONS NEEDED
C              - QAGIE
C              - QK15I
C              - QPSRT
C              - QELG
C              - F (USER PROVIDED FUNCTION)
C              - SPMPAR
C
C-----------------------------------------------------------------------
      REAL WORK(LENW)
      INTEGER IWORK(LIMIT)
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.0
      ABSERR = 0.0
      IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN
C
C         PREPARE CALL FOR QAGIE.
C
      L1 = LIMIT + 1
      L2 = LIMIT + L1
      L3 = LIMIT + L2
C
      CALL QAGIE (F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *  NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
      RETURN
      END
      SUBROUTINE QAGIE (F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *                  NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
C-----------------------------------------------------------------------
C
C                   INTEGRATION OVER INFINITE INTERVALS
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           INTEGRAL    I = INTEGRAL OF  F  OVER (BOUND,+INFINITY)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,BOUND)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,+INFINITY),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - REAL
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            BOUND  - REAL
C                     FINITE BOUND OF INTEGRATION RANGE
C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
C
C            INF    - INTEGER
C                     INDICATING THE KIND OF INTEGRATION RANGE
C                     INVOLVED
C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
C                     INF = -1            TO  (-INFINITY,BOUND),
C                     INF = 2             TO (-INFINITY,+INFINITY).
C
C            EPSABS - REAL
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - REAL
C                     RELATIVE ACCURACY REQUESTED
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPER BOUND ON THE NUMBER OF
C                     SUBINTERVALS IN THE PARTITION OF (A,B),
C                     LIMIT.GE.1
C
C         ON RETURN
C            RESULT - REAL
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - REAL
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                   - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS NOT BEEN ACHIEVED.
C
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE
C                             OF LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A LOCAL
C                             DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE
C                             SUBRANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE.
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
C                             ELIST(1) AND IORD(1) ARE SET TO ZERO.
C                             ALIST(1) AND BLIST(1) ARE SET TO 0
C                             AND 1 RESPECTIVELY.
C
C            ALIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
C
C            BLIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
C
C            RLIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT,  THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI
C                     OF THE ABSOLUTE ERROR ESTIMATES ON THE
C                     SUBINTERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE
C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED
C                     IN THE SUBDIVISION PROCESS
C
C        SUBROUTINES OR FUNCTIONS NEEDED
C              - QK15I
C              - QPSRT
C              - QELG
C              - F (USER-PROVIDED FUNCTION)
C              - SPMPAR
C
C-----------------------------------------------------------------------
      REAL ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,
     *  BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES,
     *  ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX,
     *  ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS,
     *  RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,SPMPAR,T,UFLOW
      INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
     *  KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2
      LOGICAL EXTRAP,NOEXT
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     *  RES3LA(3),RLIST(LIMIT),RLIST2(52)
C
      EXTERNAL F
C
C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
C            LIMEXP IN SUBROUTINE QELG.
C
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           RLIST2    - ARRAY OF DIMENSION AT LEAST (LIMEXP+2),
C                       CONTAINING THE PART OF THE EPSILON TABLE
C                       WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
C                       ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
C           NUMRL2    - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN
C                       APPROPRIATE APPROXIMATION TO THE COMPOUNDED
C                       INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN
C                       RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED
C                       BY ONE.
C           SMALL     - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP
C                       TO NOW, MULTIPLIED BY 1.5
C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E.
C                       BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE
C                       TRY TO DECREASE THE VALUE OF ERLARG.
C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION
C                       IS NO LONGER ALLOWED (TRUE-VALUE)
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
      EPMACH = SPMPAR(1)
      UFLOW = SPMPAR(2)
      OFLOW = SPMPAR(3)
C
C           CHECK EPSABS AND EPSREL
C           -----------------------
C
      NEVAL = 0
      LAST = 0
      RESULT = 0.0
      ABSERR = 0.0
      ALIST(1) = 0.0
      BLIST(1) = 1.0
      RLIST(1) = 0.0
      ELIST(1) = 0.0
      IORD(1) = 0
      IER = 6
      IF (EPSABS .LT. 0.0 .OR. EPSREL .LT. 0.0) GO TO 999
      IER = 0
      RERR = AMAX1(EPSREL, 50.0*EPMACH, 0.5E-14)
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
C           DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1).
C           IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE
C           I1 = INTEGRAL OF F OVER (-INFINITY,0),
C           I2 = INTEGRAL OF F OVER (0,+INFINITY).
C
      BOUN = BOUND
      IF (INF .EQ. 2) BOUN = 0.0
      CALL QK15I (F, BOUN, INF, 0.0, 1.0, RESULT, ABSERR,
     *            DEFABS, RESABS, EPMACH, UFLOW)
C
C           TEST ON ACCURACY
C
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      DRES = ABS(RESULT)
      ERRBND = AMAX1(EPSABS,RERR*DRES)
      IF (ABSERR .LE. 100.0*EPMACH*DEFABS .AND. ABSERR .GT. ERRBND)
     *          IER = 2
      IF (LIMIT .EQ. 1) IER = 1
      IF (IER .NE. 0 .OR. (ABSERR .LE. ERRBND .AND. ABSERR .NE. RESABS)
     *    .OR. ABSERR .EQ. 0.0) GO TO 130
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      CORREC = 0.0
      NRMAX = 1
      NRES = 0
      KTMIN = 0
      NUMRL2 = 2
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IERRO = 0
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF (DRES .GE. (1.0 - 50.0*EPMACH)*DEFABS) KSGN = 1
      T = 1.0 + 100.0*EPMACH
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST
C           ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5*(ALIST(MAXERR) + BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL QK15I (F, BOUN, INF, A1, B1, AREA1, ERROR1,
     *              RESABS, DEFAB1, EPMACH, UFLOW)
        CALL QK15I (F, BOUN, INF, A2, B2, AREA2, ERROR2,
     *              RESABS, DEFAB2, EPMACH, UFLOW)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1 + AREA2
        ERRO12 = ERROR1 + ERROR2
        ERRSUM = ERRSUM + ERRO12 - ERRMAX
        AREA = AREA + AREA12 - RLIST(MAXERR)
        IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15
        IF (ABS(RLIST(MAXERR) - AREA12) .GT. 0.1E-04*ABS(AREA12)
     *      .OR. ERRO12 .LT. 0.99*ERRMAX) GO TO 10
        IF (EXTRAP) IROFF2 = IROFF2 + 1
        IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1
   10   IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = AMAX1(EPSABS,RERR*ABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY
C           SET ERROR FLAG.
C
        IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2
        IF (IROFF2 .GE. 5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
C           SUBINTERVALS EQUALS LIMIT.
C
        IF (LAST .EQ. LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT SOME POINTS OF THE INTEGRATION RANGE.
C

        IF (AMAX1(ABS(A1),ABS(B2)) .LE.
     *      T*(ABS(A2) + 0.1E+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF (ERROR2 .GT. ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE
C           SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE
C           BISECTED NEXT).
C
   30   CALL QPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
        IF (ERRSUM .LE. ERRBND) GO TO 115
        IF (IER .NE. 0) GO TO 100
        IF (LAST .EQ. 2) GO TO 80
        IF (NOEXT) GO TO 90
        ERLARG = ERLARG - ERLAST
        IF (ABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12
        IF (EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
   40   IF (IERRO .EQ. 3 .OR. ERLARG .LE. ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS
C           OVER THE LARGER INTERVALS (ERLARG) AND PERFORM
C           EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
          IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
          NRMAX = NRMAX + 1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2 + 1
        RLIST2(NUMRL2) = AREA
        CALL QELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES,
     *             EPMACH, OFLOW)
        KTMIN = KTMIN + 1
        IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1E-02*ERRSUM) IER = 5
        IF (ABSEPS .GE. ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = AMAX1(EPSABS,RERR*ABS(RESEPS))
        IF (ABSERR .LE. ERTEST) GO TO 100
C
C            PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF (NUMRL2 .EQ. 1) NOEXT = .TRUE.
        IF (IER .EQ. 5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = 0.375
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF (ABSERR .EQ. OFLOW) GO TO 115
      IF (IER + IERRO .EQ. 0) GO TO 110
      IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC
      IF (IER .EQ. 0) IER = 3
      IF (RESULT .NE. 0.0 .AND. AREA .NE. 0.0) GO TO 105
      IF (ABSERR .GT. ERRSUM) GO TO 115
      IF (AREA .EQ. 0.0) GO TO 130
      GO TO 110
  105 IF (ABSERR/ABS(RESULT) .GT. ERRSUM/ABS(AREA)) GO TO 115
C
C           TEST ON DIVERGENCE
C
  110 IF (KSGN .EQ. -1 .AND. AMAX1(ABS(RESULT),ABS(AREA)) .LE.
     *    DEFABS*0.1E-01) GO TO 130
      IF (0.1E-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1E+03
     *    .OR. ERRSUM .GT. ABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.0
      DO 120 K = 1,LAST
        RESULT = RESULT + RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 NEVAL = 30*LAST - 15
      IF (INF .EQ. 2) NEVAL = 2*NEVAL
      IF (IER .GT. 2) IER = IER - 1
  999 RETURN
      END
      SUBROUTINE QK15I (F, BOUN, INF, A, B, RESULT, ABSERR, RESABS,
     *                  RESASC, EPMACH, UFLOW)
C-----------------------------------------------------------------------
C
C 1.        PURPOSE
C              THE ORIGINAL (INFINITE) INTEGRATION RANGE IS MAPPED
C              ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1).
C              IT IS THE PURPOSE TO COMPUTE
C              I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B),
C              J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B).
C
C 2.        PARAMETERS
C            ON ENTRY
C              F      - REAL
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS
C                       TO BE DECLARED E X T E R N A L IN THE
C                       CALLING PROGRAM.
C
C              BOUN   - REAL
C                       FINITE BOUND OF ORIGINAL INTEGRATION
C                       RANGE (SET TO ZERO IF INF = +2)
C
C              INF    - INTEGER
C                       IF INF = -1, THE ORIGINAL INTERVAL IS
C                                   (-INFINITY,BOUND),
C                       IF INF = +1, THE ORIGINAL INTERVAL IS
C                                   (BOUND,+INFINITY),
C                       IF INF = +2, THE ORIGINAL INTERVAL IS
C                                   (-INFINITY,+INFINITY) AND
C                       THE INTEGRAL IS COMPUTED AS THE SUM OF TWO
C                       INTEGRALS, ONE OVER (-INFINITY,0)
C                       AND ONE OVER (0,+INFINITY).
C
C              A      - REAL
C                       LOWER LIMIT FOR INTEGRATION OVER SUBRANGE
C                       OF (0,1)
C
C              B      - REAL
C                       UPPER LIMIT FOR INTEGRATION OVER SUBRANGE
C                       OF (0,1)
C
C              EPMACH - REAL
C                       THE RELATIVE PRECISION OF THE FLOATING
C                       ARITHMETIC BEING USED.
C
C              UFLOW  - REAL
C                       THE SMALLEST POSITIVE MAGNITUDE.
C
C            ON RETURN
C              RESULT - REAL
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE 15-POINT
C                       KRONROD RULE(RESK) OBTAINED BY OPTIMAL
C                       ADDITION OF ABSCISSAE TO THE 7-POINT GAUSS
C                       RULE(RESG).
C
C              ABSERR - REAL
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C              RESABS - REAL
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - REAL
C                       APPROXIMATION TO THE INTEGRAL OF
C                       ABS((TRANSFORMED INTEGRAND)-I/(B-A))
C                       OVER (A,B)
C
C 3.        SUBROUTINES OR FUNCTIONS NEEDED
C                 - F (USER-PROVIDED FUNCTION)
C
C-----------------------------------------------------------------------
      REAL FV1(7), FV2(7), XGK(8), WGK(8), WG(8)
      EXTERNAL F
C
C           THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL
C           (-1,1).  BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND
C           THEIR CORRESPONDING WEIGHTS ARE GIVEN.
C
C           XGK    - ABSCISSAE OF THE 15-POINT KRONROD RULE
C                    XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT
C                    GAUSS RULE
C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
C                    ADDED TO THE 7-POINT GAUSS RULE
C
C           WGK    - WEIGHTS OF THE 15-POINT KRONROD RULE
C
C           WG     - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING
C                    TO THE ABSCISSAE XGK(2), XGK(4), ...
C                    WG(1), WG(3), ... ARE SET TO ZERO.
C
      DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),
     *  XGK(8)/
     *     0.9914553711208126E+00,     0.9491079123427585E+00,
     *     0.8648644233597691E+00,     0.7415311855993944E+00,
     *     0.5860872354676911E+00,     0.4058451513773972E+00,
     *     0.2077849550078985E+00,     0.0000000000000000E+00/
C
      DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),
     *  WGK(8)/
     *     0.2293532201052922E-01,     0.6309209262997855E-01,
     *     0.1047900103222502E+00,     0.1406532597155259E+00,
     *     0.1690047266392679E+00,     0.1903505780647854E+00,
     *     0.2044329400752989E+00,     0.2094821410847278E+00/
C
      DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/
     *     0.0000000000000000E+00,     0.1294849661688697E+00,
     *     0.0000000000000000E+00,     0.2797053914892767E+00,
     *     0.0000000000000000E+00,     0.3818300505051189E+00,
     *     0.0000000000000000E+00,     0.4179591836734694E+00/
C
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTERVAL
C           ABSC*  - ABSCISSA
C           TABSC* - TRANSFORMED ABSCISSA
C           FVAL*  - FUNCTION VALUE
C           RESG   - RESULT OF THE 7-POINT GAUSS FORMULA
C           RESK   - RESULT OF THE 15-POINT KRONROD FORMULA
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED
C                    INTEGRAND OVER (A,B), I.E. TO I/(B-A)
C
C
      DINF = MIN0(1,INF)
C
      CENTR = 0.5*(A + B)
      HLGTH = 0.5*(B - A)
      TABSC1 = BOUN + DINF*(1.0 - CENTR)/CENTR
      FVAL1 = F(TABSC1)
      IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1)
      FC = (FVAL1/CENTR)/CENTR
C
C           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO
C           THE INTEGRAL, AND ESTIMATE THE ERROR.
C
      RESG = WG(8)*FC
      RESK = WGK(8)*FC
      RESABS = ABS(RESK)
      DO 10 J = 1,7
        ABSC = HLGTH*XGK(J)
        ABSC1 = CENTR - ABSC
        ABSC2 = CENTR + ABSC
        TABSC1 = BOUN + DINF*(1.0 - ABSC1)/ABSC1
        TABSC2 = BOUN + DINF*(1.0 - ABSC2)/ABSC2
        FVAL1 = F(TABSC1)
        FVAL2 = F(TABSC2)
        IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1)
        IF (INF .EQ. 2) FVAL2 = FVAL2 + F(-TABSC2)
        FVAL1 = (FVAL1/ABSC1)/ABSC1
        FVAL2 = (FVAL2/ABSC2)/ABSC2
        FV1(J) = FVAL1
        FV2(J) = FVAL2
        FSUM = FVAL1 + FVAL2
        RESG = RESG + WG(J)*FSUM
        RESK = RESK + WGK(J)*FSUM
        RESABS = RESABS + WGK(J)*(ABS(FVAL1) + ABS(FVAL2))
   10 CONTINUE
      RESKH = RESK*0.5
      RESASC = WGK(8)*ABS(FC - RESKH)
      DO 20 J = 1,7
        RESASC = RESASC + WGK(J)*(ABS(FV1(J)-RESKH) +
     *                            ABS(FV2(J)-RESKH))
   20 CONTINUE
      RESULT = RESK*HLGTH
      RESASC = RESASC*HLGTH
      RESABS = RESABS*HLGTH
      ABSERR = ABS((RESK - RESG)*HLGTH)
      IF (RESASC .NE. 0.0 .AND. ABSERR .NE. 0.0) ABSERR = RESASC*
     *    AMIN1(1.0, (0.2E+03*ABSERR/RESASC)**1.5)
      TOL = 50.0*EPMACH
      IF (RESABS .GT. UFLOW/TOL) ABSERR = AMAX1(ABSERR, TOL*RESABS)
      RETURN
      END
      SUBROUTINE QPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX)
C     ..................................................................
C
C 1.        QPSRT
C           ORDERING ROUTINE
C              STANDARD FORTRAN SUBROUTINE
C              REAL VERSION
C
C 2.        PURPOSE
C              THIS ROUTINE MAINTAINS THE DESCENDING ORDERING
C              IN THE LIST OF THE LOCAL ERROR ESTIMATES RESULTING FROM
C              THE INTERVAL SUBDIVISION PROCESS. AT EACH CALL TWO ERROR
C              ESTIMATES ARE INSERTED USING THE SEQUENTIAL SEARCH
C              METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE
C              AND BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE.
C
C 3.        CALLING SEQUENCE
C              CALL QPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX)
C
C           PARAMETERS (MEANING AT OUTPUT)
C              LIMIT  - INTEGER
C                       MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST
C                       CAN CONTAIN
C
C              LAST   - INTEGER
C                       NUMBER OF ERROR ESTIMATES CURRENTLY
C                       IN THE LIST
C
C              MAXERR - INTEGER
C                       MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR
C                       ESTIMATE CURRENTLY IN THE LIST
C
C              ERMAX  - REAL
C                       NRMAX-TH LARGEST ERROR ESTIMATE
C                       ERMAX = ELIST(MAXERR)
C
C              ELIST  - REAL
C                       VECTOR OF DIMENSION LAST CONTAINING
C                       THE ERROR ESTIMATES
C
C              IORD   - INTEGER
C                       VECTOR OF DIMENSION LAST, THE FIRST K
C                       ELEMENTS OF WHICH CONTAIN POINTERS
C                       TO THE ERROR ESTIMATES, SUCH THAT
C                       ELIST(IORD(1)),... , ELIST(IORD(K))
C                       FORM A DECREASING SEQUENCE, WITH
C                       K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                       K = LIMIT+1-LAST OTHERWISE
C
C              NRMAX  - INTEGER
C                       MAXERR = IORD(NRMAX)
C
C 4.        NO SUBROUTINES OR FUNCTIONS NEEDED
C
C     ..................................................................
C
      REAL ELIST,ERMAX,ERRMAX,ERRMIN
      INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR,
     *  NRMAX
      DIMENSION ELIST(LAST),IORD(LAST)
C
C           CHECK WHETHER THE LIST CONTAINS MORE THAN
C           TWO ERROR ESTIMATES.
C
C***FIRST EXECUTABLE STATEMENT  QPSRT
      IF(LAST.GT.2) GO TO 10
      IORD(1) = 1
      IORD(2) = 2
      GO TO 90
C
C           THIS PART OF THE ROUTINE IS ONLY EXECUTED
C           IF, DUE TO A DIFFICULT INTEGRAND, SUBDIVISION
C           INCREASED THE ERROR ESTIMATE. IN THE NORMAL CASE
C           THE INSERT PROCEDURE SHOULD START AFTER THE
C           NRMAX-TH LARGEST ERROR ESTIMATE.
C
   10 ERRMAX = ELIST(MAXERR)
      IF(NRMAX.EQ.1) GO TO 30
      IDO = NRMAX-1
      DO 20 I = 1,IDO
        ISUCC = IORD(NRMAX-1)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30
        IORD(NRMAX) = ISUCC
        NRMAX = NRMAX-1
   20    CONTINUE
C
C           COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO
C           BE MAINTAINED IN DESCENDING ORDER. THIS NUMBER
C           DEPENDS ON THE NUMBER OF SUBDIVISIONS STILL
C           ALLOWED.
C
   30 JUPBN = LAST
      IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST
      ERRMIN = ELIST(LAST)
C
C           INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN,
C           STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)).
C
      JBND = JUPBN-1
      IBEG = NRMAX+1
      IF(IBEG.GT.JBND) GO TO 50
      DO 40 I=IBEG,JBND
        ISUCC = IORD(I)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60
        IORD(I-1) = ISUCC
   40 CONTINUE
   50 IORD(JBND) = MAXERR
      IORD(JUPBN) = LAST
      GO TO 90
C
C           INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP.
C
   60 IORD(I-1) = MAXERR
      K = JBND
      DO 70 J=I,JBND
        ISUCC = IORD(K)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80
        IORD(K+1) = ISUCC
        K = K-1
   70 CONTINUE
      IORD(I) = LAST
      GO TO 90
   80 IORD(K+1) = LAST
C
C           SET MAXERR AND ERMAX.
C
   90 MAXERR = IORD(NRMAX)
      ERMAX = ELIST(MAXERR)
      RETURN
      END
      SUBROUTINE QELG (N, EPSTAB, RESULT, ABSERR, RES3LA, NRES,
     *                 EPMACH, OFLOW)
C-----------------------------------------------------------------------
C
C 1.        PURPOSE
C              THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF
C              APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM
C              OF P. WYNN.
C              AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN.
C              THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE
C              ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL
C              ARE PRESERVED.
C
C 2.        PARAMETERS
C              N      - INTEGER
C                       EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE
C                       FIRST COLUMN OF THE EPSILON TABLE.
C
C              EPSTAB - REAL
C                       VECTOR OF DIMENSION 52 CONTAINING THE
C                       ELEMENTS OF THE TWO LOWER DIAGONALS OF
C                       THE TRIANGULAR EPSILON TABLE
C                       THE ELEMENTS ARE NUMBERED STARTING AT THE
C                       RIGHT-HAND CORNER OF THE TRIANGLE.
C
C              RESULT - REAL
C                       RESULTING APPROXIMATION TO THE INTEGRAL
C
C              ABSERR - REAL
C                       ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM
C                       RESULT AND THE 3 PREVIOUS RESULTS
C
C              RES3LA - REAL
C                       VECTOR OF DIMENSION 3 CONTAINING THE LAST 3
C                       RESULTS
C
C              NRES   - INTEGER
C                       NUMBER OF CALLS TO THE ROUTINE
C                       (SHOULD BE ZERO AT FIRST CALL)
C
C              EPMACH - REAL
C                       THE RELATIVE PRECISION OF THE FLOATING
C                       ARITHMETIC BEING USED.
C
C              OFLOW  - REAL
C                       THE LARGEST POSITIVE MAGNITUDE.
C
C 3.        NO SUBROUTINES OR FUNCTIONS USED
C
C-----------------------------------------------------------------------
      REAL EPSTAB(52), RES3LA(3)
C---------------------
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           E0     - THE 4 ELEMENTS ON WHICH THE
C           E1       COMPUTATION OF A NEW ELEMENT IN
C           E2       THE EPSILON TABLE IS BASED
C           E3                 E0
C                        E3    E1    NEW
C                              E2
C           NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW
C                    DIAGONAL
C           ERROR  - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2)
C           RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE
C                    OF ERROR
C
C           LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON
C           TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER
C           DIAGONAL OF THE EPSILON TABLE IS DELETED.
C
      NRES = NRES + 1
      ABSERR = OFLOW
      RESULT = EPSTAB(N)
      IF (N .LT. 3) GO TO 100
      LIMEXP = 50
      EPSTAB(N + 2) = EPSTAB(N)
      NEWELM = (N - 1)/2
      EPSTAB(N) = OFLOW
      NUM = N
      K1 = N
      DO 40 I = 1,NEWELM
        K2 = K1 - 1
        K3 = K1 - 2
        RES = EPSTAB(K1 + 2)
        E0 = EPSTAB(K3)
        E1 = EPSTAB(K2)
        E2 = RES
        E1ABS = ABS(E1)
        DELTA2 = E2 - E1
        ERR2 = ABS(DELTA2)
        TOL2 = AMAX1(ABS(E2),E1ABS)*EPMACH
        DELTA3 = E1 - E0
        ERR3 = ABS(DELTA3)
        TOL3 = AMAX1(E1ABS,ABS(E0))*EPMACH
        IF (ERR2 .GT. TOL2 .OR. ERR3 .GT. TOL3) GO TO 10
C
C           IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE
C           ACCURACY, CONVERGENCE IS ASSUMED.
C           RESULT = E2
C           ABSERR = ABS(E1-E0) + ABS(E2-E1)
C
        RESULT = RES
        ABSERR = ERR2 + ERR3
C ***JUMP OUT OF DO-LOOP
        GO TO 100
   10   E3 = EPSTAB(K1)
        EPSTAB(K1) = E1
        DELTA1 = E1 - E3
        ERR1 = ABS(DELTA1)
        TOL1 = AMAX1(E1ABS,ABS(E3))*EPMACH
C
C           IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT
C           A PART OF THE TABLE BY ADJUSTING THE VALUE OF N
C
        IF (ERR1.LE.TOL1 .OR. ERR2.LE.TOL2 .OR. ERR3.LE.TOL3) GO TO 20
        SS = 1.0/DELTA1 + 1.0/DELTA2 - 1.0/DELTA3
        EPSINF = ABS(SS*E1)
C
C           TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND
C           EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE
C           OF N.
C
        IF (EPSINF .GT. 0.1E-03) GO TO 30
   20   N = I + I - 1
C ***JUMP OUT OF DO-LOOP
        GO TO 50
C
C           COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST
C           THE VALUE OF RESULT.
C
   30   RES = E1 + 1.0/SS
        EPSTAB(K1) = RES
        K1 = K1 - 2
        ERROR = ERR2 + ABS(RES - E2) + ERR3
        IF (ERROR .GT. ABSERR) GO TO 40
        ABSERR = ERROR
        RESULT = RES
   40 CONTINUE
C
C           SHIFT THE TABLE.
C
   50 IF (N .EQ. LIMEXP) N = 2*(LIMEXP/2) - 1
      IB = 1
      IF ((NUM/2)*2 .EQ. NUM) IB = 2
      IE = NEWELM + 1
      DO 60 I = 1,IE
        IB2 = IB + 2
        EPSTAB(IB) = EPSTAB(IB2)
        IB = IB2
   60 CONTINUE
      IF (NUM .EQ. N) GO TO 80
      INDX = NUM - N + 1
      DO 70 I = 1,N
        EPSTAB(I) = EPSTAB(INDX)
        INDX = INDX + 1
   70 CONTINUE
   80 IF (NRES .GE. 4) GO TO 90
      RES3LA(NRES) = RESULT
      ABSERR = OFLOW
      GO TO 100
C
C           COMPUTE ERROR ESTIMATE
C
   90 ABSERR = ABS(RESULT - RES3LA(3)) + ABS(RESULT - RES3LA(2)) +
     *         ABS(RESULT - RES3LA(1))
      RES3LA(1) = RES3LA(2)
      RES3LA(2) = RES3LA(3)
      RES3LA(3) = RESULT
  100 ABSERR = AMAX1(ABSERR,5.0*EPMACH*ABS(RESULT))
      RETURN
      END
      SUBROUTINE QXGS (F,A,B,EPSABS,EPSREL,RESULT,ABSERR,IER,
     *                 LIMIT,LENIW,LENW,LAST,IWORK,WORK)
C
C            THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL  I = INTEGRAL OF F OVER (A,B),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - REAL
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - REAL
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - REAL
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - REAL
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - REAL
C                     RELATIVE ACCURACY REQUESTED
C
C         ON RETURN
C            RESULT - REAL
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - REAL
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF LIMIT
C                             (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT. HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE. IT IS PRESUMED THAT
C                             THE REQUESTED TOLERANCE CANNOT BE
C                             ACHIEVED, AND THAT THE RETURNED RESULT IS
C                             THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS OR
C                             EPSREL IS NEGATIVE, LIMIT .LT. 1,
C                             LENW .LT. 46*LIMIT, OR
C                             LENIW .LT. 3*LIMIT.
C                             RESULT, ABSERR, LAST ARE SET TO
C                             ZERO. EXCEPT WHEN LIMIT OR LENW OR LENIW
C                             IS INVALID, IWORK(1), WORK(LIMIT*2+1) AND
C                             WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1)
C                             IS SET TO A, AND WORK(LIMIT+1) TO B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS
C                    IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL
C                    (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*46.
C                    IF LENW.LT.LIMIT*46, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LENIW - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LENIW MUST BE AT LEAST LIMIT*3.
C                    IF LENW.LT.LIMIT*3, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS
C                    PRODUCED IN THE SUBDIVISION PROCESS, WHICH DETER-
C                    MINES THE NUMBER OF SIGNIFICANT ELEMENTS ACTUALLY
C                    IN THE WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST 3*LIMIT, THE FIRST K
C                    ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2),
C                    AND K = LIMIT+1-LAST OTHERWISE.
C
C            WORK  - REAL
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END-POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END-POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN
C                     THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE ERROR ESTIMATES.
C                    WORK(LIMIT*4+1), ... IS THE AREA RESERVED TO STORE
C                     FUNCTIONAL VALUES.
C
      REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,L1,L2,L3,L4,L5
C
      DIMENSION IWORK(LENIW),WORK(LENW)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT,LENIW AND LENW.
C
      IER = 6
      LAST = 0
      RESULT = 0.0
      ABSERR = 0.0
      IF (LIMIT.LT.1 .OR. LENIW.LT.LIMIT*3 .OR. LENW.LT.LIMIT*46)
     *    RETURN
C
C         PREPARE CALL FOR QXGSE.
C
      L1 = LIMIT + 1
      L2 = LIMIT + L1
      L3 = LIMIT + L2
      L4 = LIMIT + L3
      L5 = 21*LIMIT + L4
C
      CALL QXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *  IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST,
     *  WORK(L4),WORK(L5),IWORK(L1),IWORK(L2))
C
      RETURN
      END
      SUBROUTINE QXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *   IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST,VALP,VALN,LP,LN)
C
C            THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A
C            DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - REAL
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - REAL
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - REAL
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - REAL
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - REAL
C                     RELATIVE ACCURACY REQUESTED
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPERBOUND ON THE NUMBER OF SUBINTERVALS
C                     IN THE PARTITION OF (A,B)
C
C         ON RETURN
C            RESULT - REAL
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - REAL
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                         = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF LIMIT
C                             (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS PRESUMED THAT THE REQUESTED
C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT THE
C                             RETURNED RESULT IS THE BEST WHICH CAN BE
C                             OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS OR
C                             EPSREL IS NEGATIVE. RESULT, ABSERR,
C                             LAST, RLIST(1), IORD(1), AND ELIST(1)
C                             ARE SET TO ZERO. ALIST(1) AND BLIST(1)
C                             ARE SET TO A AND B RESPECTIVELY.
C
C            ALIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE
C                     GIVEN INTEGRATION RANGE (A,B)
C
C            BLIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                     INTEGRATION RANGE (A,B)
C
C            RLIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - REAL
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI OF THE
C                     ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE
C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE
C                     SUBDIVISION PROCESS
C
C            VALP   - REAL
C            VALN     ARRAYS OF DIMENSION AT LEAST (21,LIMIT) USED TO
C                     SAVE THE FUNCTIONAL VALUES
C
C            LP     - INTEGER
C            LN       VECTORS OF DIMENSION AT LEAST LIMIT, USED TO
C                     STORE THE ACTUAL NUMBER OF FUNCTIONAL VALUES
C                     SAVED IN THE CORRESPONDING COLUMN
C                     OF VALP,VALN
C
C***ROUTINES CALLED  F,SPMPAR,QELG,QXLQM,QPSRT,QXRRD,QXCPY
C
      REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,
     *  B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES,ELIST,
     *  EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX,
     *  ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS,
     *  RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,T,UFLOW,
     *  VALP,VALN,VP1,VP2,VN1,VN2,SPMPAR
      INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
     *  KTMIN,LAST,LIMIT,MAXERR,NRES,NRMAX,NUMRL2,
     *  LP,LN,LP1,LP2,LN1,LN2
      LOGICAL EXTRAP,NOEXT
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     * RES3LA(3),RLIST(LIMIT),RLIST2(52),
     * VALP(21,LIMIT),VALN(21,LIMIT),LP(LIMIT),LN(LIMIT),
     * VP1(21),VP2(21),VN1(21),VN2(21)
C
      EXTERNAL F
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C          EPMACH IS THE LARGEST RELATIVE SPACING.
C          UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C          OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
      EPMACH = SPMPAR(1)
      UFLOW = SPMPAR(2)
      OFLOW = SPMPAR(3)
C
C            TEST ON VALIDITY OF PARAMETERS
C            ------------------------------
      LAST = 0
      RESULT = 0.0
      ABSERR = 0.0
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.0
      ELIST(1) = 0.0
      IER = 6
      IF (EPSABS .LT. 0.0 .OR. EPSREL.LT. 0.0) GO TO 999
      IER = 0
      RERR = AMAX1(EPSREL, 50.0*EPMACH)
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
      IERRO = 0
      LP(1) = 1
      LN(1) = 1
      VALP(1,1) = F((A + B)*0.5)
      VALN(1,1) = VALP(1,1)
      CALL QXLQM (F,A,B,RESULT,ABSERR,DEFABS,RESABS,
     *            VALP(1,1),VALN(1,1),LP(1),LN(1),2,
     *            EPMACH,UFLOW,OFLOW)
C
C           TEST ON ACCURACY.
C
      DRES = ABS(RESULT)
      ERRBND = AMAX1(EPSABS,RERR*DRES)
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      IF (ABSERR .LE. 100.0*EPMACH*DEFABS .AND. ABSERR .GT.
     *    ERRBND) IER = 2
      IF (LIMIT .EQ. 1) IER = 1
      IF (IER .NE. 0 .OR. (ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS) .OR.
     *    ABSERR .EQ. 0.0) GO TO 999
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      NRMAX = 1
      NRES = 0
      NUMRL2 = 2
      KTMIN = 0
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF (DRES .GE. (1.0 - 50.0*EPMACH)*DEFABS) KSGN = 1
      T = 1.0 + 100.0*EPMACH
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR
C           ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5*(ALIST(MAXERR) + BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL QXRRD(F,VALN(1,MAXERR),LN(MAXERR),B1,A1,VN1,VP1,LN1,LP1)
        CALL QXLQM(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1,VP1,VN1,LP1,LN1,
     *             2,EPMACH,UFLOW,OFLOW)
        CALL QXRRD(F,VALP(1,MAXERR),LP(MAXERR),A2,B2,VP2,VN2,LP2,LN2)
        CALL QXLQM(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2,VP2,VN2,LP2,LN2,
     *             2,EPMACH,UFLOW,OFLOW)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1 + AREA2
        ERRO12 = ERROR1 + ERROR2
        ERRSUM = ERRSUM + ERRO12 - ERRMAX
        AREA = AREA + AREA12 - RLIST(MAXERR)
        IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15
        IF (ABS(RLIST(MAXERR) - AREA12) .GT. 0.1E-04*ABS(AREA12)
     *     .OR. ERRO12 .LT. 0.99*ERRMAX) GO TO 10
        IF (EXTRAP) IROFF2 = IROFF2 + 1
        IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1
   10   IF (LAST.GT.10 .AND. ERRO12.GT.ERRMAX) IROFF3 = IROFF3 + 1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = AMAX1(EPSABS,RERR*ABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
C
        IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2
        IF (IROFF2 .GE. 5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS
C           EQUALS LIMIT.
C
        IF (LAST .EQ. LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE.
C
        IF (AMAX1(ABS(A1),ABS(B2)) .LE.
     *      T*(ABS(A2) + 1.E+03*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF (ERROR2 .GT. ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        CALL QXCPY(VALP(1,MAXERR),VP1,LP1)
        LP(MAXERR) = LP1
        CALL QXCPY(VALN(1,MAXERR),VN1,LN1)
        LN(MAXERR) = LN1
        CALL QXCPY(VALP(1,LAST),VP2,LP2)
        LP(LAST) = LP2
        CALL QXCPY(VALN(1,LAST),VN2,LN2)
        LN(LAST) = LN2
        GO TO 30
C
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
        CALL QXCPY(VALP(1,MAXERR),VP2,LP2)
        LP(MAXERR) = LP2
        CALL QXCPY(VALN(1,MAXERR),VN2,LN2)
        LN(MAXERR) = LN2
        CALL QXCPY(VALP(1,LAST),VP1,LP1)
        LP(LAST) = LP1
        CALL QXCPY(VALN(1,LAST),VN1,LN1)
        LN(LAST) = LN1
C
C           CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
   30   CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF(ERRSUM .LE. ERRBND) GO TO 115
C ***JUMP OUT OF DO-LOOP
        IF (IER .NE. 0) GO TO 100
        IF (LAST .EQ. 2) GO TO 80
        IF (NOEXT) GO TO 90
        ERLARG = ERLARG - ERLAST
        IF (ABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12
        IF (EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
C
C           THE BOUND 0.3*ERTEST HAS BEEN INTRODUCED TO PERFORM A
C           MORE CAUTIOUS EXTRAPOLATION THAN IN THE ORIGINAL DQAGSE
C           ROUTINE
C
   40   IF (IERRO .EQ. 3 .OR. ERLARG .LE. 0.3*ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE
C           LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
C ***JUMP OUT OF DO-LOOP
          IF(ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
          NRMAX = NRMAX + 1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2 + 1
        RLIST2(NUMRL2) = AREA
        CALL QELG (NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES,
     *             EPMACH,OFLOW)
        KTMIN = KTMIN + 1
        IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1E-02*ERRSUM) IER = 5
        IF (ABSEPS .GE. ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = AMAX1(EPSABS,RERR*ABS(RESEPS))
C ***JUMP OUT OF DO-LOOP
        IF (ABSERR .LE. ERTEST) GO TO 100
C
C           PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF (NUMRL2 .EQ. 1) NOEXT = .TRUE.
        IF (IER .EQ. 5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = ABS(B - A)*0.375
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF (ABSERR .EQ. OFLOW) GO TO 115
      IF (IER + IERRO .EQ. 0) GO TO 110
      IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC
      IF (IER .EQ. 0) IER = 3
      IF (RESULT .NE. 0.0 .AND. AREA .NE. 0.0) GO TO 105
      IF (ABSERR .GT. ERRSUM) GO TO 115
      IF (AREA .EQ. 0.0) GO TO 130
      GO TO 110
  105 IF (ABSERR/ABS(RESULT) .GT. ERRSUM/ABS(AREA)) GO TO 115
C
C           TEST ON DIVERGENCE.
C
  110 IF(KSGN.EQ.(-1).AND.AMAX1(ABS(RESULT),ABS(AREA)).LE.
     * DEFABS*0.1E-01) GO TO 130
      IF(0.1E-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1E+03
     * .OR.ERRSUM.GT.ABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.0
      DO 120 K = 1,LAST
         RESULT = RESULT + RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 IF (IER .GT. 2) IER = IER - 1
  999 RETURN
      END
      SUBROUTINE QXCPY (A, B, L)
C
C  TO COPY THE REAL VECTOR B OF LENGTH L   I N T O
C          THE REAL VECTOR A OF LENGTH L
C
      INTEGER L
      REAL A(L),B(L)
C
      DO 10 I = 1,L
   10    A(I) = B(I)
      RETURN
      END
      SUBROUTINE QXLQM (F,A,B,RESULT,ABSERR,RESABS,RESASC,VR,VS,LR,LS,
     *                  KEY,EPMACH,UFLOW,OFLOW)
C
C            TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
C                           ESTIMATE
C                       J = INTEGRAL OF ABS(F) OVER (A,B)
C
C           PARAMETERS
C            ON ENTRY
C              F      - REAL
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              A      - REAL
C                       LOWER LIMIT OF INTEGRATION
C
C              B      - REAL
C                       UPPER LIMIT OF INTEGRATION
C
C              VR     - REAL
C                       VECTOR OF LENGTH LR CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              VS     - REAL
C                       VECTOR OF LENGTH LS CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              LR     - INTEGER
C              LS       NUMBER OF ELEMENTS IN
C                       VR,VS RESPECTIVELY
C
C            KEY    - INTEGER
C                     KEY FOR CHOICE OF LOCAL INTEGRATION RULE
C                     RMS FORMULAS ARE USED WITH
C                      13 - 19               POINTS IF KEY.LT.1,
C                      13 - 19 - (27)        POINTS IF KEY = 1,
C                      13 - 19 - (27) - (41) POINTS IF KEY = 2,
C                           19 -  27  - (41) POINTS IF KEY = 3,
C                                 27  -  41  POINTS IF KEY.GT.3.
C
C                         (RULES) USED IF THE FUNCTION APPEARS
C                         ENOUGH REGULAR
C
C              EPMACH - REAL
C                       THE RELATIVE PRECISION OF THE FLOATING
C                       ARITHMETIC BEING USED.
C
C              UFLOW  - REAL
C                       THE SMALLEST POSITIVE MAGNITUDE.
C
C              OFLOW  - REAL
C                       THE LARGEST POSITIVE MAGNITUDE.
C
C            ON RETURN
C              RESULT - REAL
C                       APPROXIMATION TO THE INTEGRAL I
C
C              ABSERR - REAL
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD NOT EXCEED ABS(I-RESULT)
C
C              RESABS - REAL
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - REAL
C                       APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
C                       OVER (A,B)
C
C              VR     - REAL
C                       VECTOR OF LENGTH LR CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              VS     - REAL
C                       VECTOR OF LENGTH LS CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              LR     - INTEGER
C              LS       NUMBER OF ELEMENTS IN
C                       VR,VS RESPECTIVELY
C
C***ROUTINES CALLED  QXRUL
C
      REAL F,A,B,RESULT,ABSERR,RESABS,RESASC,T,
     *     EPMACH,OFLOW,UFLOW,RESG,RESK,ERROLD,VR(21),VS(21)
      INTEGER K,K0,K1,K2,KEY,KEY1,LR,LS
      EXTERNAL F
C
      KEY1 = MAX0(KEY ,  0)
      KEY1 = MIN0(KEY1,  4)
      K0   = MAX0(KEY1-2,0)
      K1   = K0 + 1
      K2   = MIN0(KEY1+1,3)
C
      CALL QXRUL (F,A,B,RESG,RESABS,RESASC,K0,K1,VR,VS,LR,LS)
      ERROLD = OFLOW
      T = 10.0*EPMACH
      DO 10 K = K1,K2
        CALL QXRUL (F,A,B,RESK,RESABS,RESASC,K,K1,VR,VS,LR,LS)
        RESULT = RESK
        ABSERR = ABS(RESK - RESG)
        IF (RESASC .NE. 0.0 .AND. ABSERR .NE. 0.0)
     *      ABSERR = RESASC*AMIN1(1.0,(200.0*ABSERR/RESASC)**1.5)
        IF (RESABS .GT. UFLOW/T) ABSERR = AMAX1(T*RESABS,ABSERR)
        RESG = RESK
        IF (ABSERR .GT. ERROLD*0.16) GO TO 3000
        IF (ABSERR .LT. 1000.0*EPMACH*RESABS) GO TO 3000
        ERROLD = ABSERR
   10 CONTINUE
 3000 CONTINUE
      RETURN
      END
      SUBROUTINE QXRUL (F,XL,XU,Y,YA,YM,KE,K1,FV1,FV2,L1,L2)
C
C            TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
C                           ESTIMATE
C            AND CONDITIONALLY COMPUTE
C                       J = INTEGRAL OF ABS(F) OVER (A,B)
C                       BY USING AN  RMS RULE
C           PARAMETERS
C            ON ENTRY
C              F      - REAL
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              XL     - REAL
C                       LOWER LIMIT OF INTEGRATION
C
C              XU     - REAL
C                       UPPER LIMIT OF INTEGRATION
C
C              KE     - INTEGER
C                     KEY FOR CHOICE OF LOCAL INTEGRATION RULE
C                     AN RMS RULE IS USED WITH
C                         13      POINTS IF KE  = 2,
C                         19      POINTS IF KE  = 3,
C                         27      POINTS IF KE  = 4,
C                         42      POINTS IF KE  = 5
C
C              K1     INTEGER
C                     VALUE OF KEY FOR WHICH THE ADDITIONAL ESTIMATES
C                     YA, YM ARE TO BE COMPUTED
C
C              FV1    - REAL
C                       VECTOR CONTAINING L1
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              FV2    - REAL
C                       VECTOR CONTAINING L2
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              L1     - INTEGER
C              L2       NUMBER OF ELEMENTS IN FV1,FV2  RESPECTIVELY
C
C            ON RETURN
C              Y      - REAL
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE
C                       REQUESTED RMS RULE
C
C              YA     - REAL
C                       IF KEY = K1  APPROXIMATION TO THE INTEGRAL J
C                       ELSE UNCHANGED
C
C              YM     - REAL
C                       IF KEY = K1  APPROXIMATION TO THE INTEGRAL OF
C                                      ABS(F-I/(XU-XL)   OVER (XL,XU)
C                       ELSE UNCHANGED
C
C              FV1    - REAL
C                       VECTOR CONTAINING L1
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              FV2    - REAL
C                       VECTOR CONTAINING L2
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              L1     - INTEGER
C              L2       NUMBER OF ELEMENTS IN FV1,FV2  RESPECTIVELY
C
C------------------------
      REAL F,XL,XU,LDL,Y,YA,YM,Y2,XX(41),WW(52),
     *                 FV1(21),FV2(21),AA,BB,C
      INTEGER ISTART(4),LEN(4),J,KE,K1,L1,L2
      EXTERNAL F
C------------------------
      DATA ISTART(1)/0/, ISTART(2)/7/, ISTART(3)/17/, ISTART(4)/31/
      DATA LEN(1)/7/, LEN(2)/10/, LEN(3)/14/, LEN(4)/21/
C------------------------
      DATA XX( 1)/.0                       /
      DATA XX( 2)/.25000000000000000000E+00/
      DATA XX( 3)/.50000000000000000000E+00/
      DATA XX( 4)/.75000000000000000000E+00/
      DATA XX( 5)/.87500000000000000000E+00/
      DATA XX( 6)/.93750000000000000000E+00/
      DATA XX( 7)/.10000000000000000000E+01/
      DATA XX( 8)/.37500000000000000000E+00/
      DATA XX( 9)/.62500000000000000000E+00/
      DATA XX(10)/.96875000000000000000E+00/
      DATA XX(11)/.12500000000000000000E+00/
      DATA XX(12)/.68750000000000000000E+00/
      DATA XX(13)/.81250000000000000000E+00/
      DATA XX(14)/.98437500000000000000E+00/
      DATA XX(15)/.18750000000000000000E+00/
      DATA XX(16)/.31250000000000000000E+00/
      DATA XX(17)/.43750000000000000000E+00/
      DATA XX(18)/.56250000000000000000E+00/
      DATA XX(19)/.84375000000000000000E+00/
      DATA XX(20)/.90625000000000000000E+00/
      DATA XX(21)/.99218750000000000000E+00/
C   NUMBER OF NODES 13
      DATA WW(1)/1.303262173284849021810473057638590518409112513421E-1/
      DATA WW(2)/2.390632866847646220320329836544615917290026806242E-1/
      DATA WW(3)/2.630626354774670227333506083741355715758124943143E-1/
      DATA WW(4)/2.186819313830574175167853094864355208948886875898E-1/
      DATA WW(5)/2.757897646642836865859601197607471574336674206700E-2/
      DATA WW(6)/1.055750100538458443365034879086669791305550493830E-1/
      DATA WW(7)/1.571194260595182254168429283636656908546309467968E-2/
C   NUMBER OF NODES 19
      DATA WW(8)/1.298751627936015783241173611320651866834051160074E-1/
      DATA WW(9)/2.249996826462523640447834514709508786970828213187E-1/
      DATA WW(15)/5.542699233295875168406783695143646338274805359780E-2/
      DATA WW(10)/1.680415725925575286319046726692683040162290325505E-1/
      DATA WW(16)/9.986735247403367525720377847755415293097913496236E-2/
      DATA WW(11)/1.415567675701225879892811622832845252125600939627E-1/
      DATA WW(12)/1.006482260551160175038684459742336605269707889822E-1/
      DATA WW(13)/2.510604860724282479058338820428989444699235030871E-2/
      DATA WW(17)/4.507523056810492466415880450799432587809828791196E-2/
      DATA WW(14)/9.402964360009747110031098328922608224934320397592E-3/
C   NUMBER OF NODES 27
      DATA WW(18)/6.300942249647773931746170540321811473310938661469E-2/
      DATA WW(28)/1.239572396231834242194189674243818619042280816640E-1/
      DATA WW(19)/1.261383225537664703012999637242003647020326905948E-1/
      DATA WW(25)/1.235837891364555000245004813294817451524633100256E-1/
      DATA WW(20)/1.273864433581028272878709981850307363453523117880E-1/
      DATA WW(26)/1.148933497158144016800199601785309838604146040215E-1/
      DATA WW(29)/2.501306413750310579525950767549691151739047969345E-2/
      DATA WW(21)/8.576500414311820514214087864326799153427368592787E-2/
      DATA WW(30)/4.915957918146130094258849161350510503556792927578E-2/
      DATA WW(22)/7.102884842310253397447305465997026228407227220665E-2/
      DATA WW(23)/5.026383572857942403759829860675892897279675661654E-2/
      DATA WW(27)/1.252575774226122633391477702593585307254527198070E-2/
      DATA WW(31)/2.259167374956474713302030584548274729936249753832E-2/
      DATA WW(24)/4.683670010609093810432609684738393586390722052124E-3/
C   NUMBER OF NODES 41
      DATA WW(32)/6.362762978782724559269342300509058175967124446839E-2/
      DATA WW(42)/1.187141856692283347609436153545356484256869129472E-1/
      DATA WW(46)/1.533126874056586959338368742803997744815413565014E-2/
      DATA WW(33)/9.950065827346794643193261975720606296171462239514E-2/
      DATA WW(47)/3.527159369750123100455704702965541866345781113903E-2/
      DATA WW(39)/8.140326425945938045967829319725797511040878579808E-2/
      DATA WW(48)/5.000556431653955124212795201196389006184693561679E-2/
      DATA WW(34)/7.048220002718565366098742295389607994441704889441E-2/
      DATA WW(49)/5.744164831179720106340717579281831675999717767532E-2/
      DATA WW(40)/6.583213447600552906273539578430361199084485578379E-2/
      DATA WW(43)/5.999947605385971985589674757013565610751028128731E-2/
      DATA WW(35)/6.512297339398335645872697307762912795346716454337E-2/
      DATA WW(44)/5.500937980198041736910257988346101839062581489820E-2/
      DATA WW(50)/1.598823797283813438301248206397233634639162043386E-2/
      DATA WW(36)/3.998229150313659724790527138690215186863915308702E-2/
      DATA WW(51)/2.635660410220884993472478832884065450876913559421E-2/
      DATA WW(37)/3.456512257080287509832054272964315588028252136044E-2/
      DATA WW(41)/2.592913726450792546064232192976262988065252032902E-2/
      DATA WW(45)/5.264422421764655969760271538981443718440340270116E-3/
      DATA WW(52)/1.196003937945541091670106760660561117114584656319E-2/
      DATA WW(38)/2.212167975884114432760321569298651047876071264944E-3/
C------------------------
      K = KE + 1
      IS = ISTART(K)
      KS = LEN(K)
      LDL = XU - XL
      BB = LDL*0.5
      AA = XL + BB
C
      Y = 0.0
      DO 10 I = 1,KS
         C = BB*XX(I)
         IF (I .GT. L1) FV1(I) = F(AA + C)
         IF (I .GT. L2) FV2(I) = F(AA - C)
         J = IS + I
         Y = Y + (FV1(I) + FV2(I))*WW(J)
   10 CONTINUE
C
      Y2 = Y
      Y = Y*BB
      IF (L1 .LT. KS) L1 = KS
      IF (L2 .LT. KS) L2 = KS
      IF (KE .NE. K1) RETURN
C
      YA = 0.0
      DO 20 I = 1,KS
         J = IS + I
         YA = YA + (ABS(FV1(I)) + ABS(FV2(I)))*WW(J)
   20 CONTINUE
      YA = YA*ABS(BB)
C
      Y2 = Y2*0.5
      YM = 0.0
      DO 30 I = 1,KS
         J = IS + I
         YM = YM + (ABS(FV1(I) - Y2) + ABS(FV2(I) - Y2))*WW(J)
   30 CONTINUE
      YM = YM*ABS(BB)
      RETURN
      END
      SUBROUTINE QXRRD (F,Z,LZ,XL,XU,R,S,LR,LS)
C
C            TO REORDER THE COMPUTED FUNCTIONAL VALUES BEFORE
C            THE BISECTION OF AN INTERVAL
C
C           PARAMETERS
C            ON ENTRY
C              F      - REAL
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              XL     - REAL
C                       LOWER LIMIT OF INTERVAL
C
C              XU     - REAL
C                       UPPER LIMIT OF INTERVAL
C
C              Z      - REAL
C                       VECTOR CONTAINING LZ
C                       SAVED  FUNCTIONAL VALUES
C
C              LZ     - INTEGER
C                       NUMBER OF ELEMENTS IN LZ
C
C            ON RETURN
C              R      - REAL
C              S        VECTORS CONTAINING LR, LS
C                       SAVED  FUNCTIONAL VALUES FOR THE NEW INTERVALS
C
C              LR     - INTEGER
C              LS       NUMBER OF ELEMENTES IN R,S RESPECTIVELY
C
C***ROUTINES CALLED  F
C
      REAL F,R,S,Z,XU,XL,DLEN,CENTR
      INTEGER LR,LS,LZ
      DIMENSION R(21),S(21),Z(21)
C
      DLEN = (XU - XL)*0.5
      CENTR = XL + DLEN
      R(1) =  Z(3)
      R(2) =  Z(9)
      R(3) =  Z(4)
      R(4) =  Z(5)
      R(5) =  Z(6)
      R(6) =  Z(10)
      R(7) =  Z(7)
      S(1) =  Z(3)
      S(2) =  Z(8)
      S(3) =  Z(2)
      S(7) =  Z(1)
      IF (LZ .GT. 11) GO TO 10
C
      R(8) =  F(CENTR + DLEN*0.375)
      R(9) =  F(CENTR + DLEN*0.625)
      R(10) = F(CENTR + DLEN*0.96875)
      LR = 10
      IF (LZ .NE. 11) S(4) = F(CENTR - DLEN*0.75)
      IF (LZ .EQ. 11) S(4) = Z(11)
      S(5) =  F(CENTR - DLEN*0.875)
      S(6) =  F(CENTR - DLEN*0.9375)
      S(8) =  F(CENTR - DLEN*0.375)
      S(9) =  F(CENTR - DLEN*0.625)
      S(10) = F(CENTR - DLEN*0.96875)
      LS = 10
      RETURN
C
   10 R(8) = Z(12)
      R(9) = Z(13)
      R(10) = Z(14)
      LR = 10
      S(4) = Z(11)
      S(5) = F(CENTR - DLEN*0.875)
      S(6) = F(CENTR - DLEN*0.9375)
      IF (LZ .GT. 14) GO TO 20
      S(8)  = F(CENTR - DLEN*0.375)
      S(9)  = F(CENTR - DLEN*0.625)
      S(10) = F(CENTR - DLEN*0.96875)
      LS = 10
      RETURN
C
   20 R(11) = Z(18)
      R(12) = Z(19)
      R(13) = Z(20)
      R(14) = Z(21)
      LR = 14
      S(8) = Z(16)
      S(9) = Z(15)
      S(10) = F(CENTR - DLEN*0.96875)
      S(11) = Z(17)
      LS = 11
      RETURN
      END
      SUBROUTINE DQAGS (F, A, B, EPSABS, EPSREL, RESULT, ABSERR,
     *                  NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK)
C-----------------------------------------------------------------------
C
C           DOUBLE PRECISION COMPUTATION OF A DEFINITE INTEGRAL
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           DEFINITE INTEGRAL   I = INTEGRAL OF  F  OVER (A,B),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A
C                             LOCAL DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE SUB-
C                             RANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME  POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             IT IS PRESUMED THAT THE REQUESTED
C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT THE
C                             RETURNED RESULT IS THE BEST WHICH CAN BE
C                             OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED
C                             THAT DIVERGENCE CAN OCCUR WITH ANY OTHER
C                             VALUE OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE, LIMIT .LT. 1,
C                             OR LENW .LT. 4 * LIMIT.
C                             RESULT, ABSERR, NEVAL, LAST ARE
C                             SET TO ZERO.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LIMIT DETERMINES THE MAXIMUM NUMBER
C                    OF SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                    INTEGRATION INTERVAL (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH
C                    IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*4.
C                    IF LENW.LT.LIMIT*4, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF
C                    SUBINTERVALS PRODUCED IN THE SUBDIVISION
C                    PROCESS, WHICH DETERMINES THE NUMBER OF
C                    SIGNIFICANT ELEMENTS ACTUALLY IN THE WORK
C                    ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                    ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                    K = LIMIT+1-LAST OTHERWISE
C
C            WORK  - DOUBLE PRECISION
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST)
C                     CONTAIN THE INTEGRAL APPROXIMATIONS OVER
C                     THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE ERROR ESTIMATES.
C
C         SUBROUTINES OR FUNCTIONS NEEDED
C              - DQAGSE
C              - DQK21
C              - DQPSRT
C              - DQELG
C              - F (USER-PROVIDED FUNCTION)
C              - DPMPAR
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,LENW,LIMIT,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(LIMIT), WORK(LENW)
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.D0
      ABSERR = 0.D0
      IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN
C
C         PREPARE CALL FOR DQAGSE.
C
      L1 = LIMIT + 1
      L2 = LIMIT + L1
      L3 = LIMIT + L2
C
      CALL DQAGSE (F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL,
     *         IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
      RETURN
      END
      SUBROUTINE DQAGSE (F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *               NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
C-----------------------------------------------------------------------
C
C           DOUBLE PRECISION COMPUTATION OF A DEFINITE INTEGRAL
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           DEFINITE INTEGRAL   I = INTEGRAL OF  F  OVER (A,B),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPERBOUND ON THE NUMBER OF
C                     SUBINTERVALS IN THE PARTITION OF (A,B)
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C
C                         = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF
C                             LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A
C                             LOCAL DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE SUB-
C                             RANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME  POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             IT IS PRESUMED THAT THE REQUESTED
C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT THE
C                             RETURNED RESULT IS THE BEST WHICH CAN BE
C                             OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED
C                             THAT DIVERGENCE CAN OCCUR WITH ANY OTHER
C                             VALUE OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE.
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
C                             IORD(1) AND ELIST(1) ARE SET TO ZERO.
C                             ALIST(1) AND BLIST(1) ARE SET TO A AND B
C                             RESPECTIVELY.
C
C            ALIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE GIVEN INTEGRATION RANGE (A,B)
C
C            BLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE GIVEN INTEGRATION RANGE (A,B)
C
C            RLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI
C                     OF THE ABSOLUTE ERROR ESTIMATES ON THE
C                     SUBINERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE ERROR
C                     ESTIMATES OVER THE SUBINTERVALS, SUCH
C                     THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE
C                     SUBDIVISION PROCESS
C
C         SUBROUTINES OR FUNCTIONS NEEDED
C              - DQK21
C              - DQPSRT
C              - DQELG
C              - F (USER-PROVIDED FUNCTION)
C              - DPMPAR
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,
     *  A1,A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DPMPAR,
     *  DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,
     *  ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS,
     *  RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,T,UFLOW
      INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
     *  KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2
      LOGICAL EXTRAP,NOEXT
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     * RES3LA(3),RLIST(LIMIT),RLIST2(52)
C
      EXTERNAL F
C
C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
C            LIMEXP IN SUBROUTINE DQELG (RLIST2 SHOULD BE OF DIMENSION
C            (LIMEXP+2) AT LEAST).
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           RLIST2    - ARRAY OF DIMENSION AT LEAST LIMEXP+2
C                       CONTAINING THE PART OF THE EPSILON TABLE
C                       WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
C                       ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT INTERVAL
C           *****2    - VARIABLE FOR THE RIGHT INTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
C           NUMRL2    - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN
C                       APPROPRIATE APPROXIMATION TO THE COMPOUNDED
C                       INTEGRAL HAS BEEN OBTAINED IT IS PUT IN
C                       RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED
C                       BY ONE.
C           SMALL     - LENGTH OF THE SMALLEST INTERVAL CONSIDERED
C                       UP TO NOW, MULTIPLIED BY 1.5
C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION
C                       I.E. BEFORE SUBDIVIDING THE SMALLEST INTERVAL
C                       WE TRY TO DECREASE THE VALUE OF ERLARG.
C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION
C                       IS NO LONGER ALLOWED (TRUE VALUE)
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
      EPMACH = DPMPAR(1)
      UFLOW = DPMPAR(2)
      OFLOW = DPMPAR(3)
C
C            CHECK EPSABS AND EPSREL
C            -----------------------
C
      NEVAL = 0
      LAST = 0
      RESULT = 0.D0
      ABSERR = 0.D0
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.D0
      ELIST(1) = 0.D0
      IER = 6
      IF (EPSABS .LT. 0.D0 .OR. EPSREL .LT. 0.D0) GO TO 999
      IER = 0
      RERR = DMAX1(EPSREL, 50.D0*EPMACH, 0.5D-28)
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
      IERRO = 0
      CALL DQK21 (F, A, B, RESULT, ABSERR, DEFABS, RESABS,
     *            EPMACH, UFLOW, ID)
      IF (ID .NE. 0) GO TO 999
      NEVAL = 21
C
C           TEST ON ACCURACY.
C
      DRES = DABS(RESULT)
      ERRBND = DMAX1(EPSABS,RERR*DRES)
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      IF (ABSERR .LE. 100.D0*EPMACH*DEFABS .AND. ABSERR .GT.
     *    ERRBND) IER = 2
      IF (LIMIT .EQ. 1) IER = 1
      IF (IER .NE. 0) GO TO 999
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      CORREC = 0.D0
      NRMAX = 1
      NRES = 0
      NUMRL2 = 2
      KTMIN = 0
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF (DRES .GE. (1.D0 - 50.D0*EPMACH)*DEFABS) KSGN = 1
      T = 1.D0 + 100.D0*EPMACH
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST
C           ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5D0*(ALIST(MAXERR) + BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL DQK21 (F, A1, B1, AREA1, ERROR1, RESABS, DEFAB1,
     *              EPMACH, UFLOW, IER)
        IF (IER .NE. 0) GO TO 100
        CALL DQK21 (F, A2, B2, AREA2, ERROR2, RESABS, DEFAB2,
     *              EPMACH, UFLOW, IER)
        NEVAL = NEVAL + 42
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1 + AREA2
        ERRO12 = ERROR1 + ERROR2
        ERRSUM = ERRSUM + ERRO12 - ERRMAX
        AREA = AREA + AREA12 - RLIST(MAXERR)
        IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15
        IF (DABS(RLIST(MAXERR) - AREA12) .GT. 0.1D-04*DABS(AREA12)
     *     .OR. ERRO12 .LT. 0.99D0*ERRMAX) GO TO 10
        IF (EXTRAP) IROFF2 = IROFF2 + 1
        IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1
   10   IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = DMAX1(EPSABS,RERR*DABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY
C           SET ERROR FLAG.
C
        IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2
        IF (IROFF2 .GE. 5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
C           SUBINTERVALS EQUALS LIMIT.
C
        IF (LAST .EQ. LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE.
C
        IF (DMAX1(DABS(A1),DABS(B2)) .LE.
     *      T*(DABS(A2) + 0.1D+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF (ERROR2 .GT. ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE
C           SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE
C           BISECTED NEXT).
C
   30   CALL DQPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF (ERRSUM .LE. ERRBND) GO TO 115
C ***JUMP OUT OF DO-LOOP
        IF (IER .NE. 0) GO TO 100
        IF (LAST .EQ. 2) GO TO 80
        IF (NOEXT) GO TO 90
        ERLARG = ERLARG - ERLAST
        IF (DABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12
        IF (EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
   40   IF (IERRO .EQ. 3 .OR. ERLARG .LE. ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS
C           OVER THE LARGER INTERVALS (ERLARG) AND PERFORM
C           EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
C ***JUMP OUT OF DO-LOOP
          IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
          NRMAX = NRMAX + 1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2 + 1
        RLIST2(NUMRL2) = AREA
        CALL DQELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES,
     *              EPMACH, OFLOW)
        KTMIN = KTMIN + 1
        IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1D-02*ERRSUM) IER = 5
        IF (ABSEPS .GE. ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = DMAX1(EPSABS,RERR*DABS(RESEPS))
C ***JUMP OUT OF DO-LOOP
        IF (ABSERR .LE. ERTEST) GO TO 100
C
C           PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF (NUMRL2 .EQ. 1) NOEXT = .TRUE.
        IF (IER .EQ. 5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5D0
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = DABS(B - A)*0.375D0
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF (ABSERR .EQ. OFLOW) GO TO 115
      IF (IER + IERRO .EQ. 0) GO TO 110
      IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC
      IF (IER .EQ. 0) IER = 3
      IF (RESULT .NE. 0.D0 .AND. AREA .NE. 0.D0) GO TO 105
      IF (ABSERR .GT. ERRSUM) GO TO 115
      IF (AREA .EQ. 0.D0) GO TO 130
      GO TO 110
  105 IF (ABSERR/DABS(RESULT) .GT. ERRSUM/DABS(AREA)) GO TO 115
C
C           TEST ON DIVERGENCE.
C
  110 IF (KSGN .EQ. -1 .AND. DMAX1(DABS(RESULT),DABS(AREA)) .LE.
     *    DEFABS*0.1D-01) GO TO 130
      IF (0.1D-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1D+03
     *    .OR. ERRSUM .GT. DABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.0
      DO 120 K = 1,LAST
         RESULT = RESULT + RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 IF (IER .GT. 2) IER = IER - 1
  999 RETURN
      END
      SUBROUTINE DQK21 (F, A, B, RESULT, ABSERR, RESABS, RESASC,
     *                  EPMACH, UFLOW, ISIG)
C-----------------------------------------------------------------------
C
C 1.        PURPOSE
C              TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
C                             ESTIMATE
C                         J = INTEGRAL OF DABS(F) OVER (A,B)
C
C 2.        PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS
C                       TO BE DECLARED E X T E R N A L IN THE
C                       CALLING PROGRAM.
C
C              A      - DOUBLE PRECISION
C                       LOWER LIMIT OF INTEGRATION
C
C              B      - DOUBLE PRECISION
C                       UPPER LIMIT OF INTEGRATION
C
C              EPMACH - DOUBLE PRECISION
C                       THE RELATIVE PRECISION OF THE FLOATING
C                       ARITHMETIC BEING USED.
C
C              UFLOW  - DOUBLE PRECISION
C                       THE SMALLEST POSITIVE MAGNITUDE.
C
C            ON RETURN
C              RESULT - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE 21-POINT
C                       KRONROD RULE (RESK) OBTAINED BY OPTIMAL
C                       ADDITION OF ABSCISSAE TO THE 10-POINT GAUSS
C                       RULE (RESG).
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD NOT EXCEED ABS(I-RESULT)
C
C              RESABS - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
C                       OVER (A,B)
C
C              ISIG   - INTEGER
C                       ISIG=0  THE INTEGRAL WAS APPROXIMATED.
C                       ISIG=5  THE INTERVAL (A,B) IS TOO SHORT.
C                               THE INTEGRAL CANNOT BE COMPUTED.
C
C 3.        SUBROUTINES OR FUNCTIONS NEEDED
C                 - F (USER-PROVIDED FUNCTION)
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC,
     *    FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESG,RESK,RESKH,
     *    RESULT,TOL,UFLOW,WG,WGK,XGK,RESASC
      INTEGER ISIG,J,JTW,JTWM1
C
      DIMENSION FV1(10), FV2(10), WG(5), WGK(11), XGK(11)
      EXTERNAL F
C
C           THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1).
C           BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR
C           CORRESPONDING WEIGHTS ARE GIVEN.
C
C           XGK    - ABSCISSAE OF THE 21-POINT KRONROD RULE
C                    XGK(2), XGK(4), ...  ABSCISSAE OF THE 10-POINT
C                    GAUSS RULE
C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
C                    ADDED TO THE 10-POINT GAUSS RULE
C
C           WGK    - WEIGHTS OF THE 21-POINT KRONROD RULE
C
C           WG     - WEIGHTS OF THE 10-POINT GAUSS RULE
C
      DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),
     *  XGK(8),XGK(9),XGK(10),XGK(11)/
     *     0.995657163025808080735527280689D+00,
     *     0.973906528517171720077964012084D+00,
     *     0.930157491355708226001207180060D+00,
     *     0.865063366688984510732096688423D+00,
     *     0.780817726586416897063717578345D+00,
     *     0.679409568299024406234327365115D+00,
     *     0.562757134668604683339000099273D+00,
     *     0.433395394129247190799265943166D+00,
     *     0.294392862701460198131126603104D+00,
     *     0.148874338981631210884826001130D+00,
     *     0.000000000000000000000000000000D+00/
C
      DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),
     *  WGK(8),WGK(9),WGK(10),WGK(11)/
     *     0.116946388673718742780643960622D-01,
     *     0.325581623079647274788189724594D-01,
     *     0.547558965743519960313813002446D-01,
     *     0.750396748109199527670431409162D-01,
     *     0.931254545836976055350654650834D-01,
     *     0.109387158802297641899210590326D+00,
     *     0.123491976262065851077958109831D+00,
     *     0.134709217311473325928054001772D+00,
     *     0.142775938577060080797094273139D+00,
     *     0.147739104901338491374841515972D+00,
     *     0.149445554002916905664936468390D+00/
C
      DATA WG(1),WG(2),WG(3),WG(4),WG(5)/
     *     0.666713443086881375935688098933D-01,
     *     0.149451349150580593145776339658D+00,
     *     0.219086362515982043995534934228D+00,
     *     0.269266719309996355091226921569D+00,
     *     0.295524224714752870173892994651D+00/
C
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTERVAL
C           ABSC   - ABSCISSA
C           FVAL*  - FUNCTION VALUE
C           RESG   - RESULT OF THE 10-POINT GAUSS FORMULA
C           RESK   - RESULT OF THE 21-POINT KRONROD FORMULA
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B),
C                    I.E. TO I/(B-A)
C
C
      CENTR = 0.5D0*(A + B)
      HLGTH = 0.5D0*(B - A)
      DHLGTH = DABS(HLGTH)
C
C             CHECK IF THE INTERVAL (A,B) IS TOO SHORT
C
      ISIG = 5
      ABSC = DABS(CENTR) + DHLGTH*0.14D0
      IF (ABSC .EQ. DABS(CENTR)) RETURN
C
C           COMPUTE THE 21-POINT KRONROD APPROXIMATION TO
C           THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR.
C
      ISIG = 0
      RESG = 0.D0
      FC = F(CENTR)
      RESK = WGK(11)*FC
      RESABS = DABS(RESK)
      DO 10 J = 1,5
        JTW = 2*J
        ABSC = HLGTH*XGK(JTW)
        FVAL1 = F(CENTR - ABSC)
        FVAL2 = F(CENTR + ABSC)
        FV1(JTW) = FVAL1
        FV2(JTW) = FVAL2
        FSUM = FVAL1 + FVAL2
        RESG = RESG + WG(J)*FSUM
        RESK = RESK + WGK(JTW)*FSUM
        RESABS = RESABS + WGK(JTW)*(DABS(FVAL1) + DABS(FVAL2))
   10 CONTINUE
      DO 15 J = 1,5
        JTWM1 = 2*J - 1
        ABSC = HLGTH*XGK(JTWM1)
        FVAL1 = F(CENTR - ABSC)
        FVAL2 = F(CENTR + ABSC)
        FV1(JTWM1) = FVAL1
        FV2(JTWM1) = FVAL2
        FSUM = FVAL1 + FVAL2
        RESK = RESK + WGK(JTWM1)*FSUM
        RESABS = RESABS + WGK(JTWM1)*(DABS(FVAL1) + DABS(FVAL2))
   15 CONTINUE
      RESKH = RESK*0.5D0
      RESASC = WGK(11)*DABS(FC - RESKH)
      DO 20 J = 1,10
        RESASC = RESASC + WGK(J)*(DABS(FV1(J)-RESKH)
     *                  + DABS(FV2(J)-RESKH))
   20 CONTINUE
      RESULT = RESK*HLGTH
      RESABS = RESABS*DHLGTH
      RESASC = RESASC*DHLGTH
      ABSERR = DABS((RESK - RESG)*HLGTH)
      IF (RESASC .NE. 0.D0 .AND. ABSERR .NE. 0.D0)
     *   ABSERR = RESASC*DMIN1(1.D0,
     *   (0.2D+03*ABSERR/RESASC)**1.5D0)
      TOL = EPMACH*0.5D+02
      IF (RESABS .GT. UFLOW/TOL) ABSERR = DMAX1(ABSERR,TOL*RESABS)
      RETURN
      END
      SUBROUTINE DQAGI (F, BOUND, INF, EPSABS, EPSREL, RESULT, ABSERR,
     *                  NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK)
C-----------------------------------------------------------------------
C
C         DOUBLE PRECISION INTEGRATION OVER INFINITE INTERVALS
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           INTEGRAL    I = INTEGRAL OF  F  OVER (BOUND,+INFINITY)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,BOUND)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,+INFINITY),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            BOUND  - DOUBLE PRECISION
C                     FINITE BOUND OF INTEGRATION RANGE
C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
C
C            INF    - INTEGER
C                     INDICATING THE KIND OF INTEGRATION RANGE
C                     INVOLVED
C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
C                     INF = -1            TO  (-INFINITY,BOUND),
C                     INF = 2             TO (-INFINITY,+INFINITY).
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                   - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS NOT BEEN ACHIEVED.
C
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE
C                             OF LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A LOCAL
C                             DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE
C                             SUBRANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE, LIMIT .LT. 1,
C                             OR LENW .LT. 4 * LIMIT.
C                             RESULT, ABSERR, NEVAL, LAST ARE
C                             SET TO ZERO.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LIMIT DETERMINES THE MAXIMUM NUMBER
C                    OF SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                    INTEGRATION INTERVAL (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH
C                    IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*4.
C                    IF LENW.LT.LIMIT*4, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF
C                    SUBINTERVALS PRODUCED IN THE SUBDIVISION
C                    PROCESS, WHICH DETERMINES THE NUMBER OF SIGNIFICANT
C                    ELEMENTS ACTUALLY IN THE WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                    K ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS,
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                    K = LIMIT+1-LAST OTHERWISE
C
C            WORK  - DOUBLE PRECISION
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST)
C                     CONTAIN THE INTEGRAL APPROXIMATIONS OVER
C                     THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE ERROR ESTIMATES.
C
C        SUBROUTINES OR FUNCTIONS NEEDED
C              - DQAGIE
C              - DQK15I
C              - DQPSRT
C              - DQELG
C              - F (USER PROVIDED FUNCTION)
C              - DPMPAR
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION ABSERR,BOUND,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,LENW,LIMIT,L1,L2,L3,NEVAL
C
      DIMENSION IWORK(LIMIT),WORK(LENW)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT AND LENW.
C
      IER = 6
      NEVAL = 0
      LAST = 0
      RESULT = 0.D0
      ABSERR = 0.D0
      IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN
C
C         PREPARE CALL FOR DQAGIE
C
      L1 = LIMIT + 1
      L2 = LIMIT + L1
      L3 = LIMIT + L2
C
      CALL DQAGIE (F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *   NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST)
      RETURN
      END
      SUBROUTINE DQAGIE (F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *                   NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST)
C-----------------------------------------------------------------------
C
C                   INTEGRATION OVER INFINITE INTERVALS
C
C-----------------------------------------------------------------------
C
C        PURPOSE
C           THE ROUTINE CALCULATES AN APPROXIMATION  RESULT  TO A GIVEN
C           INTEGRAL    I = INTEGRAL OF  F  OVER (BOUND,+INFINITY)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,BOUND)
C                    OR I = INTEGRAL OF  F  OVER (-INFINITY,+INFINITY),
C           HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C           ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            BOUND  - DOUBLE PRECISION
C                     FINITE BOUND OF INTEGRATION RANGE
C                     (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE)
C
C            INF    - INTEGER
C                     INDICATING THE KIND OF INTEGRATION RANGE
C                     INVOLVED
C                     INF = 1 CORRESPONDS TO  (BOUND,+INFINITY),
C                     INF = -1            TO  (-INFINITY,BOUND),
C                     INF = 2             TO (-INFINITY,+INFINITY).
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPER BOUND ON THE NUMBER OF
C                     SUBINTERVALS IN THE PARTITION OF (A,B),
C                     LIMIT.GE.1
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            NEVAL  - INTEGER
C                     NUMBER OF INTEGRAND EVALUATIONS
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                   - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE
C                             ESTIMATES FOR RESULT AND ERROR ARE LESS
C                             RELIABLE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS NOT BEEN ACHIEVED.
C
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE
C                             SUBDIVISIONS BY INCREASING THE VALUE
C                             OF LIMIT (AND TAKING THE ACCORDING
C                             DIMENSION ADJUSTMENTS INTO ACCOUNT).
C                             HOWEVER, IF THIS YIELDS NO IMPROVEMENT
C                             IT IS ADVISED TO ANALYZE THE INTEGRAND
C                             IN ORDER TO DETERMINE THE INTEGRATION
C                             DIFFICULTIES. IF THE POSITION OF A LOCAL
C                             DIFFICULTY CAN BE DETERMINED (E.G.
C                             SINGULARITY, DISCONTINUITY WITHIN THE
C                             INTERVAL) ONE WILL PROBABLY GAIN FROM
C                             SPLITTING UP THE INTERVAL AT THIS POINT
C                             AND CALLING THE INTEGRATOR ON THE
C                             SUBRANGES. IF POSSIBLE, AN APPROPRIATE
C                             SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED,
C                             WHICH IS DESIGNED FOR HANDLING THE TYPE
C                             OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS
C                             DETECTED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS
C                             AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS ASSUMED THAT THE REQUESTED TOLERANCE
C                             CANNOT BE ACHIEVED, AND THAT THE RETURNED
C                             RESULT IS THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS
C                             OR EPSREL IS NEGATIVE.
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1),
C                             ELIST(1) AND IORD(1) ARE SET TO ZERO.
C                             ALIST(1) AND BLIST(1) ARE SET TO 0
C                             AND 1 RESPECTIVELY.
C
C            ALIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
C
C            BLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT
C                     END POINTS OF THE SUBINTERVALS IN THE PARTITION
C                     OF THE TRANSFORMED INTEGRATION RANGE (0,1).
C
C            RLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT,  THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI
C                     OF THE ABSOLUTE ERROR ESTIMATES ON THE
C                     SUBINTERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE
C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED
C                     IN THE SUBDIVISION PROCESS
C
C        SUBROUTINES OR FUNCTIONS NEEDED
C              - DQK15I
C              - DQPSRT
C              - DQELG
C              - F (USER-PROVIDED FUNCTION)
C              - DPMPAR
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,
     *  A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES,
     *  DPMPAR,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,
     *  ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS,
     *  RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,T,UFLOW
      INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
     *  KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2
      LOGICAL EXTRAP,NOEXT
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     *  RES3LA(3),RLIST(LIMIT),RLIST2(52)
C
      EXTERNAL F
C
C            THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF
C            LIMEXP IN SUBROUTINE DQELG.
C
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           RLIST2    - ARRAY OF DIMENSION AT LEAST (LIMEXP+2),
C                       CONTAINING THE PART OF THE EPSILON TABLE
C                       WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST ERROR
C                       ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           ERLAST    - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED
C                       (BEFORE THAT SUBDIVISION HAS TAKEN PLACE)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C           NRES      - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE
C           NUMRL2    - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN
C                       APPROPRIATE APPROXIMATION TO THE COMPOUNDED
C                       INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN
C                       RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED
C                       BY ONE.
C           SMALL     - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP
C                       TO NOW, MULTIPLIED BY 1.5
C           ERLARG    - SUM OF THE ERRORS OVER THE INTERVALS LARGER
C                       THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW
C           EXTRAP    - LOGICAL VARIABLE DENOTING THAT THE ROUTINE
C                       IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E.
C                       BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE
C                       TRY TO DECREASE THE VALUE OF ERLARG.
C           NOEXT     - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION
C                       IS NO LONGER ALLOWED (TRUE-VALUE)
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
      EPMACH = DPMPAR(1)
      UFLOW = DPMPAR(2)
      OFLOW = DPMPAR(3)
C
C           CHECK EPSABS AND EPSREL
C           -----------------------
C
      NEVAL = 0
      LAST = 0
      RESULT = 0.D0
      ABSERR = 0.D0
      ALIST(1) = 0.D0
      BLIST(1) = 1.D0
      RLIST(1) = 0.D0
      ELIST(1) = 0.D0
      IORD(1) = 0
      IER = 6
      IF (EPSABS .LT. 0.D0 .OR. EPSREL .LT. 0.D0) GO TO 999
      IER = 0
      RERR = DMAX1(EPSREL, 50.D0*EPMACH, 0.5D-28)
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
C           DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1).
C           IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE
C           I1 = INTEGRAL OF F OVER (-INFINITY,0),
C           I2 = INTEGRAL OF F OVER (0,+INFINITY).
C
      BOUN = BOUND
      IF (INF .EQ. 2) BOUN = 0.D0
      CALL DQK15I (F, BOUN, INF, 0.D0, 1.D0, RESULT, ABSERR,
     *             DEFABS, RESABS, EPMACH, UFLOW)
C
C           TEST ON ACCURACY
C
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      DRES = DABS(RESULT)
      ERRBND = DMAX1(EPSABS,RERR*DRES)
      IF (ABSERR .LE. 100.D0*EPMACH*DEFABS .AND. ABSERR .GT. ERRBND)
     *          IER = 2
      IF (LIMIT .EQ. 1) IER = 1
      IF (IER .NE. 0 .OR. (ABSERR .LE. ERRBND .AND. ABSERR .NE. RESABS)
     *    .OR. ABSERR .EQ. 0.D0) GO TO 130
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      CORREC = 0.D0
      NRMAX = 1
      NRES = 0
      KTMIN = 0
      NUMRL2 = 2
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IERRO = 0
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF (DRES .GE. (1.D0 - 50.D0*EPMACH)*DEFABS) KSGN = 1
      T = 1.D0 + 100.D0*EPMACH
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST
C           ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5D0*(ALIST(MAXERR) + BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL DQK15I (F, BOUN, INF, A1, B1, AREA1, ERROR1,
     *               RESABS, DEFAB1, EPMACH, UFLOW)
        CALL DQK15I (F, BOUN, INF, A2, B2, AREA2, ERROR2,
     *               RESABS, DEFAB2, EPMACH, UFLOW)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1 + AREA2
        ERRO12 = ERROR1 + ERROR2
        ERRSUM = ERRSUM + ERRO12 - ERRMAX
        AREA = AREA + AREA12 - RLIST(MAXERR)
        IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15
        IF (DABS(RLIST(MAXERR) - AREA12) .GT. 0.1D-04*DABS(AREA12)
     *      .OR. ERRO12 .LT. 0.99D0*ERRMAX) GO TO 10
        IF (EXTRAP) IROFF2 = IROFF2 + 1
        IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1
   10   IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = DMAX1(EPSABS,RERR*DABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY
C           SET ERROR FLAG.
C
        IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2
        IF (IROFF2 .GE. 5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF
C           SUBINTERVALS EQUALS LIMIT.
C
        IF (LAST .EQ. LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT SOME POINTS OF THE INTEGRATION RANGE.
C

        IF (DMAX1(DABS(A1),DABS(B2)) .LE.
     *      T*(DABS(A2) + 0.1D+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF (ERROR2 .GT. ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE
C           SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE
C           BISECTED NEXT).
C
   30   CALL DQPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
        IF (ERRSUM .LE. ERRBND) GO TO 115
        IF (IER .NE. 0) GO TO 100
        IF (LAST .EQ. 2) GO TO 80
        IF (NOEXT) GO TO 90
        ERLARG = ERLARG - ERLAST
        IF (DABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12
        IF (EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
   40   IF (IERRO .EQ. 3 .OR. ERLARG .LE. ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS
C           OVER THE LARGER INTERVALS (ERLARG) AND PERFORM
C           EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
          IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
          NRMAX = NRMAX + 1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2 + 1
        RLIST2(NUMRL2) = AREA
        CALL DQELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES,
     *              EPMACH, OFLOW)
        KTMIN = KTMIN + 1
        IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1D-02*ERRSUM) IER = 5
        IF (ABSEPS .GE. ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = DMAX1(EPSABS,RERR*DABS(RESEPS))
        IF (ABSERR .LE. ERTEST) GO TO 100
C
C            PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF (NUMRL2 .EQ. 1) NOEXT = .TRUE.
        IF (IER .EQ. 5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5D0
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = 0.375D0
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF (ABSERR .EQ. OFLOW) GO TO 115
      IF (IER + IERRO .EQ. 0) GO TO 110
      IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC
      IF (IER .EQ. 0) IER = 3
      IF (RESULT .NE. 0.D0 .AND. AREA .NE. 0.D0) GO TO 105
      IF (ABSERR .GT. ERRSUM) GO TO 115
      IF (AREA .EQ. 0.D0) GO TO 130
      GO TO 110
  105 IF (ABSERR/DABS(RESULT) .GT. ERRSUM/DABS(AREA)) GO TO 115
C
C           TEST ON DIVERGENCE
C
  110 IF (KSGN .EQ. -1 .AND. DMAX1(DABS(RESULT),DABS(AREA)) .LE.
     *    DEFABS*0.1D-01) GO TO 130
      IF (0.1D-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1D+03
     *    .OR. ERRSUM .GT. DABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.D0
      DO 120 K = 1,LAST
        RESULT = RESULT + RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 NEVAL = 30*LAST - 15
      IF (INF .EQ. 2) NEVAL = 2*NEVAL
      IF (IER .GT. 2) IER = IER - 1
  999 RETURN
      END
      SUBROUTINE DQK15I (F, BOUN, INF, A, B, RESULT, ABSERR, RESABS,
     *                   RESASC, EPMACH, UFLOW)
C-----------------------------------------------------------------------
C
C 1.        PURPOSE
C              THE ORIGINAL (INFINITE) INTEGRATION RANGE IS MAPPED
C              ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1).
C              IT IS THE PURPOSE TO COMPUTE
C              I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B),
C              J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B).
C
C 2.        PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS
C                       TO BE DECLARED E X T E R N A L IN THE
C                       CALLING PROGRAM.
C
C              BOUN   - DOUBLE PRECISION
C                       FINITE BOUND OF ORIGINAL INTEGRATION
C                       RANGE (SET TO ZERO IF INF = +2)
C
C              INF    - INTEGER
C                       IF INF = -1, THE ORIGINAL INTERVAL IS
C                                   (-INFINITY,BOUND),
C                       IF INF = +1, THE ORIGINAL INTERVAL IS
C                                   (BOUND,+INFINITY),
C                       IF INF = +2, THE ORIGINAL INTERVAL IS
C                                   (-INFINITY,+INFINITY) AND
C                       THE INTEGRAL IS COMPUTED AS THE SUM OF TWO
C                       INTEGRALS, ONE OVER (-INFINITY,0)
C                       AND ONE OVER (0,+INFINITY).
C
C              A      - DOUBLE PRECISION
C                       LOWER LIMIT FOR INTEGRATION OVER SUBRANGE
C                       OF (0,1)
C
C              B      - DOUBLE PRECISION
C                       UPPER LIMIT FOR INTEGRATION OVER SUBRANGE
C                       OF (0,1)
C
C              EPMACH - DOUBLE PRECISION
C                       THE RELATIVE PRECISION OF THE FLOATING
C                       ARITHMETIC BEING USED.
C
C              UFLOW  - DOUBLE PRECISION
C                       THE SMALLEST POSITIVE MAGNITUDE.
C
C            ON RETURN
C              RESULT - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE 15-POINT
C                       KRONROD RULE(RESK) OBTAINED BY OPTIMAL
C                       ADDITION OF ABSCISSAE TO THE 7-POINT GAUSS
C                       RULE(RESG).
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C              RESABS - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL OF
C                       ABS((TRANSFORMED INTEGRAND)-I/(B-A))
C                       OVER (A,B)
C
C 3.        SUBROUTINES OR FUNCTIONS NEEDED
C                 - F (USER-PROVIDED FUNCTION)
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR,DINF,
     *            EPMACH,F,FC,FSUM,FVAL1,FVAL2,HLGTH,RESABS,RESASC,
     *            RESG,RESK,RESKH,RESULT,TABSC1,TABSC2,TOL,UFLOW
      DOUBLE PRECISION FV1(7), FV2(7), XGK(8), WGK(8), WG(8)
      EXTERNAL F
C
C           THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL
C           (-1,1).  BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND
C           THEIR CORRESPONDING WEIGHTS ARE GIVEN.
C
C           XGK    - ABSCISSAE OF THE 15-POINT KRONROD RULE
C                    XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT
C                    GAUSS RULE
C                    XGK(1), XGK(3), ...  ABSCISSAE WHICH ARE OPTIMALLY
C                    ADDED TO THE 7-POINT GAUSS RULE
C
C           WGK    - WEIGHTS OF THE 15-POINT KRONROD RULE
C
C           WG     - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING
C                    TO THE ABSCISSAE XGK(2), XGK(4), ...
C                    WG(1), WG(3), ... ARE SET TO ZERO.
C
      DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7),
     *  XGK(8)/
     *     0.991455371120812639206854697526D+00,
     *     0.949107912342758524526189684048D+00,
     *     0.864864423359769072789712788641D+00,
     *     0.741531185599394439863864773281D+00,
     *     0.586087235467691130294144838259D+00,
     *     0.405845151377397166906606412077D+00,
     *     0.207784955007898467600689403773D+00,
     *     0.000000000000000000000000000000D+00/
C
      DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7),
     *  WGK(8)/
     *     0.229353220105292249637320080590D-01,
     *     0.630920926299785532907006631892D-01,
     *     0.104790010322250183839876322542D+00,
     *     0.140653259715525918745189590510D+00,
     *     0.169004726639267902826583426599D+00,
     *     0.190350578064785409913256402421D+00,
     *     0.204432940075298892414161999235D+00,
     *     0.209482141084727828012999174892D+00/
C
      DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/
     *     0.0D+00,    0.129484966168869693270611432679D+00,
     *     0.0D+00,    0.279705391489276667901467771424D+00,
     *     0.0D+00,    0.381830050505118944950369775489D+00,
     *     0.0D+00,    0.417959183673469387755102040816D+00/
C
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTERVAL
C           ABSC*  - ABSCISSA
C           TABSC* - TRANSFORMED ABSCISSA
C           FVAL*  - FUNCTION VALUE
C           RESG   - RESULT OF THE 7-POINT GAUSS FORMULA
C           RESK   - RESULT OF THE 15-POINT KRONROD FORMULA
C           RESKH  - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED
C                    INTEGRAND OVER (A,B), I.E. TO I/(B-A)
C
C
      DINF = MIN0(1,INF)
C
      CENTR = 0.5D0*(A + B)
      HLGTH = 0.5D0*(B - A)
      TABSC1 = BOUN + DINF*(1.D0 - CENTR)/CENTR
      FVAL1 = F(TABSC1)
      IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1)
      FC = (FVAL1/CENTR)/CENTR
C
C           COMPUTE THE 15-POINT KRONROD APPROXIMATION TO
C           THE INTEGRAL, AND ESTIMATE THE ERROR.
C
      RESG = WG(8)*FC
      RESK = WGK(8)*FC
      RESABS = DABS(RESK)
      DO 10 J = 1,7
        ABSC = HLGTH*XGK(J)
        ABSC1 = CENTR - ABSC
        ABSC2 = CENTR + ABSC
        TABSC1 = BOUN + DINF*(1.D0 - ABSC1)/ABSC1
        TABSC2 = BOUN + DINF*(1.D0 - ABSC2)/ABSC2
        FVAL1 = F(TABSC1)
        FVAL2 = F(TABSC2)
        IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1)
        IF (INF .EQ. 2) FVAL2 = FVAL2 + F(-TABSC2)
        FVAL1 = (FVAL1/ABSC1)/ABSC1
        FVAL2 = (FVAL2/ABSC2)/ABSC2
        FV1(J) = FVAL1
        FV2(J) = FVAL2
        FSUM = FVAL1 + FVAL2
        RESG = RESG + WG(J)*FSUM
        RESK = RESK + WGK(J)*FSUM
        RESABS = RESABS + WGK(J)*(DABS(FVAL1) + DABS(FVAL2))
   10 CONTINUE
      RESKH = RESK*0.5D0
      RESASC = WGK(8)*DABS(FC - RESKH)
      DO 20 J = 1,7
        RESASC = RESASC + WGK(J)*(DABS(FV1(J)-RESKH) +
     *                            DABS(FV2(J)-RESKH))
   20 CONTINUE
      RESULT = RESK*HLGTH
      RESASC = RESASC*HLGTH
      RESABS = RESABS*HLGTH
      ABSERR = DABS((RESK - RESG)*HLGTH)
      IF (RESASC .NE. 0.D0 .AND. ABSERR .NE. 0.D0) ABSERR = RESASC*
     *    DMIN1(1.D0, (0.2D+03*ABSERR/RESASC)**1.5D0)
      TOL = 50.D0*EPMACH
      IF (RESABS .GT. UFLOW/TOL) ABSERR = DMAX1(ABSERR, TOL*RESABS)
      RETURN
      END
      SUBROUTINE DQPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX)
C     ..................................................................
C
C 1.        DQPSRT
C           ORDERING ROUTINE
C              STANDARD FORTRAN SUBROUTINE
C              DOUBLE PRECISION VERSION
C
C 2.        PURPOSE
C              THIS ROUTINE MAINTAINS THE DESCENDING ORDERING
C              IN THE LIST OF THE LOCAL ERROR ESTIMATES RESULTING FROM
C              THE INTERVAL SUBDIVISION PROCESS. AT EACH CALL TWO ERROR
C              ESTIMATES ARE INSERTED USING THE SEQUENTIAL SEARCH
C              METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE
C              AND BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE.
C
C 3.        CALLING SEQUENCE
C              CALL DQPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX)
C
C           PARAMETERS (MEANING AT OUTPUT)
C              LIMIT  - INTEGER
C                       MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST
C                       CAN CONTAIN
C
C              LAST   - INTEGER
C                       NUMBER OF ERROR ESTIMATES CURRENTLY
C                       IN THE LIST
C
C              MAXERR - INTEGER
C                       MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR
C                       ESTIMATE CURRENTLY IN THE LIST
C
C              ERMAX  - DOUBLE PRECISION
C                       NRMAX-TH LARGEST ERROR ESTIMATE
C                       ERMAX = ELIST(MAXERR)
C
C              ELIST  - DOUBLE PRECISION
C                       VECTOR OF DIMENSION LAST CONTAINING
C                       THE ERROR ESTIMATES
C
C              IORD   - INTEGER
C                       VECTOR OF DIMENSION LAST, THE FIRST K
C                       ELEMENTS OF WHICH CONTAIN POINTERS
C                       TO THE ERROR ESTIMATES, SUCH THAT
C                       ELIST(IORD(1)),... , ELIST(IORD(K))
C                       FORM A DECREASING SEQUENCE, WITH
C                       K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                       K = LIMIT+1-LAST OTHERWISE
C
C              NRMAX  - INTEGER
C                       MAXERR = IORD(NRMAX)
C
C 4.        NO SUBROUTINES OR FUNCTIONS NEEDED
C
C     ..................................................................
C
      DOUBLE PRECISION ELIST,ERMAX,ERRMAX,ERRMIN
      INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR,
     *  NRMAX
      DIMENSION ELIST(LAST),IORD(LAST)
C
C           CHECK WHETHER THE LIST CONTAINS MORE THAN
C           TWO ERROR ESTIMATES.
C
C***FIRST EXECUTABLE STATEMENT DQPSRT
      IF(LAST.GT.2) GO TO 10
      IORD(1) = 1
      IORD(2) = 2
      GO TO 90
C
C           THIS PART OF THE ROUTINE IS ONLY EXECUTED
C           IF, DUE TO A DIFFICULT INTEGRAND, SUBDIVISION
C           INCREASED THE ERROR ESTIMATE. IN THE NORMAL CASE
C           THE INSERT PROCEDURE SHOULD START AFTER THE
C           NRMAX-TH LARGEST ERROR ESTIMATE.
C
   10 ERRMAX = ELIST(MAXERR)
      IF(NRMAX.EQ.1) GO TO 30
      IDO = NRMAX-1
      DO 20 I = 1,IDO
        ISUCC = IORD(NRMAX-1)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30
        IORD(NRMAX) = ISUCC
        NRMAX = NRMAX-1
   20    CONTINUE
C
C           COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO
C           BE MAINTAINED IN DESCENDING ORDER. THIS NUMBER
C           DEPENDS ON THE NUMBER OF SUBDIVISIONS STILL
C           ALLOWED.
C
   30 JUPBN = LAST
      IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST
      ERRMIN = ELIST(LAST)
C
C           INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN,
C           STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)).
C
      JBND = JUPBN-1
      IBEG = NRMAX+1
      IF(IBEG.GT.JBND) GO TO 50
      DO 40 I=IBEG,JBND
        ISUCC = IORD(I)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60
        IORD(I-1) = ISUCC
   40 CONTINUE
   50 IORD(JBND) = MAXERR
      IORD(JUPBN) = LAST
      GO TO 90
C
C           INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP.
C
   60 IORD(I-1) = MAXERR
      K = JBND
      DO 70 J=I,JBND
        ISUCC = IORD(K)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80
        IORD(K+1) = ISUCC
        K = K-1
   70 CONTINUE
      IORD(I) = LAST
      GO TO 90
   80 IORD(K+1) = LAST
C
C           SET MAXERR AND ERMAX.
C
   90 MAXERR = IORD(NRMAX)
      ERMAX = ELIST(MAXERR)
      RETURN
      END
      SUBROUTINE DQELG (N, EPSTAB, RESULT, ABSERR, RES3LA, NRES,
     *                  EPMACH, OFLOW)
C-----------------------------------------------------------------------
C
C 1.        PURPOSE
C              THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF
C              APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM
C              OF P. WYNN.
C              AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN.
C              THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE
C              ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL
C              ARE PRESERVED.
C
C 2.        PARAMETERS
C              N      - INTEGER
C                       EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE
C                       FIRST COLUMN OF THE EPSILON TABLE.
C
C              EPSTAB - DOUBLE PRECISION
C                       VECTOR OF DIMENSION 52 CONTAINING THE
C                       ELEMENTS OF THE TWO LOWER DIAGONALS OF
C                       THE TRIANGULAR EPSILON TABLE
C                       THE ELEMENTS ARE NUMBERED STARTING AT THE
C                       RIGHT-HAND CORNER OF THE TRIANGLE.
C
C              RESULT - DOUBLE PRECISION
C                       RESULTING APPROXIMATION TO THE INTEGRAL
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM
C                       RESULT AND THE 3 PREVIOUS RESULTS
C
C              RES3LA - DOUBLE PRECISION
C                       VECTOR OF DIMENSION 3 CONTAINING THE LAST 3
C                       RESULTS
C
C              NRES   - INTEGER
C                       NUMBER OF CALLS TO THE ROUTINE
C                       (SHOULD BE ZERO AT FIRST CALL)
C
C              EPMACH - DOUBLE PRECISION
C                       THE RELATIVE PRECISION OF THE FLOATING
C                       ARITHMETIC BEING USED.
C
C              OFLOW  - DOUBLE PRECISION
C                       THE LARGEST POSITIVE MAGNITUDE.
C
C 3.        NO SUBROUTINES OR FUNCTIONS USED
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION ABSERR,DELTA1,DELTA2,DELTA3,EPMACH,EPSINF,
     *                 EPSTAB,ERROR,ERR1,ERR2,ERR3,E0,E1,E1ABS,E2,E3,
     *                 OFLOW,RES,RESULT,RES3LA,SS,TOL1,TOL2,TOL3
      INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM
      DIMENSION EPSTAB(52),RES3LA(3)
C---------------------
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           E0     - THE 4 ELEMENTS ON WHICH THE
C           E1       COMPUTATION OF A NEW ELEMENT IN
C           E2       THE EPSILON TABLE IS BASED
C           E3                 E0
C                        E3    E1    NEW
C                              E2
C           NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW
C                    DIAGONAL
C           ERROR  - ERROR = ABS(E1-E0) + ABS(E2-E1) + ABS(NEW-E2)
C           RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE
C                    OF ERROR
C
C           LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON
C           TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER
C           DIAGONAL OF THE EPSILON TABLE IS DELETED.
C
      NRES = NRES + 1
      ABSERR = OFLOW
      RESULT = EPSTAB(N)
      IF (N .LT. 3) GO TO 100
      LIMEXP = 50
      EPSTAB(N + 2) = EPSTAB(N)
      NEWELM = (N - 1)/2
      EPSTAB(N) = OFLOW
      NUM = N
      K1 = N
      DO 40 I = 1,NEWELM
        K2 = K1 - 1
        K3 = K1 - 2
        RES = EPSTAB(K1 + 2)
        E0 = EPSTAB(K3)
        E1 = EPSTAB(K2)
        E2 = RES
        E1ABS = DABS(E1)
        DELTA2 = E2 - E1
        ERR2 = DABS(DELTA2)
        TOL2 = DMAX1(DABS(E2),E1ABS)*EPMACH
        DELTA3 = E1 - E0
        ERR3 = DABS(DELTA3)
        TOL3 = DMAX1(E1ABS,DABS(E0))*EPMACH
        IF (ERR2 .GT. TOL2 .OR. ERR3 .GT. TOL3) GO TO 10
C
C           IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE
C           ACCURACY, CONVERGENCE IS ASSUMED.
C           RESULT = E2
C           ABSERR = ABS(E1-E0) + ABS(E2-E1)
C
        RESULT = RES
        ABSERR = ERR2 + ERR3
C ***JUMP OUT OF DO-LOOP
        GO TO 100
   10   E3 = EPSTAB(K1)
        EPSTAB(K1) = E1
        DELTA1 = E1 - E3
        ERR1 = DABS(DELTA1)
        TOL1 = DMAX1(E1ABS,DABS(E3))*EPMACH
C
C           IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT
C           A PART OF THE TABLE BY ADJUSTING THE VALUE OF N
C
        IF (ERR1.LE.TOL1 .OR. ERR2.LE.TOL2 .OR. ERR3.LE.TOL3) GO TO 20
        SS = 1.D0/DELTA1 + 1.D0/DELTA2 - 1.D0/DELTA3
        EPSINF = DABS(SS*E1)
C
C           TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND
C           EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE
C           OF N.
C
        IF (EPSINF .GT. 0.1D-03) GO TO 30
   20   N = I + I - 1
C ***JUMP OUT OF DO-LOOP
        GO TO 50
C
C           COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST
C           THE VALUE OF RESULT.
C
   30   RES = E1 + 1.D0/SS
        EPSTAB(K1) = RES
        K1 = K1 - 2
        ERROR = ERR2 + DABS(RES - E2) + ERR3
        IF (ERROR .GT. ABSERR) GO TO 40
        ABSERR = ERROR
        RESULT = RES
   40 CONTINUE
C
C           SHIFT THE TABLE.
C
   50 IF (N .EQ. LIMEXP) N = 2*(LIMEXP/2) - 1
      IB = 1
      IF ((NUM/2)*2 .EQ. NUM) IB = 2
      IE = NEWELM + 1
      DO 60 I = 1,IE
        IB2 = IB + 2
        EPSTAB(IB) = EPSTAB(IB2)
        IB = IB2
   60 CONTINUE
      IF (NUM .EQ. N) GO TO 80
      INDX = NUM - N + 1
      DO 70 I = 1,N
        EPSTAB(I) = EPSTAB(INDX)
        INDX = INDX + 1
   70 CONTINUE
   80 IF (NRES .GE. 4) GO TO 90
      RES3LA(NRES) = RESULT
      ABSERR = OFLOW
      GO TO 100
C
C           COMPUTE ERROR ESTIMATE
C
   90 ABSERR = DABS(RESULT - RES3LA(3)) + DABS(RESULT - RES3LA(2)) +
     *         DABS(RESULT - RES3LA(1))
      RES3LA(1) = RES3LA(2)
      RES3LA(2) = RES3LA(3)
      RES3LA(3) = RESULT
  100 ABSERR = DMAX1(ABSERR,5.D0*EPMACH*DABS(RESULT))
      RETURN
      END
      SUBROUTINE DQXGS (F,A,B,EPSABS,EPSREL,RESULT,ABSERR,IER,
     *                  LIMIT,LENIW,LENW,LAST,IWORK,WORK)
C
C            THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL  I = INTEGRAL OF F OVER (A,B),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            DABS(I-RESULT).LE.MAX(EPSABS,EPSREL*DABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED DABS(I-RESULT)
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF LIMIT
C                             (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT. HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE. IT IS PRESUMED THAT
C                             THE REQUESTED TOLERANCE CANNOT BE
C                             ACHIEVED, AND THAT THE RETURNED RESULT IS
C                             THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS OR
C                             EPSREL IS NEGATIVE, LIMIT .LT. 1,
C                             LENW .LT. 46*LIMIT, OR
C                             LENIW .LT. 3*LIMIT.
C                             RESULT, ABSERR, LAST ARE SET TO
C                             ZERO. EXCEPT WHEN LIMIT OR LENW OR LENIW
C                             IS INVALID, IWORK(1), WORK(LIMIT*2+1) AND
C                             WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1)
C                             IS SET TO A, AND WORK(LIMIT+1) TO B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS
C                    IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL
C                    (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*46.
C                    IF LENW.LT.LIMIT*46, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LENIW - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LENIW MUST BE AT LEAST LIMIT*3.
C                    IF LENW.LT.LIMIT*3, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS
C                    PRODUCED IN THE SUBDIVISION PROCESS, WHICH DETER-
C                    MINES THE NUMBER OF SIGNIFICANT ELEMENTS ACTUALLY
C                    IN THE WORK ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST 3*LIMIT, THE FIRST K
C                    ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2),
C                    AND K = LIMIT+1-LAST OTHERWISE.
C
C            WORK  - DOUBLE PRECISION
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END-POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END-POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN
C                     THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE ERROR ESTIMATES.
C                    WORK(LIMIT*4+1), ... IS THE AREA RESERVED TO STORE
C                     FUNCTIONAL VALUES.
C
      DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,L1,L2,L3,L4,L5
C
      DIMENSION IWORK(LENIW),WORK(LENW)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT,LENIW AND LENW.
C
      IER = 6
      LAST = 0
      RESULT = 0.D0
      ABSERR = 0.D0
      IF (LIMIT.LT.1 .OR. LENIW.LT.LIMIT*3 .OR. LENW.LT.LIMIT*46)
     *    RETURN
C
C         PREPARE CALL FOR DQXGSE.
C
      L1 = LIMIT + 1
      L2 = LIMIT + L1
      L3 = LIMIT + L2
      L4 = LIMIT + L3
      L5 = 21*LIMIT + L4
C
      CALL DQXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *  IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST,
     *  WORK(L4),WORK(L5),IWORK(L1),IWORK(L2))
C
      RETURN
      END
      SUBROUTINE DQXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *   IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST,VALP,VALN,LP,LN)
C
C            THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A
C            DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            DABS(I-RESULT).LE.MAX(EPSABS,EPSREL*DABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPERBOUND ON THE NUMBER OF SUBINTERVALS
C                     IN THE PARTITION OF (A,B)
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED DABS(I-RESULT)
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                         = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF LIMIT
C                             (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS PRESUMED THAT THE REQUESTED
C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT THE
C                             RETURNED RESULT IS THE BEST WHICH CAN BE
C                             OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID BECAUSE EPSABS OR
C                             EPSREL IS NEGATIVE. RESULT, ABSERR,
C                             LAST, RLIST(1), IORD(1), AND ELIST(1)
C                             ARE SET TO ZERO. ALIST(1) AND BLIST(1)
C                             ARE SET TO A AND B RESPECTIVELY.
C
C            ALIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE
C                     GIVEN INTEGRATION RANGE (A,B)
C
C            BLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                     INTEGRATION RANGE (A,B)
C
C            RLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI OF THE
C                     ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE
C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE
C                     SUBDIVISION PROCESS
C
C            VALP   - DOUBLE PRECISION
C            VALN     ARRAYS OF DIMENSION AT LEAST (21,LIMIT) USED TO
C                     SAVE THE FUNCTIONAL VALUES
C
C            LP     - INTEGER
C            LN       VECTORS OF DIMENSION AT LEAST LIMIT, USED TO
C                     STORE THE ACTUAL NUMBER OF FUNCTIONAL VALUES
C                     SAVED IN THE CORRESPONDING COLUMN
C                     OF VALP,VALN
C
C***ROUTINES CALLED  F,DPMPAR,DQELG,DQXLQM,DQPSRT,DQXRRD,DQXCPY
C
      DOUBLE PRECISION
     *  A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,
     *  B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES,ELIST,
     *  EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX,
     *  ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS,
     *  RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,T,UFLOW,
     *  VALP,VALN,VP1,VP2,VN1,VN2,DPMPAR
      INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
     *  KTMIN,LAST,LIMIT,MAXERR,NRES,NRMAX,NUMRL2,
     *  LP,LN,LP1,LP2,LN1,LN2
      LOGICAL EXTRAP,NOEXT
C
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     * RES3LA(3),RLIST(LIMIT),RLIST2(52),
     * VALP(21,LIMIT),VALN(21,LIMIT),LP(LIMIT),LN(LIMIT),
     * VP1(21),VP2(21),VN1(21),VN2(21)
C
      EXTERNAL F
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C          EPMACH IS THE LARGEST RELATIVE SPACING.
C          UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C          OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
      EPMACH = DPMPAR(1)
      UFLOW = DPMPAR(2)
      OFLOW = DPMPAR(3)
C
C            TEST ON VALIDITY OF PARAMETERS
C            ------------------------------
      LAST = 0
      RESULT = 0.D0
      ABSERR = 0.D0
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.D0
      ELIST(1) = 0.D0
      IER = 6
      IF (EPSABS .LT. 0.D0 .OR. EPSREL.LT. 0.D0) GO TO 999
      IER = 0
      RERR = DMAX1(EPSREL, 50.D0*EPMACH)
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
      IERRO = 0
      LP(1) = 1
      LN(1) = 1
      VALP(1,1) = F((A + B)*0.5D0)
      VALN(1,1) = VALP(1,1)
      CALL DQXLQM (F,A,B,RESULT,ABSERR,DEFABS,RESABS,
     *             VALP(1,1),VALN(1,1),LP(1),LN(1),2,
     *             EPMACH,UFLOW,OFLOW)
C
C           TEST ON ACCURACY.
C
      DRES = DABS(RESULT)
      ERRBND = DMAX1(EPSABS,RERR*DRES)
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      IF (ABSERR .LE. 100.D0*EPMACH*DEFABS .AND. ABSERR .GT.
     *    ERRBND) IER = 2
      IF (LIMIT .EQ. 1) IER = 1
      IF (IER .NE. 0 .OR. (ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS) .OR.
     *    ABSERR .EQ. 0.D0) GO TO 999
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      NRMAX = 1
      NRES = 0
      NUMRL2 = 2
      KTMIN = 0
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF (DRES .GE. (1.D0 - 50.D0*EPMACH)*DEFABS) KSGN = 1
      T = 1.D0 + 100.D0*EPMACH
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR
C           ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5D0*(ALIST(MAXERR) + BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL DQXRRD(F,VALN(1,MAXERR),LN(MAXERR),B1,A1,VN1,VP1,LN1,LP1)
        CALL DQXLQM(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1,VP1,VN1,LP1,LN1,
     *              2,EPMACH,UFLOW,OFLOW)
        CALL DQXRRD(F,VALP(1,MAXERR),LP(MAXERR),A2,B2,VP2,VN2,LP2,LN2)
        CALL DQXLQM(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2,VP2,VN2,LP2,LN2,
     *              2,EPMACH,UFLOW,OFLOW)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1 + AREA2
        ERRO12 = ERROR1 + ERROR2
        ERRSUM = ERRSUM + ERRO12 - ERRMAX
        AREA = AREA + AREA12 - RLIST(MAXERR)
        IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15
        IF (DABS(RLIST(MAXERR) - AREA12) .GT. 0.1D-04*DABS(AREA12)
     *     .OR. ERRO12 .LT. 0.99D0*ERRMAX) GO TO 10
        IF (EXTRAP) IROFF2 = IROFF2 + 1
        IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1
   10   IF (LAST.GT.10 .AND. ERRO12.GT.ERRMAX) IROFF3 = IROFF3 + 1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = DMAX1(EPSABS,RERR*DABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
C
        IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2
        IF (IROFF2 .GE. 5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS
C           EQUALS LIMIT.
C
        IF (LAST .EQ. LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE.
C
        IF (DMAX1(DABS(A1),DABS(B2)) .LE.
     *      T*(DABS(A2) + 1.D+03*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF (ERROR2 .GT. ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        CALL DQXCPY(VALP(1,MAXERR),VP1,LP1)
        LP(MAXERR) = LP1
        CALL DQXCPY(VALN(1,MAXERR),VN1,LN1)
        LN(MAXERR) = LN1
        CALL DQXCPY(VALP(1,LAST),VP2,LP2)
        LP(LAST) = LP2
        CALL DQXCPY(VALN(1,LAST),VN2,LN2)
        LN(LAST) = LN2
        GO TO 30
C
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
        CALL DQXCPY(VALP(1,MAXERR),VP2,LP2)
        LP(MAXERR) = LP2
        CALL DQXCPY(VALN(1,MAXERR),VN2,LN2)
        LN(MAXERR) = LN2
        CALL DQXCPY(VALP(1,LAST),VP1,LP1)
        LP(LAST) = LP1
        CALL DQXCPY(VALN(1,LAST),VN1,LN1)
        LN(LAST) = LN1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
   30   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF(ERRSUM .LE. ERRBND) GO TO 115
C ***JUMP OUT OF DO-LOOP
        IF (IER .NE. 0) GO TO 100
        IF (LAST .EQ. 2) GO TO 80
        IF (NOEXT) GO TO 90
        ERLARG = ERLARG - ERLAST
        IF (DABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12
        IF (EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
C
C           THE BOUND 0.3*ERTEST HAS BEEN INTRODUCED TO PERFORM A
C           MORE CAUTIOUS EXTRAPOLATION THAN IN THE ORIGINAL DQAGSE
C           ROUTINE
C
   40   IF (IERRO .EQ. 3 .OR. ERLARG .LE. 0.3D0*ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE
C           LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
C ***JUMP OUT OF DO-LOOP
          IF(DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90
          NRMAX = NRMAX + 1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2 + 1
        RLIST2(NUMRL2) = AREA
        CALL DQELG (NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES,
     *              EPMACH,OFLOW)
        KTMIN = KTMIN + 1
        IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1D-02*ERRSUM) IER = 5
        IF (ABSEPS .GE. ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = DMAX1(EPSABS,RERR*DABS(RESEPS))
C ***JUMP OUT OF DO-LOOP
        IF (ABSERR .LE. ERTEST) GO TO 100
C
C           PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF (NUMRL2 .EQ. 1) NOEXT = .TRUE.
        IF (IER .EQ. 5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5D0
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = DABS(B - A)*0.375D0
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF (ABSERR .EQ. OFLOW) GO TO 115
      IF (IER + IERRO .EQ. 0) GO TO 110
      IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC
      IF (IER .EQ. 0) IER = 3
      IF (RESULT .NE. 0.D0 .AND. AREA .NE. 0.D0) GO TO 105
      IF (ABSERR .GT. ERRSUM) GO TO 115
      IF (AREA .EQ. 0.D0) GO TO 130
      GO TO 110
  105 IF (ABSERR/DABS(RESULT) .GT. ERRSUM/DABS(AREA)) GO TO 115
C
C           TEST ON DIVERGENCE.
C
  110 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE.
     * DEFABS*0.1D-01) GO TO 130
      IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03
     * .OR.ERRSUM.GT.DABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.D0
      DO 120 K = 1,LAST
         RESULT = RESULT + RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 IF (IER .GT. 2) IER = IER - 1
  999 RETURN
      END
      SUBROUTINE DQXCPY (A, B, L)
C
C  TO COPY THE DOUBLE PRECISION VECTOR B OF LENGTH L   I N T O
C          THE DOUBLE PRECISION VECTOR A OF LENGTH L
C
      INTEGER L
      DOUBLE PRECISION A(L),B(L)
C
      DO 10 I = 1,L
   10    A(I) = B(I)
      RETURN
      END
      SUBROUTINE DQXLQM (F,A,B,RESULT,ABSERR,RESABS,RESASC,VR,VS,LR,LS,
     *                   KEY,EPMACH,UFLOW,OFLOW)
C
C            TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
C                           ESTIMATE
C                       J = INTEGRAL OF DABS(F) OVER (A,B)
C
C           PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              A      - DOUBLE PRECISION
C                       LOWER LIMIT OF INTEGRATION
C
C              B      - DOUBLE PRECISION
C                       UPPER LIMIT OF INTEGRATION
C
C              VR     - DOUBLE PRECISION
C                       VECTOR OF LENGTH LR CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              VS     - DOUBLE PRECISION
C                       VECTOR OF LENGTH LS CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              LR     - INTEGER
C              LS       NUMBER OF ELEMENTS IN
C                       VR,VS RESPECTIVELY
C
C            KEY    - INTEGER
C                     KEY FOR CHOICE OF LOCAL INTEGRATION RULE
C                     RMS FORMULAS ARE USED WITH
C                      13 - 19               POINTS IF KEY.LT.1,
C                      13 - 19 - (27)        POINTS IF KEY = 1,
C                      13 - 19 - (27) - (41) POINTS IF KEY = 2,
C                           19 -  27  - (41) POINTS IF KEY = 3,
C                                 27  -  41  POINTS IF KEY.GT.3.
C
C                         (RULES) USED IF THE FUNCTION APPEARS
C                         ENOUGH REGULAR
C
C              EPMACH - DOUBLE PRECISION
C                       THE RELATIVE PRECISION OF THE FLOATING
C                       ARITHMETIC BEING USED.
C
C              UFLOW  - DOUBLE PRECISION
C                       THE SMALLEST POSITIVE MAGNITUDE.
C
C              OFLOW  - DOUBLE PRECISION
C                       THE LARGEST POSITIVE MAGNITUDE.
C
C            ON RETURN
C              RESULT - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL I
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD NOT EXCEED DABS(I-RESULT)
C
C              RESABS - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL OF DABS(F-I/(B-A))
C                       OVER (A,B)
C
C              VR     - DOUBLE PRECISION
C                       VECTOR OF LENGTH LR CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              VS     - DOUBLE PRECISION
C                       VECTOR OF LENGTH LS CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              LR     - INTEGER
C              LS       NUMBER OF ELEMENTS IN
C                       VR,VS RESPECTIVELY
C
C***ROUTINES CALLED  DQXRUL
C
      DOUBLE PRECISION F,A,B,RESULT,ABSERR,RESABS,RESASC, T,
     *     EPMACH,OFLOW,UFLOW,RESG,RESK,ERROLD,VR(21),VS(21)
      INTEGER K,K0,K1,K2,KEY,KEY1,LR,LS
      EXTERNAL F
C
      KEY1 = MAX0(KEY ,  0)
      KEY1 = MIN0(KEY1,  4)
      K0   = MAX0(KEY1-2,0)
      K1   = K0 + 1
      K2   = MIN0(KEY1+1,3)
C
      CALL DQXRUL (F,A,B,RESG,RESABS,RESASC,K0,K1,VR,VS,LR,LS)
      ERROLD = OFLOW
      T = 10.D0*EPMACH
      DO 10 K = K1,K2
        CALL DQXRUL (F,A,B,RESK,RESABS,RESASC,K,K1,VR,VS,LR,LS)
        RESULT = RESK
        ABSERR = DABS(RESK - RESG)
        IF (RESASC .NE. 0.D0 .AND. ABSERR .NE. 0.D0)
     *      ABSERR = RESASC*DMIN1(1.D0,(200.D0*ABSERR/RESASC)**1.5D0)
        IF (RESABS .GT. UFLOW/T) ABSERR = DMAX1(T*RESABS,ABSERR)
        RESG = RESK
        IF (ABSERR .GT. ERROLD*0.16D0) GO TO 3000
        IF (ABSERR .LT. 1000.D0*EPMACH*RESABS) GO TO 3000
        ERROLD = ABSERR
   10 CONTINUE
 3000 CONTINUE
      RETURN
      END
      SUBROUTINE DQXRUL (F,XL,XU,Y,YA,YM,KE,K1,FV1,FV2,L1,L2)
C
C            TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
C                           ESTIMATE
C            AND CONDITIONALLY COMPUTE
C                       J = INTEGRAL OF DABS(F) OVER (A,B)
C                       BY USING AN  RMS RULE
C           PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              XL     - DOUBLE PRECISION
C                       LOWER LIMIT OF INTEGRATION
C
C              XU     - DOUBLE PRECISION
C                       UPPER LIMIT OF INTEGRATION
C
C              KE     - INTEGER
C                     KEY FOR CHOICE OF LOCAL INTEGRATION RULE
C                     AN RMS RULE IS USED WITH
C                         13      POINTS IF KE  = 2,
C                         19      POINTS IF KE  = 3,
C                         27      POINTS IF KE  = 4,
C                         42      POINTS IF KE  = 5
C
C              K1     INTEGER
C                     VALUE OF KEY FOR WHICH THE ADDITIONAL ESTIMATES
C                     YA, YM ARE TO BE COMPUTED
C
C              FV1    - DOUBLE PRECISION
C                       VECTOR CONTAINING L1
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              FV2    - DOUBLE PRECISION
C                       VECTOR CONTAINING L2
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              L1     - INTEGER
C              L2       NUMBER OF ELEMENTS IN FV1,FV2  RESPECTIVELY
C
C            ON RETURN
C              Y      - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE
C                       REQUESTED RMS RULE
C
C              YA     - DOUBLE PRECISION
C                       IF KEY = K1  APPROXIMATION TO THE INTEGRAL J
C                       ELSE UNCHANGED
C
C              YM     - DOUBLE PRECISION
C                       IF KEY = K1  APPROXIMATION TO THE INTEGRAL OF
C                                      DABS(F-I/(XU-XL)   OVER (XL,XU)
C                       ELSE UNCHANGED
C
C              FV1    - DOUBLE PRECISION
C                       VECTOR CONTAINING L1
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              FV2    - DOUBLE PRECISION
C                       VECTOR CONTAINING L2
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              L1     - INTEGER
C              L2       NUMBER OF ELEMENTS IN FV1,FV2  RESPECTIVELY
C
C------------------------
      DOUBLE PRECISION F,XL,XU,LDL,Y,YA,YM,Y2,XX(41),WW(52),
     *                 FV1(21),FV2(21),AA,BB,C
      INTEGER ISTART(4),LEN(4),J,KE,K1,L1,L2
      EXTERNAL F
C------------------------
      DATA ISTART(1)/0/, ISTART(2)/7/, ISTART(3)/17/, ISTART(4)/31/
      DATA LEN(1)/7/, LEN(2)/10/, LEN(3)/14/, LEN(4)/21/
C------------------------
      DATA XX( 1)/0.D0                     /
      DATA XX( 2)/.25000000000000000000D+00/
      DATA XX( 3)/.50000000000000000000D+00/
      DATA XX( 4)/.75000000000000000000D+00/
      DATA XX( 5)/.87500000000000000000D+00/
      DATA XX( 6)/.93750000000000000000D+00/
      DATA XX( 7)/.10000000000000000000D+01/
      DATA XX( 8)/.37500000000000000000D+00/
      DATA XX( 9)/.62500000000000000000D+00/
      DATA XX(10)/.96875000000000000000D+00/
      DATA XX(11)/.12500000000000000000D+00/
      DATA XX(12)/.68750000000000000000D+00/
      DATA XX(13)/.81250000000000000000D+00/
      DATA XX(14)/.98437500000000000000D+00/
      DATA XX(15)/.18750000000000000000D+00/
      DATA XX(16)/.31250000000000000000D+00/
      DATA XX(17)/.43750000000000000000D+00/
      DATA XX(18)/.56250000000000000000D+00/
      DATA XX(19)/.84375000000000000000D+00/
      DATA XX(20)/.90625000000000000000D+00/
      DATA XX(21)/.99218750000000000000D+00/
C   NUMBER OF NODES 13
      DATA WW(1)/1.303262173284849021810473057638590518409112513421D-1/
      DATA WW(2)/2.390632866847646220320329836544615917290026806242D-1/
      DATA WW(3)/2.630626354774670227333506083741355715758124943143D-1/
      DATA WW(4)/2.186819313830574175167853094864355208948886875898D-1/
      DATA WW(5)/2.757897646642836865859601197607471574336674206700D-2/
      DATA WW(6)/1.055750100538458443365034879086669791305550493830D-1/
      DATA WW(7)/1.571194260595182254168429283636656908546309467968D-2/
C   NUMBER OF NODES 19
      DATA WW(8)/1.298751627936015783241173611320651866834051160074D-1/
      DATA WW(9)/2.249996826462523640447834514709508786970828213187D-1/
      DATA WW(15)/5.542699233295875168406783695143646338274805359780D-2/
      DATA WW(10)/1.680415725925575286319046726692683040162290325505D-1/
      DATA WW(16)/9.986735247403367525720377847755415293097913496236D-2/
      DATA WW(11)/1.415567675701225879892811622832845252125600939627D-1/
      DATA WW(12)/1.006482260551160175038684459742336605269707889822D-1/
      DATA WW(13)/2.510604860724282479058338820428989444699235030871D-2/
      DATA WW(17)/4.507523056810492466415880450799432587809828791196D-2/
      DATA WW(14)/9.402964360009747110031098328922608224934320397592D-3/
C   NUMBER OF NODES 27
      DATA WW(18)/6.300942249647773931746170540321811473310938661469D-2/
      DATA WW(28)/1.239572396231834242194189674243818619042280816640D-1/
      DATA WW(19)/1.261383225537664703012999637242003647020326905948D-1/
      DATA WW(25)/1.235837891364555000245004813294817451524633100256D-1/
      DATA WW(20)/1.273864433581028272878709981850307363453523117880D-1/
      DATA WW(26)/1.148933497158144016800199601785309838604146040215D-1/
      DATA WW(29)/2.501306413750310579525950767549691151739047969345D-2/
      DATA WW(21)/8.576500414311820514214087864326799153427368592787D-2/
      DATA WW(30)/4.915957918146130094258849161350510503556792927578D-2/
      DATA WW(22)/7.102884842310253397447305465997026228407227220665D-2/
      DATA WW(23)/5.026383572857942403759829860675892897279675661654D-2/
      DATA WW(27)/1.252575774226122633391477702593585307254527198070D-2/
      DATA WW(31)/2.259167374956474713302030584548274729936249753832D-2/
      DATA WW(24)/4.683670010609093810432609684738393586390722052124D-3/
C   NUMBER OF NODES 41
      DATA WW(32)/6.362762978782724559269342300509058175967124446839D-2/
      DATA WW(42)/1.187141856692283347609436153545356484256869129472D-1/
      DATA WW(46)/1.533126874056586959338368742803997744815413565014D-2/
      DATA WW(33)/9.950065827346794643193261975720606296171462239514D-2/
      DATA WW(47)/3.527159369750123100455704702965541866345781113903D-2/
      DATA WW(39)/8.140326425945938045967829319725797511040878579808D-2/
      DATA WW(48)/5.000556431653955124212795201196389006184693561679D-2/
      DATA WW(34)/7.048220002718565366098742295389607994441704889441D-2/
      DATA WW(49)/5.744164831179720106340717579281831675999717767532D-2/
      DATA WW(40)/6.583213447600552906273539578430361199084485578379D-2/
      DATA WW(43)/5.999947605385971985589674757013565610751028128731D-2/
      DATA WW(35)/6.512297339398335645872697307762912795346716454337D-2/
      DATA WW(44)/5.500937980198041736910257988346101839062581489820D-2/
      DATA WW(50)/1.598823797283813438301248206397233634639162043386D-2/
      DATA WW(36)/3.998229150313659724790527138690215186863915308702D-2/
      DATA WW(51)/2.635660410220884993472478832884065450876913559421D-2/
      DATA WW(37)/3.456512257080287509832054272964315588028252136044D-2/
      DATA WW(41)/2.592913726450792546064232192976262988065252032902D-2/
      DATA WW(45)/5.264422421764655969760271538981443718440340270116D-3/
      DATA WW(52)/1.196003937945541091670106760660561117114584656319D-2/
      DATA WW(38)/2.212167975884114432760321569298651047876071264944D-3/
C------------------------
      K = KE + 1
      IS = ISTART(K)
      KS = LEN(K)
      LDL = XU - XL
      BB = LDL*0.5D0
      AA = XL + BB
C
      Y = 0.D0
      DO 10 I = 1,KS
         C = BB*XX(I)
         IF (I .GT. L1) FV1(I) = F(AA + C)
         IF (I .GT. L2) FV2(I) = F(AA - C)
         J = IS + I
         Y = Y + (FV1(I) + FV2(I))*WW(J)
   10 CONTINUE
C
      Y2 = Y
      Y = Y*BB
      IF (L1 .LT. KS) L1 = KS
      IF (L2 .LT. KS) L2 = KS
      IF (KE .NE. K1) RETURN
C
      YA = 0.D0
      DO 20 I = 1,KS
         J = IS + I
         YA = YA + (DABS(FV1(I)) + DABS(FV2(I)))*WW(J)
   20 CONTINUE
      YA = YA*DABS(BB)
C
      Y2 = Y2*0.5D0
      YM = 0.D0
      DO 30 I = 1,KS
         J = IS + I
         YM = YM + (DABS(FV1(I) - Y2) + DABS(FV2(I) - Y2))*WW(J)
   30 CONTINUE
      YM = YM*DABS(BB)
      RETURN
      END
      SUBROUTINE DQXRRD (F,Z,LZ,XL,XU,R,S,LR,LS)
C
C            TO REORDER THE COMPUTED FUNCTIONAL VALUES BEFORE
C            THE BISECTION OF AN INTERVAL
C
C           PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              XL     - DOUBLE PRECISION
C                       LOWER LIMIT OF INTERVAL
C
C              XU     - DOUBLE PRECISION
C                       UPPER LIMIT OF INTERVAL
C
C              Z      - DOUBLE PRECISION
C                       VECTOR CONTAINING LZ
C                       SAVED  FUNCTIONAL VALUES
C
C              LZ     - INTEGER
C                       NUMBER OF ELEMENTS IN LZ
C
C            ON RETURN
C              R      - DOUBLE PRECISION
C              S        VECTORS CONTAINING LR, LS
C                       SAVED  FUNCTIONAL VALUES FOR THE NEW INTERVALS
C
C              LR     - INTEGER
C              LS       NUMBER OF ELEMENTES IN R,S RESPECTIVELY
C
C***ROUTINES CALLED  F
C
      DOUBLE PRECISION F,R,S,Z,XU,XL,DLEN,CENTR
      INTEGER LR,LS,LZ
      DIMENSION R(21),S(21),Z(21)
C
      DLEN = (XU - XL)*0.5D0
      CENTR = XL + DLEN
      R(1) =  Z(3)
      R(2) =  Z(9)
      R(3) =  Z(4)
      R(4) =  Z(5)
      R(5) =  Z(6)
      R(6) =  Z(10)
      R(7) =  Z(7)
      S(1) =  Z(3)
      S(2) =  Z(8)
      S(3) =  Z(2)
      S(7) =  Z(1)
      IF (LZ .GT. 11) GO TO 10
C
      R(8) =  F(CENTR + DLEN*0.375D0)
      R(9) =  F(CENTR + DLEN*0.625D0)
      R(10) = F(CENTR + DLEN*0.96875D0)
      LR = 10
      IF (LZ .NE. 11) S(4) = F(CENTR - DLEN*0.75D0)
      IF (LZ .EQ. 11) S(4) = Z(11)
      S(5) =  F(CENTR - DLEN*0.875D0)
      S(6) =  F(CENTR - DLEN*0.9375D0)
      S(8) =  F(CENTR - DLEN*0.375D0)
      S(9) =  F(CENTR - DLEN*0.625D0)
      S(10) = F(CENTR - DLEN*0.96875D0)
      LS = 10
      RETURN
C
   10 R(8) = Z(12)
      R(9) = Z(13)
      R(10) = Z(14)
      LR = 10
      S(4) = Z(11)
      S(5) = F(CENTR - DLEN*0.875D0)
      S(6) = F(CENTR - DLEN*0.9375D0)
      IF (LZ .GT. 14) GO TO 20
      S(8)  = F(CENTR - DLEN*0.375D0)
      S(9)  = F(CENTR - DLEN*0.625D0)
      S(10) = F(CENTR - DLEN*0.96875D0)
      LS = 10
      RETURN
C
   20 R(11) = Z(18)
      R(12) = Z(19)
      R(13) = Z(20)
      R(14) = Z(21)
      LR = 14
      S(8) = Z(16)
      S(9) = Z(15)
      S(10) = F(CENTR - DLEN*0.96875D0)
      S(11) = Z(17)
      LS = 11
      RETURN
      END
      SUBROUTINE CUBTRI(F, T, EPS, MCALLS, ANS, ERR, NCALLS, W, NW,
     * IDATA, RDATA, IER)
C
C       ADAPTIVE CUBATURE OVER A TRIANGLE
C
C       PARAMETERS
C          F     - USER SUPPLIED EXTERNAL FUNCTION OF THE FORM
C                  F(X,Y,IDATA,RDATA)
C                  WHERE X AND Y ARE THE CARTESIAN COORDINATES OF A
C                  POINT IN THE PLANE, AND IDATA AND RDATA ARE INTEGER
C                  AND REAL VECTORS IN WHICH DATA MAY BE PASSED.
C          T     - ARRAY OF DIMENSION (2,3) WHERE T(1,J) AND T(2,J)
C                  ARE THE X AND Y COORDINATES OF THE J-TH VERTEX OF
C                  THE GIVEN TRIANGLE (INPUT)
C          EPS   - REQUIRED TOLERANCE (INPUT).  IF THE COMPUTED
C                  INTEGRAL IS BETWEEN-1 AND 1, AN ABSOLUTE ERROR
C                  TEST IS USED, ELSE A RELATIVE ERROR TEST IS USED.
C          MCALLS- MAXIMUM PERMITTED NUMBER OF CALLS TO F (INPUT)
C          ANS   - ESTIMATE FOR THE VALUE OF THE INTEGRAL OF F OVER
C                  THE GIVEN TRIANGLE (OUTPUT)
C          ERR   - ESTIMATED ABSOLUTE ERROR IN ANS (OUTPUT)
C          NCALLS- ACTUAL NUMBER OF CALLS TO F (OUTPUT).  THIS
C                  PARAMETER MUST BE INITIALIZED TO 0 ON THE FIRST
C                  CALL TO CUBTRI FOR A GIVEN INTEGRAL (INPUT)
C          W     - WORK SPACE.  MAY NOT BE DESTROYED BETWEEN CALLS TO
C                  CUBTRI IF RESTARTING IS INTENDED
C          NW    - LENGTH OF WORK SPACE (INPUT).
C                  IF NW .GE. 3*(19+3*MCALLS)/38, TERMINATION DUE TO
C                  FULL WORK SPACE WILL NOT OCCUR.
C          IER   - TERMINATION INDICATOR (OUTPUT)
C                  IER=0   NORMAL TERMINATION, TOLERANCE SATISFIED
C                  IER=1   MAXIMUM NUMBER OF CALLS REACHED
C                  IER=2   WORK SPACE FULL
C                  IER=3   FURTHER SUBDIVISION OF TRIANGLES IMPOSSIBLE
C                  IER=4   NO FURTHER IMPROVEMENT IN ACCURACY IS
C                        POSSIBLE DUE TO ROUNDING ERRORS IN FUNCTION
C                        VALUES
C                  IER=5   NO FURTHER IMPROVEMENT IN ACCURACY IS
C                        POSSIBLE BECAUSE SUBDIVISION DOES NOT
C                        CHANGE THE ESTIMATED INTEGRAL. MACHINE
C                        ACCURACY HAS PROBABLY BEEN REACHED BUT
C                        THE ERROR ESTIMATE IS NOT SHARP ENOUGH.
C
C       CUBTRI IS DESIGNED TO BE CALLED REPEATEDLY WITHOUT WASTING
C       EARLIER WORK.  THE PARAMETER NCALLS IS USED TO INDICATE TO
C       CUBTRI AT WHAT POINT TO RESTART, AND MUST BE RE-INITIALIZED
C       TO 0 WHEN A NEW INTEGRAL IS TO BE COMPUTED.  AT LEAST ONE OF
C       THE PARAMETERS EPS, MCALLS AND NW MUST BE CHANGED BETWEEN
C       CALLS TO CUBTRI, ACCORDING TO THE RETURNED VALUE OF IER. NONE
C       OF THE OTHER PARAMETERS MAY BE CHANGED IF RESTARTING IS DONE.
C       IF IER=3 IS ENCOUNTERED, THERE PROBABLY IS A SINGULARITY
C       SOMEWHERE IN THE REGION.  THE ERROR MESSAGE INDICATES THAT
C       FURTHER SUBDIVISION IS IMPOSSIBLE BECAUSE THE VERTICES OF THE
C       SMALLER TRIANGLES PRODUCED WILL BEGIN TO COALESCE TO THE
C       PRECISION OF THE COMPUTER.  THIS SITUATION CAN USUALLY BE
C       RELIEVED BY SPECIFYING THE REGION IN SUCH A WAY THAT THE
C       SINGULARITY IS LOCATED AT THE THIRD VERTEX OF THE TRIANGLE.
C       IF IER=4 IS ENCOUNTERED, THE VALUE OF THE INTEGRAL CANNOT BE
C       IMPROVED ANY FURTHER. THE ONLY EXCEPTION TO THIS OCCURS WHEN A
C       FUNCTION WITH HIGHLY IRREGULAR BEHAVIOUR IS INTEGRATED (E.G.
C       FUNCTIONS WITH JUMP DISCONTINUITIES OR VERY HIGHLY OSCILLATORY
C       FUNCTIONS). IN SUCH A CASE THE USER CAN DISABLE THE ROUNDING
C       ERROR TEST BY REMOVING THE IF STATEMENT IMMEDIATELY PRECEDING
C       STATEMENT NUMBER 90.
C
      EXTERNAL F
      INTEGER IDATA(*), IER, MCALLS, NCALLS, NW
      REAL ALFA, ANS, ANSKP, AREA, EPS, ERR, ERRMAX, H, Q1, Q2, R1, R2,
     * RDATA(*), D(2,4), S(4), T(2,*), VEC(2,3), W(6,NW), X(2)
C       ACTUAL DIMENSION OF W IS (6,NW/6)
C
      DOUBLE PRECISION TANS, TERR, DZERO
      COMMON /CUBSTA/ TANS, TERR
C       THIS COMMON IS REQUIRED TO PRESERVE TANS AND TERR BETWEEN CALLS
C       AND TO SAVE VARIABLES IN FUNCTION RNDERR
      DATA NFE /19/, S(1), S(2), S(3), S(4) /3*1E0,-1E0/, D(1,1),
     * D(2,1) /0.0,0.0/, D(1,2), D(2,2) /0.0,1.0/, D(1,3), D(2,3)
     * /1.0,0.0/, D(1,4), D(2,4) /1.0,1.0/
C       NFE IS THE NUMBER OF FUNCTION EVALUATIONS PER CALL TO CUBRUL.
      DATA ZERO /0.E0/, ONE /1.E0/, DZERO /0.D0/, POINT5 /.5E0/
C
C      CALCULATE DIRECTION VECTORS, AREA AND MAXIMUM NUMBER
C      OF SUBDIVISIONS THAT MAY BE PERFORMED
      DO 20 I=1,2
        VEC(I,3) = T(I,3)
        DO 10 J=1,2
          VEC(I,J) = T(I,J) - T(I,3)
   10   CONTINUE
   20 CONTINUE
      MAXC = (MCALLS/NFE+3)/4
      IER = 1
      MAXK = MIN0(MAXC,(NW/6+2)/3)
      IF (MAXC.GT.MAXK) IER = 2
      AREA = ABS(VEC(1,1)*VEC(2,2)-VEC(1,2)*VEC(2,1))*POINT5
      K = (NCALLS/NFE+3)/4
      MW = 3*(K-1) + 1
      IF (NCALLS.GT.0) GO TO 30
C
C       TEST FOR TRIVIAL CASES
      TANS = DZERO
      TERR = DZERO
      IF (AREA.EQ.ZERO) GO TO 90
      IF (MCALLS.LT.NFE) GO TO 100
      IF (NW.LT.6) GO TO 110
C
C       INITIALIZE DATA LIST
      K = 1
      MW = 1
      W(1,1) = ZERO
      W(2,1) = ZERO
      W(3,1) = ONE
      CALL CUBRUL(F, VEC, W(1,1), IDATA, RDATA)
      TANS = W(5,1)
      TERR = W(6,1)
      NCALLS = NFE
C
C       TEST TERMINATION CRITERIA
   30 ANS = TANS
      ERR = TERR
      IF (ERR.LT.AMAX1(ONE,ABS(ANS))*EPS) GO TO 90
      IF (K.EQ.MAXK) GO TO 120
C
C       FIND TRIANGLE WITH LARGEST ERROR
      ERRMAX = ZERO
      DO 40 I=1,MW
        IF (W(6,I).LE.ERRMAX) GO TO 40
        ERRMAX = W(6,I)
        J = I
   40 CONTINUE
C
C       SUBDIVIDE TRIANGLE INTO FOUR SUBTRIANGLES AND UPDATE DATA LIST
      DO 50 I=1,2
        X(I) = W(I,J)
   50 CONTINUE
      H = W(3,J)*POINT5
      IF (RNDERR(X(1),H,X(1),H).NE.ZERO) GO TO 130
      IF (RNDERR(X(2),H,X(2),H).NE.ZERO) GO TO 130
      ANSKP = SNGL(TANS)
      TANS = TANS - DBLE(W(5,J))
      TERR = TERR - DBLE(W(6,J))
      R1 = W(4,J)
      R2 = W(5,J)
      JKP = J
      Q1 = ZERO
      Q2 = ZERO
      DO 70 I=1,4
        DO 60 L=1,2
          W(L,J) = X(L) + H*D(L,I)
   60   CONTINUE
        W(3,J) = H*S(I)
        CALL CUBRUL(F, VEC, W(1,J), IDATA, RDATA)
        Q2 = Q2 + W(5,J)
        Q1 = Q1 + W(4,J)
        J = MW + I
   70 CONTINUE
      ALFA = 1E15
      IF (Q2.NE.R2) ALFA = ABS((Q1-R1)/(Q2-R2)-ONE)
      J = JKP
      DO 80 I=1,4
        W(6,J) = W(6,J)/ALFA
        TANS = TANS + W(5,J)
        TERR = TERR + W(6,J)
        J = MW + I
   80 CONTINUE
      MW = MW + 3
      NCALLS = NCALLS + 4*NFE
      K = K + 1
C
C       IF ANSWER IS UNCHANGED, IT CANNOT BE IMPROVED
      IF (ANSKP.EQ.SNGL(TANS)) GO TO 150
C
C       REMOVE THIS IF STATEMENT TO DISABLE ROUNDING ERROR TEST
      IF (K.GT.3 .AND. ABS(Q2-R2).GT.ABS(Q1-R1)) GO TO 140
      GO TO 30
C
C       EXITS FROM SUBROUTINE
   90 IER = 0
      GO TO 120
  100 IER = 1
      GO TO 120
  110 IER = 2
  120 ANS = TANS
      ERR = TERR
      RETURN
  130 IER = 3
      GO TO 120
  140 IER = 4
      GO TO 120
  150 IER = 5
      GO TO 120
      END
      FUNCTION RNDERR(X, A, Y, B)
C       THIS FUNCTION COMPUTES THE ROUNDING ERROR COMMITTED WHEN THE
C       SUM X+A IS FORMED.  IN THE CALLING PROGRAM, Y MUST BE THE SAME
C       AS X AND B MUST BE THE SAME AS A.  THEY ARE DECLARED AS
C       DISTINCT VARIABLES IN THIS FUNCTION, AND THE INTERMEDIATE
C       VARIABLES S AND T ARE PUT INTO COMMON, IN ORDER TO DEFEND
C       AGAINST THE WELL-MEANING ACTIONS OF SOME OFFICIOUS OPTIMIZING
C       FORTRAN COMPILERS.
      COMMON /CUBATB/ S, T
      S = X + A
      T = S - Y
      RNDERR = T - B
      RETURN
      END
      SUBROUTINE CUBRUL(F, VEC, P, IDATA, RDATA)
C
C       BASIC CUBATURE RULE PAIR OVER A TRIANGLE
C
C       PARAMETERS
C         F  - EXTERNAL FUNCTION - SEE COMMENTS TO CUBTRI
C         VEC- MATRIX OF BASE VECTORS AND ORIGIN (INPUT)
C         P  - TRIANGLE DESCRIPTION VECTOR OF DIMENSION 6
C               P(1) - TRANSFORMED X COORDINATE OF ORIGIN VERTEX(INPUT)
C               P(2) - TRANSFORMED Y COORDINATE OF ORIGIN VERTEX(INPUT)
C               P(3) - DISTANCE OF OTHER VERTICES IN THE DIRECTIONS
C                     OF THE BASE VECTORS (INPUT)
C               P(4) - LESS ACCURATE ESTIMATED INTEGRAL (OUTPUT)
C               P(5) - MORE ACCURATE ESTIMATED INTEGRAL (OUTPUT)
C               P(6) - ABS(P(5)-P(4))   (OUTPUT)
C
C       CUBRUL EVALUATES A LINEAR COMBINATION OF BASIC INTEGRATION
C       RULES HAVING D3 SYMMETRY.  THE AREAL COORDINATES PERTAINING TO
C       THE J-TH RULE ARE STORED IN W(I,J),I=1,2,3.  THE CORRESPONDING
C       WEIGHTS ARE W(4,J) AND W(5,J), WITH W(5,J) BELONGING TO THE
C       MORE ACCURATE FORMULA.  IF W(1,J).EQ.W(2,J), THE INTEGRATION
C       POINT IS THE CENTROID, ELSE IF W(2,J).EQ.W(3,J), THE EVALUATION
C       POINTS ARE ON THE MEDIANS.  IN BOTH CASES ADVANTAGE IS TAKEN OF
C       SYMMETRY TO AVOID REPEATING FUNCTION EVALUATIONS.
C
C       THE FOLLOWING DOUBLE PRECISION VARIABLES ARE USED TO AVOID
C       UNNECESSARY ROUNDING ERRORS IN FLOATING POINT ADDITION.
C       THEY MAY BE DECLARED SINGLE PRECISION IF DOUBLE PRECISION IS
C       NOT AVAILABLE AND FULL ACCURACY IS NOT NEEDED.
C
      DOUBLE PRECISION A1, A2, S, SN, DZERO, DONE, DTHREE, DSIX
      REAL AREA, ORIGIN(2), P(*), RDATA(*), TVEC(2,3), VEC(2,*), W(5,6)
      INTEGER IDATA(*)
      EXTERNAL F
C
C       W CONTAINS POINTS AND WEIGHTS OF THE INTEGRATION FORMULAE
C       NQUAD - NUMBER OF BASIC RULES USED
C
C       THIS PARTICULAR RULE IS THE 19 POINT EXTENSION (DEGREE 8) OF
C       THE FAMILIAR 7 POINT RULE (DEGREE 5).
C
C     SIGMA=SQRT(7)
C     PHI=SQRT(15)
C     W(1,1),W(2,1),W(3,1) = 1/3
C     W(4,1) = 9/40
C     W(5,1) = 7137/62720 - 45*SIGMA/1568
C     W(1,2) = 3/7 + 2*PHI/21
C     W(2,2),W(3,2) = 2/7 - PHI/21
C     W(4,2) = 31/80 - PHI/400
C     W(5,2) = - 9301697/4695040 - 13517313*PHI/23475200
C            + 764885*SIGMA/939008 + 198763*PHI*SIGMA/939008
C     W(*,3) = W(*,2) WITH PHI REPLACED BY -PHI
C     W(1,5) = 4/9 + PHI/9 + SIGMA/9 - SIGMA*PHI/45
C     W(2,5),W(3,5) = 5/18 - PHI/18 - SIGMA/18 + SIGMA*PHI/90
C     W(4,5) = 0
C     W(5,5) = 102791225/59157504 + 23876225*PHI/59157504
C            - 34500875*SIGMA/59157504 - 9914825*PHI*SIGMA/59157504
C     W(*,4) = W(*,5) WITH PHI REPLACED BY -PHI
C     W(1,6) = 4/9 + SIGMA/9
C     W(2,6) = W(2,4)
C     W(3,6) = W(2,5)
C     W(4,6) = 0
C     W(5,6) = 11075/8064 - 125*SIGMA/288
C
      DATA NQUAD /6/
      DATA W(1,1), W(2,1), W(3,1) /3*.3333333333333333333333333E0/,
     * W(4,1), W(5,1) /.225E0,.3786109120031468330830822E-1/,
     * W(1,2), W(2,2), W(3,2) /.7974269853530873223980253E0,2*
     * .1012865073234563388009874E0/, W(4,2), W(5,2)
     * /.3778175416344814577870518E0,.1128612762395489164329420E0/,
     * W(1,3), W(2,3), W(3,3) /.5971587178976982045911758E-1,2*
     * .4701420641051150897704412E0/, W(4,3), W(5,3)
     * /.3971824583655185422129482E0,.2350720567323520126663380E0/
      DATA W(1,4), W(2,4), W(3,4) /.5357953464498992646629509E0,2*
     * .2321023267750503676685246E0/, W(4,4), W(5,4)
     * /0.E0,.3488144389708976891842461E0/, W(1,5), W(2,5), W(3,5)
     * /.9410382782311208665596304E0,2*.2948086088443956672018481E-1/,
     * W(4,5), W(5,5) /0.E0,.4033280212549620569433320E-1/, W(1,6),
     * W(2,6), W(3,6) /.7384168123405100656112906E0,
     * .2321023267750503676685246E0,.2948086088443956672018481E-1/,
     * W(4,6), W(5,6) /0.E0,.2250583347313904927138324E0/
C
      DATA DZERO /0.D0/, DONE /1.D0/, DTHREE /3.D0/, DSIX /6.D0/,
     * POINT5 /.5E0/
C
C       SCALE BASE VECTORS AND OBTAIN AREA
C
      DO 20 I=1,2
        ORIGIN(I) = VEC(I,3) + P(1)*VEC(I,1) + P(2)*VEC(I,2)
        DO 10 J=1,2
          TVEC(I,J) = P(3)*VEC(I,J)
   10   CONTINUE
   20 CONTINUE
      AREA = POINT5*ABS(TVEC(1,1)*TVEC(2,2)-TVEC(1,2)*TVEC(2,1))
      A1 = DZERO
      A2 = DZERO
C
C       COMPUTE ESTIMATES FOR INTEGRAL AND ERROR
C
      DO 40 K=1,NQUAD
        X = ORIGIN(1) + W(1,K)*TVEC(1,1) + W(2,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(1,K)*TVEC(2,1) + W(2,K)*TVEC(2,2)
        S = DBLE(F(X,Y,IDATA,RDATA))
        SN = DONE
        IF (W(1,K).EQ.W(2,K)) GO TO 30
        X = ORIGIN(1) + W(2,K)*TVEC(1,1) + W(1,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(2,K)*TVEC(2,1) + W(1,K)*TVEC(2,2)
        S = S + DBLE(F(X,Y,IDATA,RDATA))
        X = ORIGIN(1) + W(2,K)*TVEC(1,1) + W(3,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(2,K)*TVEC(2,1) + W(3,K)*TVEC(2,2)
        S = S + DBLE(F(X,Y,IDATA,RDATA))
        SN = DTHREE
        IF (W(2,K).EQ.W(3,K)) GO TO 30
        X = ORIGIN(1) + W(1,K)*TVEC(1,1) + W(3,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(1,K)*TVEC(2,1) + W(3,K)*TVEC(2,2)
        S = S + DBLE(F(X,Y,IDATA,RDATA))
        X = ORIGIN(1) + W(3,K)*TVEC(1,1) + W(1,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(3,K)*TVEC(2,1) + W(1,K)*TVEC(2,2)
        S = S + DBLE(F(X,Y,IDATA,RDATA))
        X = ORIGIN(1) + W(3,K)*TVEC(1,1) + W(2,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(3,K)*TVEC(2,1) + W(2,K)*TVEC(2,2)
        S = S + DBLE(F(X,Y,IDATA,RDATA))
        SN = DSIX
   30   S = S/SN
        A1 = A1 + W(4,K)*S
        A2 = A2 + W(5,K)*S
   40 CONTINUE
      P(4) = SNGL(A1)*AREA
      P(5) = SNGL(A2)*AREA
      P(6) = ABS(P(5)-P(4))
      RETURN
      END
      SUBROUTINE IESLV (KERNEL,RHFCN,A,B,EP,IFLAG,T,X,NT,NUPPER,
     *                     MUPPER,NF,MF,NORM,W,IER)
C
C   THE INTEGRAL EQUATION BEING SOLVED IS
C
C                     B
C          X(S) -  INT  KERNEL(S,T)*X(T)*DT = RHFCN(S)
C                     A
C
C   THE METHOD BEING USED IS BASED ON THE NYSTROM METHOD WITH
C   GAUSSIAN QUADRATURE, WITH AN ITERATIVE TECHNIQUE OF SOLUTION
C   FOR THE RESULTING LINEAR SYSTEM.
C
C   KERNEL     THESE ARE REAL FUNCTIONS OF TWO AND ONE
C   RHFCN      VARIABLES, RESPECTIVELY. THEY MUST BE DECLARED IN AN
C              EXTERNAL STATEMENT IN THE PROGRAM CALLING IESLV.
C   EP         THE DESIRED ERROR. THE VARIABLE EP IS CHANGED ON
C              COMPLETION OF THE PROGRAM. SEE THE DISCUSSION OF IER
C              AND IFLAG FOR MORE INFORMATION.
C   IFLAG =0   EP IS INTERPRETED AS AN ABSOLUTE ERROR TOLERANCE.
C         =1   EP IS INTERPRETED AS A RELATIVE ERROR TOLERANCE.
C   T          CONTAINS THE NODE POINTS AT WHICH THE SOLUTION OF THE
C              INTEGRAL EQUATION IS DESIRED. SEE THE VARIABLE NT FOR
C              MORE INFORMATION.
C   X          THE COMPUTED APPROXIMATE SOLUTION OF THE INTEGRAL
C              EQUATION, EVALUATED AT THE NODE POINTS IN T, IS
C              STORED IN X ON COMPLETION OF THE ROUTINE. THIS IS
C              TRUE IRREGARDLESS OF WHETHER OR NOT THE DESIRED ERROR
C              TOLERANCE WAS ATTAINED.
C   NT         IF NT=0, THEN T AND X WILL BE SET EQUAL TO THE FINAL
C              GAUSSIAN NODES AND THE CORRESPONDING SOLUTION VALUES,
C              AND NT WILL BE SET TO THE NUMBER OF THE SOLUTION
C              VALUES STORED IN X AND T. THE ARRAYS T AND X SHOULD
C              HAVE DIMENSION AT LEAST MUPPER, ASSIGNED IN THE
C              CALLING PROGRAM.
C              IF NT .GT. 0, THEN T CONTAINS NT USER SUPPLIED NODES
C              AT WHICH THE SOLUTION X IS DESIRED.
C   NUPPER     AN UPPER LIMIT ON THE VARIABLE N IN THIS PROGRAM.
C              N IS THE ORDER OF A LINEAR SYSTEM WHICH IS BEING
C              USED TO ITERATIVELY SOLVE A LARGER LINEAR SYSTEM OF
C              ORDER M WHICH APPROXIMATES THE INTEGRAL EQUATION.
C              (FOR FURTHER DETAILS CONCERNING THE MAXIMUM VALUE
C              THAT N CAN TAKE, SEE THE DESCRIPTION OF NMAX BELOW.)
C   MUPPER     AN UPPER LIMIT ON THE VARIABLE M IN THE PROGRAM.
C              N AND M ARE ALWAYS POWERS OF TWO.
C   NF         SAME AS NFINAL (SEE BELOW)
C   MF         SAME AS MFINAL (SEE BELOW)
C   NORM       SAME AS NORMK (SEE BELOW)
C   W          TEMPORARY WORKING STORAGE FOR THE PROGRAM. IT MUST
C              CONTAIN AT LEAST 5*NU*NU+9*(NU+MU) POSITIONS, WITH
C              NU=NUPPER, MU=MUPPER.
C   IER =0     THIS ERROR COMPLETION CODE MEANS THE ROUTINE WAS
C              COMPLETED SATISFACTORILY. EP CONTAINS THE PREDICTED
C              ERROR.
C       =1     THE ERROR TEST WAS NOT SATISFIED. EP CONTAINS THE
C              PREDICTED ERROR.
C       =2     THE ERROR TEST WAS NOT SATISFIED. EP HAS BEEN SET
C              TO ZERO.
C       =3     THE ORIGINAL VALUE OF EP WAS TOO SMALL, DUE TO
C              POSSIBLE ILL-CONDITIONING PROBLEMS IN THE INTEGRAL
C              EQUATION. THE VALUE OF EP WAS RESET TO A MORE
C              REALISTIC VALUE, AND THAT TOLERANCE WAS ATTAINED.
C       =4     THE ERROR WAS SATISFACTORY AT THE GAUSSIAN NODE
C              POINTS (IER=0), BUT THE INTERPOLATION PROCESS(DUE TO
C              NT .GT. 0) MAY NOT PRESERVE THIS ACCURACY. CHECK THE
C              VALUE OF NORM(K) FOR POSSIBLE INDICATIONS THAT THE
C              INTEGRAL EQUATION MAY BE ALMOST FIRST KIND. SUCH
C              EQUATIONS ARE QUITE ILL-CONDITIONED. THE ERROR IN EP
C              IS THE PREDICTED ERROR FOR THE SOLUTION AT THE
C              GAUSSIAN NODE POINTS OF ORDER MFINAL.
C       =5     THE ANALOGUE OF IER=4, BUT WITH IER=1 AT THE
C              GAUSSIAN NODE POINTS.
C       =6     THE ANALOGUE OF IER=4, BUT WITH IER=3 AT THE
C              GAUSSIAN NODE POINTS.
C
C
C   *** REFERENCES ***
C   (1) AN AUTOMATIC PROGRAM FOR FREDHOLM INTEGRAL EQUATIONS OF THE
C       SECOND KIND, ACM TRANS. MATH SOFTWARE 2(1976), PP.154-171.
C   (2) A SURVEY OF NUMERICAL METHODS FOR THE SOLUTION OF FREDHOLM
C       INTEGRAL EQUATIONS OF THE SECOND KIND, SIAM PUB., 1976,
C       PART II, CHAP. 5.
C
      REAL KERNEL,NORM,NORMK
      DIMENSION X(*),T(*),W(*)
      EXTERNAL KERNEL,RHFCN
C
C*******************************************************************
C                                                                  *
      COMMON/XXINFO/R1,R2,FINLEP,NORMK,NFINAL,MFINAL
C                                                                  *
C   THE NUMBERS IN XXINFO GIVE ADDITIONAL INFORMATION ABOUT THE    *
C   FUNCTIONING OF IESLV. R1 IS THE ITERATIVE RATE OF CONVERGENCE  *
C   IN THE MOST RECENTLY COMPUTED LINEAR SYSTEM. R2 IS THE RATE OF *
C   CONVERGENCE OF THE GAUSSIAN QUADRATURE VARIANT OF THE NYSTROM  *
C   METHOD. FINLEP IS THE FINAL VALUE OF EP USED AS THE DESIRED    *
C   ERROR TOLERANCE. USUALLY FINLEP WILL EQUAL THE INPUT VALUE OF  *
C   EP, UNLESS EP WAS MUCH TOO SMALL. NORMK IS AN APPROXIMATE      *
C   VALUE FOR THE NORM OF THE INTEGRAL OPERATOR K, AND IT IS       *
C   CALCULATED ONLY IF NT .GT. 0.                                  *
C   NFINAL AND MFINAL ARE THE FINAL VALUES OF N AND M USED IN      *
C   IESLV.  IF NFINAL=MFINAL, THEN ITERATION WAS NOT INVOKED       *
C   SUCCESSFULLY.                                                  *
C                                                                  *
C*******************************************************************
C                                                                  *
C   NMAX IS THE MAXIMUM VALUE FOR N THAT IS PERMITTED BY IESLV.    *
C   THUS MIN0(NUPPER,NMAX) IS THE MAXIMUM VALUE FOR N THAT CAN BE  *
C   USED. THERE IS ALSO AN UPPER LIMIT OF 128 ON N IMPOSED BY THE  *
C   SUBROUTINE LNSYS.                                              *
C                                                                  *
              DATA NMAX /64/
C                                                                  *
C*******************************************************************
C                                                                  *
C     UNITRD IS A MACHINE DEPENDENT PARAMETER. ASSIGN UNITRD THE   *
C     VALUE U WHERE U IS THE SMALLEST FLOATING POINT NUMBER SUCH   *
C     THAT 1.0 + U .GT. 1.0.                                       *
C                                                                  *
              UNITRD = SPMPAR(1)
C                                                                  *
C*******************************************************************
C
      CUTOFF = 0.5
      ROOTRT = 0.1
      NUP = MIN0(NUPPER,NMAX)
C
C   SET UP THE RELATIVE BASE ADDRESSES FOR THE VARIOUS ARRAYS INTO
C   WHICH W IS TO BE SPLIT.
      N=NUP
      M=MUPPER
      NSQ=N*N
      I1=1
      I2=I1+NSQ
      I3=I2+NSQ
      I4=I3+NSQ/2
      I5=I4+NSQ/2
      I6=I5+M
      I7=I6+M
      I8=I7+N
      I9=I8+N
      I10=I9+M
      I11=I10+N
      I12=I11+M
      I13=I12+M
      I14=I13+M
      I15=I14+N
      I16=I15+M
      I17=I16+M
      I18=I17+N
      I19=I18+M
      I20=I19+4*N
      I21=I20+NSQ
      NHALF=N/2
      CALL IEGS(KERNEL,RHFCN,A,B,EP,IFLAG,X,T,NT,NUP,MUPPER,IER,
     *   CUTOFF,ROOTRT,UNITRD,NHALF,W(I1),W(I2),W(I3),W(I4),W(I5),
     *   W(I6),W(I7),W(I8),W(I9),W(I10),W(I11),W(I12),W(I13),
     *   W(I14),W(I15),W(I16),W(I17),W(I18),W(I19),W(I20),W(I21))
      NORM=NORMK
      NF=NFINAL
      MF=MFINAL
      RETURN
      END
      SUBROUTINE IEGS(KERNEL,RHFCN,A,B,EP,IFLAG,X,T,NT,NUP,MUP,IER,
     *   CUTOFF,ROOTRT,UNITRD,NHALF,LUFACT,KMM,KMN,KNM,RHS,R,RH,
     *   DELN,TM,TN,XM,XMZ,WM,WN,OLDX,SAVE,XN,SAVE2,ASIDE,ASIDE3,
     *   IMKNN)
C
C   THIS ROUTINE CONTROLS THE SOLUTION OF THE INTEGRAL EQUATION.
C
      REAL KERNEL,LUFACT,KMM,KMN,KNM,IMKNN,NORMK,NUMR1,NUMR2
      INTEGER FLAG,OLDM,PIVOT(128)
      DIMENSION X(*),T(*),LUFACT(NUP,NUP),KMM(NUP,NUP),RHS(MUP),
     *   KNM(NHALF,NUP),KMN(NUP,NHALF),R(MUP),RH(NUP),DELN(NUP),
     *   TM(MUP),TN(NUP),XM(MUP),XMZ(MUP),WM(MUP),WN(NUP),OLDX(MUP),
     *   SAVE(MUP),XN(NUP),SAVE2(MUP),ASIDE(NUP,*),ASIDE2(5),
     *   ASIDE3(NUP,NUP),IMKNN(NUP,NUP)
      COMMON/XXLIN/ELINSY,RELRSD,PIVOT
      COMMON/XXINFO/R1,R2,FINLEP,NORMK,NFINAL,MFINAL
      EXTERNAL KERNEL,RHFCN
C
C   INITIALIZATION
C
      LOOP=1
      N=2
      R2=0.5
      M=2*N
      R1RAT=ROOTRT
      COND=1.0
      PASTC=1.0
      PASTRE=0.0
      EPS=EP
C
C   STAGE A. DIRECT SOLUTION OF LINEAR SYSTEM (I-KN)*XN=RHS, WHILE
C   TRYING TO FIND A GOOD APPROXIMATE INVERSE TO IMPLEMENT
C   ITERATIVE METHOD OF SOLUTION.
C
C   CREATE THE NODES AND WEIGHTS TN(I) AND WN(I), I=1,...,N
      CALL WANDT(WN,TN,N,A,B)
C   SET UP MATRIX FOR (I-KN)*XN=RHFCN
      DO 2 J=1,N
      DO 1 I=1,N
1     IMKNN(I,J)=-WN(J)*KERNEL(TN(I),TN(J))
      XMZ(J)=RHFCN(TN(J))
2     IMKNN(J,J)=IMKNN(J,J)+1.0
      GO TO 6
C   THIS IS ENTRANCE FOR AN INCREASED VALUE OF N, USING PREVIOUSLY
C   STORED VALUES IN KMM TO DEFINE MATRIX FOR (I-KN)*XN=RHFCN WITH
C   NEW VALUE OF N.
3     DO 5 J=1,N
      DO 4 I=1,N
4     IMKNN(I,J)=-KMM(I,J)
      WN(J)=WM(J)
      TN(J)=TM(J)
      XMZ(J)=RHS(J)
5     IMKNN(J,J)=IMKNN(J,J)+1.0
C   THIS IS THE ENTRANCE WHEN ITERATION IN STAGE B FAILS AND WE NEED
C   TO INCREASE N TO OBTAIN A BETTER ITERATIVE RATE.
6     CONTINUE
C   SOLVE (I-KN)*XN=RHFCN AT ALL TN(I).ALSO OBTAIN THE LU
C   DECOMPOSITION FOR LATER USE IN THE STAGE B ITERATIVE METHOD.
C
C*******************************************************************
C                                                                  *
      CALL LNSYS(IMKNN,LUFACT,NUP,N,XMZ,XN,2,IND)
C                                                                  *
C   LNSYS IS A GENERAL LINEAR EQUATION SOLVER. IT HAS SPECIAL      *
C   OPTIONS WHICH ARE USED IN THE FOLLOWING PROGRAM. THUS IT       *
C   SHOULD NOT BE REPLACED WITH ANOTHER SOLVER. LNSYS IS ALSO      *
C   USED IN THE SUBROUTINE ITERT.                                  *
C                                                                  *
C*******************************************************************
C
      COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE)
      RELMIN=RMIN(N,N,COND,UNITRD,AVERR)
      IF(LOOP .EQ. 1) GO TO 11
      IF(LOOP .EQ. 2) GO TO 9
C   SET UP APPROXIMATE RATE OF CONVERGENCE OF SOLUTIONS XN TO TRUE
C   SOLUTION X. ALSO SET UP DESIRED RATIO FOR ITERATIVE METHOD.
      NUMR2=RNRM(XN,OLDX,N,1)
      R2=AMIN1(0.5,AMAX1(NUMR2/DENR2,1.0E-4))
      R1RAT=AMIN1(ROOTRT,SQRT(R2))
C   CHECK FOR ERROR IN XN USING TEST INVOLVING R2 AND OLDX,ACCORDING
C   TO THEORY FOR ASYMPTOTIC ERROR BOUNDS. MODIFY ERROR IF IT IS
C   OUTSIDE PRECISION RANGE OF COMPUTER, POSSIBLY DUE TO
C   ILL-CONDITIONING.
8     ERROR=(R2/(1.0-R2))*NUMR2
      XNORM=RNRM(XN,XN,N,0)
      RELERR=ERROR/XNORM
      IF(IFLAG .EQ. 0) EPS=AMAX1(EP,XNORM*RELMIN)
      IF(IFLAG .EQ. 1) EPS=AMAX1(EP,RELMIN)
      IF(IFLAG .EQ. 1)ERROR=AMAX1(RELERR,RELMIN)
      IF((IFLAG .EQ. 0) .AND. (RELERR .LT. RELMIN))
     *   ERROR=RELMIN*XNORM
      IF(ERROR .LE. EPS) GO TO 10
      DENR2=NUMR2
      GO TO 11
C   ENTRANCE FOR LOOP=2.
9     NUMR2=RNRM(XN,OLDX,N,1)
      DENR2=0.0
      GO TO 8
C   EXIT FOR SUCCESSFUL RETURN. ITERATION WAS NOT NECESSARY.
10    CALL LEAVE(0,N,N,XN,TN,WN,ERROR,
     *   KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM,
     *   XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM)
      RETURN
C
C   ATTEMPT TO SOLVE (I-KM)*XM=RHFCN ITERATIVELY, CHECKING TO SEE IF
C   THE RATE OF CONVERGENCE IS SUFFICIENTLY FAST SO AS TO ENTER
C   STAGE B.
C
C   CALCULATE TM(I) AND WM(I), I=1,...,M.
11    CALL WANDT(WM,TM,M,A,B)
      FLAG=0
C   CALCULATE INITIAL GUESS XMZ FOR ITERATION METHOD.
      CALL NSTERP(TM,WM,XMZ,M,TN,WN,XN,N,
     *   KERNEL,RHFCN,RHS,KMN,NHALF,NUP)
      DO 12 I=1,M
12    OLDX(I)=XMZ(I)
C   CALCULATE FIRST ITERATE.
      CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM,
     *   RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG)
      COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE)
      DENR1=RNRM(XM,XMZ,M,1)
      FLAG=1
      DO 13 I=1,M
13    XMZ(I)=XM(I)
C   CALCULATE SECOND ITERATE.
      CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM,
     *   RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG)
      COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE)
      NUMR1=RNRM(XM,XMZ,M,1)
C   CHECK ON THE SPEED OF CONVERGENCE OF ITERATIVE METHOD. IF IT IS
C   SUFFICIENTLY RAPID, THEN FIX N AND GO TO STAGE B.
      R1=AMAX1(NUMR1/DENR1,.0001)
      RATE=R1
      IF(M .GT. NUP) GO TO 19
      IF(R1 .LE. R1RAT) GO TO 15
C   THE ITERATION DID NOT WORK WELL ENOUGH, AND STAGE A IS TO BE
C   REPEATED. RE-INITIALIZE FOR SOLVING (I-KN)*XN=RHFCN AGAIN
C   WITH A LARGER N.
14    N=M
      LOOP=LOOP+1
      M=2*N
      GO TO 3
C   THE ITERATIVE RATE IS SUFFICIENTLY RAPID, AND CONTROL WILL GO TO
C   STAGE B. SAVE INFORMATION IN CASE STAGE B ABORTS AT A LARGER
C   VALUE OF M AND STAGE A HAS TO BE RETURNED TO.
15    DO 16 I=1,M
      ASIDE(I,1)=OLDX(I)
      ASIDE(I,2)=WM(I)
      ASIDE(I,3)=TM(I)
16    ASIDE(I,4)=RHS(I)
      ASIDE2(1)=LOOP
      ASIDE2(3)=R2
      ASIDE2(4)=DENR2
      ASIDE2(5)=R1RAT
      DO 17 J=1,M
      DO 17 I=1,M
17    ASIDE3(I,J)=KMM(I,J)
C
C   STAGE B. ITERATIVE METHOD OF SOLUTION OF (I-KM)*XM=RHS.
C
19    OLDM=N
      ASIDE2(2)=M
      IF(R1 .LE. CUTOFF) GO TO 22
C   THE ITERATES ARE CONVERGING VERY SLOWLY OR NOT AT ALL. THUS
C   RETURN WITHOUT FURTHER ATTEMPTS TO LESSEN THE ERROR.
      IF(LOOP .NE. 1) GO TO 21
20    CALL LEAVE(2,N,N,XN,TN,WN,0.0,
     *   KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM,
     *   XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM)
      RETURN
21    CALL LEAVE(1,N,N,XN,TN,WN,ERROR,
     *   KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM,
     *   XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM)
      RETURN
C   TEST TO SEE IF THE CURRENT ITERATE XM IS SUFFICIENTLY ACCURATE
C   COMPARED TO THE TRUE XM.
22    RATE=R1*RATE
      TEMP=RNRM(XM,OLDX,M,1)
      IF(LOOP .EQ. 1) TEMP2=0.5
      IF(LOOP .GT. 1) TEMP2=TEMP/DENR2
      RT=  AMIN1(0.01,AMAX1(TEMP2,0.0001))/2.0
      XNORM=RNRM(XM,XM,M,0)
      ESTERR=(RT/(1.0-RT))*TEMP/XNORM
      IF(ESTERR .LT. RELMIN) ESTERR=RELMIN
      ESTERR=ESTERR*XNORM
      TEST=((1.0-R1)/R1)*ESTERR
      IF(NUMR1 .LE. TEST) GO TO 33
C   ITERATE NOT SUFFICIENTLY ACCURATE. INITIALIZE FOR COMPUTATION
C   OF ANOTHER ITERATE.
25    DENR1=NUMR1
      DO 26 I=1,M
26    XMZ(I)=XM(I)
      CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM,
     *   RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG)
      COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE)
      NUMR1=RNRM(XM,XMZ,M,1)
      R1=AMAX1(NUMR1/DENR1,.0001)
      IF(R1 .LE. CUTOFF) GO TO 22
C   THIS IS ENTRANCE FOR CASE WHERE ITERATION FAILS IN STAGE B.
C   PARAMETERS MUST BE RESET FOR A RETURN TO STAGE A OR FOR AN
C   ABORTIVE EXIT IF N CANNOT BE INCREASED ANY FURTHER.
27    MNEW=ASIDE2(2)
      IF(MNEW .GT. NUP) GO TO 30
      N=MNEW
      DO 29 J=1,N
      DO 28 I=1,N
28    IMKNN(I,J)=-ASIDE3(I,J)
      OLDX(J)=ASIDE(J,1)
      WN(J)=ASIDE(J,2)
      TN(J)=ASIDE(J,3)
      XMZ(J)=ASIDE(J,4)
29    IMKNN(J,J)=IMKNN(J,J)+1.0
      M=2*N
      LOOP=ASIDE2(1)+1.0
      R2=ASIDE2(3)
      DENR2=ASIDE2(4)
      R1RAT=ASIDE2(5)
      GO TO 6
C   ABORTIVE EXIT FROM STAGE B. N CANNOT BE INCREASED FURTHER, AND
C   R1 IS NOT SUFFICIENTLY SMALL.
30    IF(LOOP .EQ. 1) GO TO 20
      CALL WANDT(WM,TM,OLDM,A,B)
      CALL LEAVE(1,N,OLDM,SAVE,TM,WM,ERROR,
     *   KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM,
     *   XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM)
      RETURN
C   AN ACCURATE VALUE OF XM HAS BEEN OBTAINED. R2 IS TO BE TESTED AS
C   TO WHETHER IT SHOULD BE RESET. THEN CHECK ERROR IN XM COMPARED
C   WITH THE TRUE SOLUTION X.
33    IF(LOOP .EQ. 1) GO TO 37
      NUMR2=TEMP
      R2=AMAX1(1.0E-4,RATE,AMIN1(NUMR2/DENR2,0.5))
      DENR2=NUMR2
34    ERROR=(R2/(1.0-R2))*TEMP
      XNORM=RNRM(XM,XM,M,0)
      RELERR=ERROR/XNORM
      RELMIN=RMIN(N,M,COND,UNITRD,AVERR)
      IF(IFLAG .EQ. 0) EPS=AMAX1(EP,XNORM*RELMIN)
      IF(IFLAG .EQ. 1) EPS=AMAX1(EP,RELMIN)
      IF(IFLAG .EQ. 1)ERROR=AMAX1(RELERR,RELMIN)
      IF((IFLAG .EQ. 0) .AND. (RELERR .LT. RELMIN))
     *   ERROR=RELMIN*XNORM
      IF(ERROR .GT. EPS) GO TO 35
      CALL LEAVE(0,N,M,XM,TM,WM,ERROR,
     *   KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM,
     *   XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM)
      RETURN
35    MNEW=2*M
      IF(MNEW .LE. MUP) GO TO 39
C   M CANNOT BE INCREASED ANY FURTHER.
      CALL LEAVE(1,N,M,XM,TM,WM,ERROR,
     *   KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM,
     *   XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM)
      RETURN
37    DENR2=TEMP
      LOOP=2
      GO TO 34
C   ERROR NOT SUFFICIENTLY SMALL. M IS INCREASED AND TWO MORE
C   MORE ITERATES ARE COMPUTED WITH THE NEW M.
39    OLDM=M
      M=MNEW
      DO 41 I=1,OLDM
      SAVE2(I)=WM(I)
41    SAVE(I)=TM(I)
      CALL WANDT(WM,TM,M,A,B)
      FLAG=0
      CALL NSTERP(TM,WM,XMZ,M,SAVE,SAVE2,XM,OLDM,
     *   KERNEL,RHFCN,RHS,KMN,NHALF,NUP)
      DO 43 I=1,OLDM
43    SAVE(I)=XM(I)
      DO 45 I=1,M
45    OLDX(I)=XMZ(I)
      CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM,
     *   RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG)
      COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE)
      DENR1=RNRM(XM,XMZ,M,1)
      FLAG=1
      DO 47 I=1,M
47    XMZ(I)=XM(I)
      CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM,
     *   RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG)
      COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE)
      NUMR1=RNRM(XM,XMZ,M,1)
      R1=AMAX1(NUMR1/DENR1,.0001)
      RATE=R1
      IF(R1 .LE. CUTOFF) GO TO 22
      GO TO 27
      END
      SUBROUTINE NSTERP(TM,WM,XM,M,TN,WN,XN,N,KERNEL,RHFCN,RHS,KMN,
     *   NHALF,NUP)
C
C   USE THE VALUES OF XN(I), I=1,...,N, TO CALCULATE THE NYSTROM
C   INTERPOLATES XM(I), I=1,...,M.
C
      REAL KERNEL,KMN
      DIMENSION TM(M),WM(M),XM(M),TN(N),WN(N),XN(N),RHS(M),
     *   KMN(NUP,NHALF)
      EXTERNAL KERNEL,RHFCN
C
      IF(M .GT. NUP) GO TO 4
C   SINCE M .LE. NUPPER, SAVE K(TM(I),TN(J))=KMN(I,J) AND
C   RHS(I)=RHFCN(TM(I)) FOR LATER USE IN ITERT.
      DO 1 I=1,M
      DO 1 J=1,N
1     KMN(I,J)=WN(J)*KERNEL(TM(I),TN(J))
      DO 2 I=1,M
      RHS(I)=RHFCN(TM(I))
2     XM(I)=RHS(I)
C   CALCULATE NYSTROM INTERPOLATING FORMULA.
      DO 3 I=1,M
      DO 3 J=1,N
3     XM(I)=XM(I)+KMN(I,J)*XN(J)
      RETURN
C   M .GT. NUPPER, SO SAVE JUST RHS(I) FOR LATER USE IN ITERT.
C   CALCULATE NYSTROM INTERPOLATING FORMULA.
4     DO 5 I=1,M
      RHS(I)=RHFCN(TM(I))
      XM(I)=RHS(I)
      DO 5 J=1,N
5     XM(I)=XM(I)+WN(J)*KERNEL(TM(I),TN(J))*XN(J)
      RETURN
      END
      FUNCTION RMIN(N,M,COND,UNITRD,AVERR)
C
C   FOR A LINEAR SYSTEM   (I-KMM)*XM=RHFCN   OF ORDER M, THIS IS THE
C   VALUE OF RELMIN USED IN IEGS. THE VARIABLE UNITRD IS DEFINED IN
C   IEGAUS, AND THE VARIABLES COND AND AVERR ARE DEFINED IN IEGS
C   USING CONEW.
C   IT IS UNLIKELY THAT A SOLUTION X CAN BE FOUND FOR THE ORIGINAL
C   INTEGRAL EQUATION WITH A SMALLER RELATIVE ERROR THAN RMIN.
C
      FLOAT1=M
      FLOAT2=FLOAT(M)/FLOAT(N)
      RMIN=AMAX1((FLOAT1**1.5)*COND*UNITRD,
     *   (FLOAT2**1.5)*AVERR)
      RETURN
      END
      REAL FUNCTION RNRM(X,Y,N,IFLAG)
C
C   IFLAG=0    CALCULATE THE MAXIMUM NORM OF X.
C   IFLAG=1    CALCULATE THE MAXIMUM NORM OF X-Y.
C
      DIMENSION X(N),Y(N)
      IF(IFLAG .EQ. 1) GO TO 2
C   FIND THE NORM OF X.
      RNRM=0.0
      DO 1 I=1,N
1     RNRM=AMAX1(RNRM,ABS(X(I)))
      RETURN
C   FIND THE NORM OF X-Y.
2     RNRM=0.0
      DO 3 I=1,N
3     RNRM=AMAX1(RNRM,ABS(X(I)-Y(I)))
      RETURN
      END
      FUNCTION CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE)
C
C   THIS IS USED IN UPDATING THE VALUE OF THE CONDITION NUMBER
C   IN IEGS.
C
      AVERR=SQRT(ELINSY*PASTRE)
      PASTRE=ELINSY
      IF(RELRSD .EQ. 0.0) GO TO 1
      C=AMAX1(1.0,ELINSY/RELRSD)
      CONEW=SQRT(C*PASTC)
      PASTC=C
      RETURN
1     CONEW=COND
      RETURN
      END
      SUBROUTINE WANDT(WV,TV,N,A,B)
C
C   INTEGRATION WEIGHTS AND NODES ARE TO BE CALCULATED AND STORED IN
C   WV AND TV, RESPECTIVELY. N IS ASSUMED TO BE A POWER OF TWO. IF
C   2 .LE. N .LE. 256, THEN GAUSSIAN QUADRATURE IS USED. IF N .GT.
C   256, THEN THE INTERVAL (A,B) IS DIVIDED N/256 TIMES AND THE 256
C   POINT FORMULA IS APPLIED TO EACH SUBINTERVAL.
C
      DIMENSION WV(N),TV(N)
      DIMENSION W(255),T(255)
      DATA T(1),T(2),T(3),T(4),T(5),T(6),T(7),T(8),T(9),T(10),T(11),
     *     T(12),T(13),T(14),T(15)/.577350269189626E0,
     *  .861136311594053E0,.339981043584856E0,.960289856497536E0,
     *  .796666477413627E0,.525532409916329E0,.183434642495650E0,
     *  .989400934991650E0,.944575023073233E0,.865631202387832E0,
     *  .755404408355003E0,.617876244402644E0,.458016777657227E0,
     *  .281603550779259E0,.950125098376374E-1/
      DATA T(16),T(17),T(18),T(19),T(20),T(21),T(22),T(23),T(24),T(25),
     *     T(26),T(27),T(28),T(29),T(30),T(31)/.997263861849482E0,
     *  .985611511545268E0,.964762255587506E0,.934906075937740E0,
     *  .896321155766052E0,.849367613732570E0,.794483795967942E0,
     *  .732182118740290E0,.663044266930215E0,.587715757240762E0,
     *  .506899908932229E0,.421351276130635E0,.331868602282128E0,
     *  .239287362252137E0,.144471961582796E0,.483076656877383E-1/
      DATA T(32),T(33),T(34),T(35),T(36),T(37),T(38),T(39),T(40),T(41),
     *     T(42),T(43),T(44),T(45),T(46),T(47)/.999305041735772E0,
     *  .996340116771955E0,.991013371476744E0,.983336253884626E0,
     *  .973326827789911E0,.961008799652054E0,.946411374858403E0,
     *  .929569172131940E0,.910522137078503E0,.889315445995114E0,
     *  .865999398154093E0,.840629296252580E0,.813265315122798E0,
     *  .783972358943341E0,.752819907260532E0,.719881850171611E0/
      DATA T(48),T(49),T(50),T(51),T(52),T(53),T(54),T(55),T(56),T(57),
     *     T(58),T(59),T(60),T(61),T(62),T(63)/.685236313054233E0,
     *  .648965471254657E0,.611155355172393E0,.571895646202634E0,
     *  .531279464019895E0,.489403145707053E0,.446366017253464E0,
     *  .402270157963992E0,.357220158337668E0,.311322871990211E0,
     *  .264687162208767E0,.217423643740007E0,.169644420423993E0,
     *  .121462819296121E0,.729931217877990E-1,.243502926634244E-1/
      DATA T(64),T(65),T(66),T(67),T(68),T(69),T(70),T(71),T(72),T(73),
     *     T(74),T(75),T(76),T(77),T(78),T(79)/.999824887947132E0,
     *  .999077459977376E0,.997733248625514E0,.995792758534981E0,
     *  .993257112900213E0,.990127818491734E0,.986406742724586E0,
     *  .982096108435719E0,.977198491463907E0,.971716818747137E0,
     *  .965654366431965E0,.959014757853700E0,.951801961341264E0,
     *  .944020287830220E0,.935674388277916E0,.926769250878948E0/
      DATA T(80),T(81),T(82),T(83),T(84),T(85),T(86),T(87),T(88),T(89),
     *     T(90),T(91),T(92),T(93),T(94),T(95),T(96),T(97)/
     *  .917310198080961E0,.907302883401757E0,.896753288049158E0,
     *  .885667717345397E0,.874052796958032E0,.861915468939548E0,
     *  .849262987577969E0,.836102915060907E0,.822443116955644E0,
     *  .808291757507914E0,.793657294762193E0,.778548475506412E0,
     *  .762974330044095E0,.746944166797062E0,.730467566741909E0,
     *  .713554377683587E0,.696214708369514E0,.678458922447719E0/
      DATA T(98),T(99),T(100),T(101),T(102),T(103),T(104),T(105),T(106),
     *     T(107),T(108),T(109),T(110),T(111),T(112),T(113),T(114)/
     *  .660297632272646E0,.641741692562308E0,.622802193910585E0,
     *  .603490456158549E0,.583818021628763E0,.563796648226618E0,
     *  .543438302412810E0,.522755152051175E0,.501759559136144E0,
     *  .480464072404172E0,.458881419833552E0,.437024501037104E0,
     *  .414906379552275E0,.392540275033267E0,.369939555349859E0,
     *  .347117728597636E0,.324088435024413E0/
      DATA T(115),T(116),T(117),T(118),T(119),T(120),T(121),T(122),
     *     T(123),T(124),T(125),T(126),T(127)/.300865438877677E0,
     *  .277462620177904E0,.253893966422694E0,.230173564226660E0,
     *  .206315590902079E0,.182334305985337E0,.158244042714225E0,
     *  .134059199461188E0,.109794231127644E0,
     *  .854636405045155E-1,.610819696041396E-1,.366637909687335E-1,
     *  .122236989606158E-1/
      DATA T(128),T(129),T(130),T(131),T(132),T(133),T(134),T(135),
     *     T(136),T(137),T(138),T(139),T(140),T(141),T(142)/
     *  .999956050018992E0,.999768437409263E0,.999430937466261E0,
     *  .998943525843409E0,.998306266473006E0,.997519252756721E0,
     *  .996582602023382E0,.995496454481096E0,.994260972922410E0,
     *  .992876342608822E0,.991342771207583E0,.989660488745065E0,
     *  .987829747564861E0,.985850822286126E0,.983724009760315E0/
      DATA T(143),T(144),T(145),T(146),T(147),T(148),T(149),T(150),
     *     T(151),T(152),T(153),T(154),T(155),T(156),T(157)/
     *  .981449629025464E0,.979028021257622E0,.976459549719234E0,
     *  .973744599704370E0,.970883578480743E0,.967876915228489E0,
     *  .964725060975706E0,.961428488530732E0,.957987692411178E0,
     *  .954403188769716E0,.950675515316628E0,.946805231239127E0,
     *  .942792917117462E0,.938639174837814E0, .934344627502003E0/
      DATA T(158),T(159),T(160),T(161),T(162),T(163),T(164),T(165),
     *     T(166),T(167),T(168),T(169),T(170),T(171),T(172)/
     *  .929909919334006E0,.925335715583316E0,.920622702425146E0,
     *  .915771586857490E0,.910783096595065E0,.905657979960145E0,
     *  .900397005770304E0,.895000963223085E0,.889470661777611E0,
     *  .883806931033158E0,.878010620604707E0,.872082599995488E0,
     *  .866023758466555E0,.859835004903376E0,.853517267679503E0/
      DATA T(173),T(174),T(175),T(176),T(177),T(178),T(179),T(180),
     *     T(181),T(182),T(183),T(184),T(185),T(186),T(187)/
     *  .847071494517296E0,.840498652345763E0,.833799727155505E0,
     *  .826975723850813E0,.820027666098917E0,.812956596176432E0,
     *  .805763574812999E0,.798449681032171E0,.791016011989546E0,
     *  .783463682808184E0,.775793826411326E0,.768007593352446E0,
     *  .760106151642655E0,.752090686575492E0,.743962400549112E0/
      DATA T(188),T(189),T(190),T(191),T(192),T(193),T(194),T(195),
     *     T(196),T(197),T(198),T(199),T(200),T(201),T(202)/
     *  .735722512885918E0,.727372259649652E0,.718912893459971E0,
     *  .710345683304543E0,.701671914348685E0,.692892887742577E0,
     *  .684009920426076E0,.675024344931163E0,.665937509182049E0,
     *  .656750776292973E0,.647465524363725E0,.638083146272911E0,
     *  .628605049469015E0,.619032655759261E0,.609367401096334E0/
      DATA T(203),T(204),T(205),T(206),T(207),T(208),T(209),T(210),
     *     T(211),T(212),T(213),T(214),T(215),T(216),T(217)/
     *  .599610735362968E0,.589764122154454E0,.579829038559083E0,
     *  .569806974936569E0,.559699434694481E0,.549507934062719E0,
     *  .539234001866059E0,.528879179294822E0,.518445019673674E0,
     *  .507933088228616E0,.497344961852181E0,.486682228866890E0,
     *  .475946488786983E0,.465139352078479E0,.454262439917590E0/
      DATA T(218),T(219),T(220),T(221),T(222),T(223),T(224),T(225),
     *     T(226),T(227),T(228),T(229),T(230),T(231),T(232)/
     *  .443317383947527E0,.432305826033741E0,.421229418017624E0,
     *  .410089821468717E0,.398888707435459E0,.387627756194516E0,
     *  .376308656998716E0,.364933107823654E0,.353502815112970E0,
     *  .342019493522372E0,.330484865662417E0,.318900661840106E0,
     *  .307268619799319E0,.295590484460136E0,.283868007657082E0/
      DATA T(233),T(234),T(235),T(236),T(237),T(238),T(239),T(240),
     *     T(241),T(242),T(243),T(244),T(245),T(246),T(247)/
     *  .272102947876337E0,.260297069991943E0,.248452145001057E0,
     *  .236569949758284E0,.224652266709132E0,.212700883622626E0,
     *  .200717593323127E0,.188704193421389E0,.176662486044902E0,
     *  .164594277567554E0,.152501378338656E0,.140385602411376E0,
     *  .128248767270607E0,.116092693560333E0,.103919204810509E0/
      DATA   T(248),T(249),T(250),T(251),T(252),T(253),T(254),T(255)/
     *  .917301271635196E-1,.795272891002330E-1,.673125211657164E-1,
     *  .550876556946340E-1,.428545265363791E-1,.306149687799790E-1,
     *  .183708184788137E-1,.612391237518953E-2/
      DATA W(1),W(2),W(3),W(4),W(5),W(6),W(7),W(8),W(9),W(10),W(11),
     *     W(12),W(13),W(14),W(15)/1.0E0,.347854845137454E0,
     *  .652145154862546E0,.101228536290376E0,.222381034453374E0,
     *  .313706645877887E0,.362683783378362E0,.271524594117541E-1,
     *  .622535239386479E-1,.951585116824928E-1,.124628971255534E0,
     *  .149595988816577E0,.169156519395003E0,.182603415044924E0,
     *  .189450610455068E0/
      DATA W(16),W(17),W(18),W(19),W(20),W(21),W(22),W(23),W(24),W(25),
     *     W(26),W(27),W(28),W(29),W(30),W(31)/.701861000947010E-2,
     *  .162743947309057E-1,.253920653092621E-1,.342738629130214E-1,
     *  .428358980222267E-1,.509980592623762E-1,.586840934785355E-1,
     *  .658222227763618E-1,.723457941088485E-1,.781938957870703E-1,
     *  .833119242269468E-1,.876520930044038E-1,.911738786957639E-1,
     *  .938443990808046E-1,.956387200792749E-1,.965400885147278E-1/
      DATA W(32),W(33),W(34),W(35),W(36),W(37),W(38),W(39),W(40),W(41),
     *     W(42),W(43),W(44),W(45),W(46),W(47)/.178328072169643E-2,
     *  .414703326056247E-2,.650445796897836E-2,.884675982636395E-2,
     *  .111681394601311E-1,.134630478967186E-1,.157260304760247E-1,
     *  .179517157756973E-1,.201348231535302E-1,.222701738083833E-1,
     *  .243527025687109E-1,.263774697150547E-1,.283396726142595E-1,
     *  .302346570724025E-1,.320579283548516E-1,.338051618371416E-1/
      DATA W(48),W(49),W(50),W(51),W(52),W(53),W(54),W(55),W(56),W(57),
     *     W(58),W(59),W(60),W(61),W(62),W(63)/ .354722132568824E-1,
     *  .370551285402400E-1,.385501531786156E-1,.399537411327203E-1,
     *  .412625632426235E-1,.424735151236536E-1,.435837245293235E-1,
     *  .445905581637566E-1,.454916279274181E-1, .462847965813144E-1,
     * .469681828162100E-1,.475401657148303E-1,.479993885964583E-1,
     *  .483447622348030E-1,.485754674415034E-1,.486909570091397E-1/
      DATA W(64),W(65),W(66),W(67),W(68),W(69),W(70),W(71),W(72),W(73),
     *     W(74),W(75),W(76),W(77),W(78),W(79)/ .449380960292090E-3,
     *  .104581267934035E-2,.164250301866903E-2,.223828843096262E-2,
     *  .283275147145799E-2,.342552604091022E-2,.401625498373864E-2,
     *  .460458425670296E-2,.519016183267633E-2,.577263754286570E-2,
     *  .635166316170719E-2,.692689256689881E-2,.749798192563473E-2,
     *  .806458989048606E-2,.862637779861675E-2,.918300987166087E-2/
      DATA W(80),W(81),W(82),W(83),W(84),W(85),W(86),W(87),W(88),
     * W(89),W(90),W(91),W(92),W(93),W(94),W(95)/.973415341500681E-2,
     *  .102794790158322E-1,.108186607395031E-1,.113513763240804E-1,
     *  .118773073727403E-1,.123961395439509E-1,.129075627392673E-1,
     *  .134112712886163E-1,.139069641329520E-1,.143943450041668E-1,
     *  .148731226021473E-1,.153430107688651E-1,.158037286593993E-1,
     *  .162550009097852E-1,.166965578015892E-1,.171281354231114E-1/
      DATA W(96),W(97),W(98),W(99),W(100),W(101),W(102),W(103),W(104),
     *     W(105),W(106),W(107),W(108),W(109),W(110),W(111),W(112)/
     *  .175494758271177E-1,.179603271850087E-1,.183604439373313E-1,
     *  .187495869405447E-1,.191275236099509E-1,.194940280587066E-1,
     *  .198488812328309E-1,.201918710421300E-1,.205227924869601E-1,
     *  .208414477807511E-1,.211476464682213E-1,.214412055392085E-1,
     *  .217219495380521E-1,.219897106684605E-1,.222443288937998E-1,
     *  .224856520327450E-1,.227135358502365E-1/
      DATA W(113),W(114),W(115),W(116),W(117),W(118),W(119),W(120),
     *     W(121),W(122),W(123),W(124),W(125),W(126),W(127)/
     *  .229278441436868E-1,.231284488243870E-1,.233152299940628E-1,
     *  .234880760165359E-1,.236468835844476E-1,.237915577810034E-1,
     *  .239220121367035E-1,.240381686810241E-1,.241399579890193E-1,
     *  .242273192228152E-1,.243002001679719E-1,.243585572646906E-1,
     *  .244023556338496E-1,.244315690978500E-1,.244461801962625E-1/
      DATA W(128),W(129),W(130),W(131),W(132),W(133),W(134),W(135),
     *     W(136),W(137),W(138),W(139),W(140),W(141),W(142)/
     *  .112789017822272E-3,.262534944296446E-3,.412463254426176E-3,
     *  .562348954031410E-3,.712154163473321E-3,.861853701420089E-3,
     *  .101142439320844E-2,.116084355756772E-2,.131008868190250E-2,
     *  .145913733331073E-2,.160796713074933E-2,.175655573633073E-2,
     *  .190488085349972E-2,.205292022796614E-2,.220065164983991E-2/
      DATA W(143),W(144),W(145),W(146),W(147),W(148),W(149),W(150),
     *     W(151),W(152),W(153),W(154),W(155),W(156),W(157)/
     *  .234805295632731E-2,.249510203470371E-2,.264177682542749E-2,
     *  .278805532532771E-2,.293391559082972E-2,.307933574119934E-2,
     *  .322429396179420E-2,.336876850731555E-2,.351273770505631E-2,
     *  .365617995814250E-2,.379907374876626E-2,.394139764140883E-2,
     *  .408313028605267E-2,.422425042138154E-2,.436473687796806E-2/
      DATA W(158),W(159),W(160),W(161),W(162),W(163),W(164),W(165),
     *     W(166),W(167),W(168),W(169),W(170),W(171),W(172)/
     *  .450456858144790E-2,.464372455568006E-2,.478218392589269E-2,
     *  .491992592181387E-2,.505692988078684E-2,.519317525086928E-2,
     *  .532864159391593E-2,.546330858864431E-2,.559715603368291E-2,
     *  .573016385060144E-2,.586231208692265E-2,.599358091911534E-2,
     *  .612395065556793E-2,.625340173954240E-2,.638191475210788E-2/
      DATA W(173),W(174),W(175),W(176),W(177),W(178),W(179),W(180),
     *     W(181),W(182),W(183),W(184),W(185),W(186),W(187)/
     *  .650947041505366E-2,.663604959378107E-2,.676163330017380E-2,
     *  .688620269544632E-2,.700973909296982E-2,.713222396107539E-2,
     *  .725363892583391E-2,.737396577381235E-2,.749318645480588E-2,
     *  .761128308454566E-2,.772823794738156E-2,.784403349893971E-2,
     *  .795865236875435E-2,.807207736287350E-2,.818429146643827E-2/
      DATA W(188),W(189),W(190),W(191),W(192),W(193),W(194),W(195),
     *     W(196),W(197),W(198),W(199),W(200),W(201),W(202)/
     *  .829527784623523E-2,.840501985322154E-2,.851350102502249E-2,
     *  .862070508840101E-2,.872661596169881E-2,.883121775724875E-2,
     *  .893449478375821E-2,.903643154866287E-2,.913701276045081E-2,
     *  .923622333095630E-2,.933404837762327E-2,.943047322573775E-2,
     *  .952548341062928E-2,.961906467984073E-2,.971120299526628E-2/
      DATA W(203),W(204),W(205),W(206),W(207),W(208),W(209),W(210),
     *     W(211),W(212),W(213),W(214),W(215),W(216),W(217)/
     *  .980188453525733E-2,.989109569669583E-2,.997882309703491E-2,
     *  .100650535763064E-1,.101497741990949E-1,.102329722564782E-1,
     *  .103146352679340E-1,.103947509832117E-1,.104733073841704E-1,
     *  .105502926865815E-1,.106256953418966E-1,.106995040389798E-1,
     *  .107717077058046E-1,.108422955111148E-1,.109112568660490E-1/
      DATA W(218),W(219),W(220),W(221),W(222),W(223),W(224),W(225),
     *     W(226),W(227),W(228),W(229),W(230),W(231),W(232)/
     *  .109785814257296E-1,.110442590908139E-1,.111082800090098E-1,
     *  .111706345765534E-1,.112313134396497E-1,.112903074958755E-1,
     *  .113476078955455E-1,.114032060430392E-1,.114570935980906E-1,
     *  .115092624770395E-1,.115597048540436E-1,.116084131622531E-1,
     *  .116553800949452E-1,.117005986066207E-1,.117440619140606E-1/
      DATA W(233),W(234),W(235),W(236),W(237),W(238),W(239),W(240),
     *     W(241),W(242),W(243),W(244),W(245),W(246),W(247)/
     *  .117857634973434E-1,.118256971008240E-1,.118638567340711E-1,
     *  .119002366727665E-1,.119348314595636E-1,.119676359049059E-1,
     *  .119986450878058E-1,.120278543565826E-1,.120552593295601E-1,
     *  .120808558957245E-1,.121046402153405E-1,.121266087205273E-1,
     *  .121467581157945E-1,.121650853785355E-1,.121815877594818E-1/
      DATA W(248),W(249),W(250),W(251),W(252),W(253),W(254),W(255)/
     *  .121962627831147E-1,.122091082480372E-1,.122201222273040E-1,
     *  .122293030687103E-1,.122366493950402E-1,.122421601042728E-1,
     *  .122458343697479E-1,.122476716402898E-1/
      LOOP=MAX0(1,N/256)
      FLOOP=LOOP
      H=(B-A)/FLOOP
      SCALE=H/2.0
      M=MIN0(128,N/2)
      MT=2*M
      NPLACE=M-1
      DO 1 L=1,LOOP
      FL=L
      AL=A+(FL-1.0)*H
      BL=A+FL*H
      K=256*(L-1)
      DO 1 I=1,M
      NPI=NPLACE+I
      S=T(NPI)
      R=W(NPI)*SCALE
      I1=K+I
      I2=K+MT+1-I
      TV(I1)=  (AL*(1.0+S)+(1.0-S)*BL)/2.0
      TV(I2)=  (AL*(1.0-S)+(1.0+S)*BL)/2.0
      WV(I1)=R
1     WV(I2)=R
      RETURN
      END
      SUBROUTINE LEAVE(IERSET,NF,MF,XV,TV,WV,ERROR,KERNEL,RHFCN,EP,
     *   IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM,XMZ,KMM,KMN,KNM,
     *   RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM)
C
C   THIS ROUTINE SETS ALL NECESSARY PARAMETERS FOR LEAVING IEGAUS.
C   IF NT .GT. 0, IT ALSO PERFORMS THE NECESSARY NYSTROM
C   INTERPOLATION AT THE NODES GIVEN IN T.
C
      REAL KERNEL,KMM,KMN,KNM,IMKNN,LUFACT,NORMK,NUMR1
      DIMENSION X(*),T(*),XV(MF),TV(MF),WV(MF),TN(NF),WN(NF),WM(MF),
     *   XM(MF),XMZ(MF),KMM(NUP,NUP),KMN(NUP,NHALF),KNM(NHALF,NUP),
     *   RHS(MF),IMKNN(NUP,NUP),LUFACT(NUP,NUP),R(MF),RH(NF),
     *   TM(MF),DELN(NF)
      COMMON/XXINFO/R1,R2,FINLEP,NORMK,NFINAL,MFINAL
      EXTERNAL KERNEL,RHFCN
C
C   SET ERROR PARAMETERS FOR RETURN.
C
      NORMK=0.0
      NFINAL=NF
      MFINAL=MF
      FINLEP=EPS
      IF((EPS .GT. EP) .AND. (ERROR .LE. EPS)) GO TO 10
      IER=IERSET
      EP=ERROR
      IF(NT .EQ. 0) GO TO 20
      GO TO 30
10    IER=3
C
C   SINCE EPS IS THE SMALLEST ERROR POSSIBLE, SET EP=EPS FOR THE
C   RETURN ERROR ESTIMATE.
C
      EP=EPS
      IF(NT .GT. 0) GO TO 30
C
C   NO NYSTROM INTERPOLATION IS DESIRED. RETURN THE VALUES AT THE
C   GAUSSIAN NODE POINTS.
C
20    DO 21 I=1,MF
      X(I)=XV(I)
21    T(I)=TV(I)
      NT=MF
      RETURN
C   CALCULATE NORM(K).
30    SAVEP=EP
      DO 31 I=1,NF
31    IMKNN(I,I)=IMKNN(I,I)-1.0
      NORMK=0.0
      DO 33 I=1,NF
      SUM=0.0
      DO 32 J=1,NF
32    SUM=SUM+ABS(IMKNN(I,J))
33    NORMK=AMAX1(NORMK,SUM)
      DO 34 I=1,NF
34    IMKNN(I,I)=IMKNN(I,I)+1.0
      IF(NF .EQ. MF) GO TO 50
C
C   ITERATE TO DECREASE THE NOISE LEVEL IN X. THIS SHOULD REDUCE
C   POSSIBLE ERRORS IN NYSTROM INTERPOLATION.
C
      DERROR=((1.0-R1)/R1)*EPS/NORMK
      IF(IFLAG .EQ. 1) DERROR=DERROR*XNORM
      ITLOOP=0
      DO 41 I=1,MF
41    XM(I)=XV(I)
42    DO 43 I=1,MF
43    XMZ(I)=XM(I)
      CALL ITERT(KERNEL,RHFCN,NF,TN,WN,MF,TM,WM,XM,XMZ,KMM,KMN,KNM,
     *   RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,1)
      NUMR1=RNRM(XM,XMZ,MF,1)
      ITLOOP=ITLOOP+1
      IF((NUMR1 .GT. DERROR) .AND. (ITLOOP .LT. 5)) GO TO 42
      DO 44 I=1,MF
44    XV(I)=XM(I)
C
C   ESTIMATE NEW ERROR BOUND FOR NYSTROM INTERPOLATES.
C
      TEMP=NORMK*(R1/(1.0-R1))*NUMR1
      IF(IFLAG .EQ. 1) TEMP=TEMP/XNORM
      EP=AMAX1(EP,TEMP)
      GO TO 60
C
C   NO ITERATION USED IN COMPUTING X. JUST COMPUTE ERROR ESTIMATE
C   IN NYSTROM INTERPOLATE.
C
50    TEMP=NORMK*ELINSY
      IF(IFLAG .EQ. 0) TEMP=TEMP*XNORM
      IF(IER .NE. 2) EP=AMAX1(EP,TEMP)
C
C   COMPUTE NYSTROM INTERPOLATES AT THE NODES IN T.
C
60    DO 62 I=1,NT
      SUM=0.0
      DO 61 J=1,MF
61    SUM=SUM+WV(J)*KERNEL(T(I),TV(J))*XV(J)
62    X(I)=RHFCN(T(I))+SUM
      IF((IER .EQ. 0) .AND. (EP .GT. EPS)) IER=4
      IF((IER .EQ. 1) .AND. (EP .GT. ERROR)) IER=5
      IF((IER .EQ. 3) .AND. (EP .GT. EPS)) IER=6
      EP=SAVEP
      RETURN
      END
      SUBROUTINE ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,
     *   KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,IFLG)
C
C   THIS ROUTINE CALCULATES ONE ITERATE XM GIVEN THE INITIAL GUESS
C   XMZ. THE ROUTINE IS DIVIDED ACCORDING TO WHETHER OR NOT
C   M .GT. NUPPER.
C
      REAL KERNEL,KMM,KMN,KNM,IMKNN,LUFACT
      DIMENSION TN(N),WN(N),TM(M),WM(M),XM(M),XMZ(M),KMM(NUP,NUP),
     *   KMN(NUP,NHALF),KNM(NHALF,NUP),RHS(M),IMKNN(NUP,NUP),
     *   LUFACT(NUP,NUP),R(M),RH(N),DELN(N)
      EXTERNAL KERNEL
C
C   M .GT. NUPPER MEANS THAT THE MATRICES KMM,KMN,KNM CAN NO LONGER
C   BE STORED DUE TO LACK OF SPACE.
      IF (M .GT. NUP) GO TO 13
      IF(IFLG .EQ. 1) GO TO 3
C   IF IFLG=0, THEN THE MATRICES KMM AND KNM MUST BE COMPUTED
C   AND STORED.
      DO 2 J=1,M
      DO 1 I=1,M
1     KMM(I,J)=WM(J)*KERNEL(TM(I),TM(J))
      DO 2 I=1,N
2     KNM(I,J)=WM(J)*KERNEL(TN(I),TM(J))
C   COMPUTE  RESIDUALS R(I)=RHFCN(TM(I))-XMZ(I)+KM(TM(I))*XMZ(I)
3     DO 5 I=1,M
      SUM=0.0
      DO 4 J=1,M
4     SUM=SUM+KMM(I,J)*XMZ(J)
5     R(I)=RHS(I)-(XMZ(I)-SUM)
C
C   COMPUTE RH=KM*R AT ALL TN(I).
      DO 7 I=1,N
      RH(I)=0.0
      DO 7 J=1,M
7     RH(I)=RH(I)+KNM(I,J)*R(J)
C   CALCULATE DELN=((I-KN)**(-1))*KM*R AT ALL TN(I).
C
C*******************************************************************
C                                                                  *
      CALL LNSYS(IMKNN,LUFACT,NUP,N,RH,DELN,4,IND)
C                                                                  *
C   SEE THE ORIGINAL REFERENCE IN IEGS.                            *
C*******************************************************************
C
C   CALCULATE NEW XM.
      DO 12 I=1,M
      SUM=0.0
      DO 10 J=1,M
10    SUM=SUM+KMM(I,J)*R(J)
      DO 11 J=1,N
11    SUM=SUM+KMN(I,J)*DELN(J)
12    XM(I)=SUM+R(I)+XMZ(I)
      RETURN
C   ENTRANCE WHEN M .GT. NUP.
C   CALCULATE RESIDUALS.
13    DO 15 I=1,M
      SUM=0.0
      DO 14 J=1,M
14    SUM=SUM+WM(J)*KERNEL(TM(I),TM(J))*XMZ(J)
15    R(I)=RHS(I)-(XMZ(I)-SUM)
C   CALCULATE RH=KM*R.
      DO 17 I=1,N
      RH(I)=0.0
      DO 17 J=1,M
17    RH(I)=RH(I)+WM(J)*KERNEL(TN(I),TM(J))*R(J)
C
C*******************************************************************
C                                                                  *
      CALL LNSYS(IMKNN,LUFACT,NUP,N,RH,DELN,4,IND)
C                                                                  *
C   SEE THE ORIGINAL REFERENCE IN IEGS.                            *
C*******************************************************************
C
C   CALCULATE XM.
      DO 22 I=1,M
      SUM=0.0
      DO 20 J=1,M
20    SUM=SUM+WM(J)*KERNEL(TM(I),TM(J))*R(J)
      DO 21 J=1,N
21    SUM=SUM+WN(J)*KERNEL(TM(I),TN(J))*DELN(J)
22    XM(I)=SUM+R(I)+XMZ(I)
      RETURN
      END
      SUBROUTINE LNSYS(A,D,M,N,B,X,OPTION,IERR)
C
C   SOLVE AX = B WHERE A IS A MATRIX OF ORDER N. M IS THE NUMBER OF
C   ROWS IN THE DIMENSION STATEMENT FOR A IN THE CALLING PROGRAM.
C
C   OPTION=1   COMPUTE AN LU DECOMPOSITION OF A AND STORE IT IN D.
C              STORE THE PIVOT INDICES IN PIVOT AND SOLVE AX = B.
C   OPTION=2   COMPUTE AN LU DECOMPOSITION OF A AND STORE IT IN D.
C              STORE THE PIVOT INDICES IN PIVOT AND SOLVE AX = B.
C              THEN COMPUTE THE RESIDUAL AND ONE CORRECTION. THE
C              CORRECTION IS STORED IN R, THE NEW VALUE X1 IN X,
C              THE RELATIVE ERROR
C                         NORM(X0-X1)/NORM(X1)
C              IN THE VARIABLE ERROR, AND THE RELATIVE RESIDUAL
C                         NORM(RESIDUAL)/NORM(B)
C              IN THE VARIABLE RELRSD. THESE VALUES CAN BE OBTAINED
C              USING THE COMMON/XXLIN/ GIVEN BELOW.
C   OPTION=3   SAME AS OPTION=1, EXCEPT THAT THE LU DECOMPOSITION
C              HAS ALREADY BEEN STORED IN D AND THE PIVOT INDICES
C              IN PIVOT.
C   OPTION=4   SAME AS OPTION=2, EXCEPT THAT THE LU DECOMPOSITION
C              HAS ALREADY BEEN STORED IN D AND THE PIVOT INDICES
C              IN PIVOT.
C
C   THE LU DECOMPOSITION IS OBTAINED USING SCALED PARTIAL PIVOTING.
C   FOR OPTIONS 1 AND 2, IERR IS A VARIABLE THAT REPORTS THE STATUS
C   OF THE RESULTS. IERR = 0 IF THE LU DECOMPOSITION IS OBTAINED.
C   OTHERWISE, IERR = -K WHEN THE K-TH ROW OF A CONTAINS ONLY ZEROS
C   OR IERR = K WHEN THE K-TH PIVOT ELEMENT IS 0.
C
C   IT IS ASSUMED THAT N .LE. 128. THIS ASSUMPTION MAY BE MODIFIED
C   BY CHANGING THE DIMENSION STATEMENTS FOR THE ARRAYS PIVOT, R,
C   AND SCALE. ALSO MODIFY THE DIMENSION STATEMENT FOR PIVOT IN THE
C   SUBROUTINE IEGS.
C
      REAL A(M,N),D(M,N),B(N),X(N)
      INTEGER OPTION,PIVOT(128)
      REAL NORMX,NORME,NORMB,NORMR,R(128),SCALE(128)
      COMMON /XXLIN/ ERROR,RELRSD,PIVOT
C
      NM1 = N - 1
      ISWIT = 1
      IF (OPTION .GT. 2) GO TO 100
C
      DO 11 I = 1,N
      SCALE(I) = 0.0
        DO 10 J = 1,N
        D(I,J) = A(I,J)
   10   SCALE(I) = SCALE(I) + ABS(D(I,J))
      IF (SCALE(I) .NE. 0.0) GO TO 11
      IERR = -I
      RETURN
   11 CONTINUE
C
C             OBTAIN THE LU DECOMPOSITION OF A
C
      IERR = 0
      DO 43 K = 1,NM1
      C = ABS(D(K,K))/SCALE(K)
      L = K
      KP1 = K + 1
        DO 20 I = KP1,N
        T = ABS(D(I,K))/SCALE(I)
        IF (T .LE. C) GO TO 20
        C = T
        L = I
   20   CONTINUE
C
      IF (C .NE. 0.0) GO TO 30
      IERR = K
      RETURN
C
C     INTERCHANGE ROWS K AND L
C
   30 PIVOT(K) = L
      IF (K .EQ. L) GO TO 40
        DO 31 J = K,N
        T = D(K,J)
        D(K,J) = D(L,J)
   31   D(L,J) = T
      T = SCALE(K)
      SCALE(K) = SCALE(L)
      SCALE(L) = T
C
C     ELIMINATE THE K-TH UNKNOWN BELOW THE DIAGONAL
C
   40   DO 42 I = KP1,N
        D(I,K) = D(I,K)/D(K,K)
        T = D(I,K)
          DO 41 J = KP1,N
   41     D(I,J) = D(I,J) - T*D(K,J)
   42   CONTINUE
   43 CONTINUE
C
      IF (D(N,N) .NE. 0.0) GO TO 100
      IERR = N
      RETURN
C
C               STORE B IN R AND SET X = 0
C
  100 DO 110 I = 1,N
      R(I) = B(I)
  110 X(I) = 0.0
      GO TO 200
C
C             COMPUTE THE RESIDUAL R = B - AX
C
  120 DO 131 I = 1,N
      SUM = 0.0
        DO 130 J = 1,N
  130   SUM = SUM + A(I,J)*X(J)
  131 R(I) = B(I) - SUM
C
      NORMB = 0.0
      NORMR = 0.0
      DO 140 I = 1,N
      NORMB = AMAX1(NORMB,ABS(B(I)))
  140 NORMR = AMAX1(NORMR,ABS(R(I)))
      RELRSD = 0.0
      IF (NORMB .NE. 0.0) RELRSD = NORMR/NORMB
      ISWIT = 2
C
C             SOLVE LZ = R AND STORE Z IN R
C
  200 DO 212 K = 1,NM1
      L = PIVOT(K)
      IF (K .EQ. L) GO TO 210
      T = R(K)
      R(K) = R(L)
      R(L) = T
  210 KP1 = K + 1
        DO 211 I = KP1,N
  211   R(I) = R(I) - D(I,K)*R(K)
  212 CONTINUE
C
C      SOLVE UE = R, STORE E IN R, AND SET X = X + E
C
      R(N) = R(N)/D(N,N)
      X(N) = X(N) + R(N)
      DO 221 NMI = 1,NM1
      I = N - NMI
      IP1 = I + 1
      SUM = 0.0
        DO 220 J = IP1,N
  220   SUM = SUM + D(I,J)*R(J)
      R(I) = (R(I) - SUM)/D(I,I)
  221 X(I) = X(I) + R(I)
C
      GO TO (300,230,300,230),OPTION
  230 IF (ISWIT .EQ. 1) GO TO 120
C
C             CALCULATE THE CORRECTION ERROR
C
      NORMX = 0.0
      NORME = 0.0
      DO 250 I = 1,N
      NORMX = AMAX1(NORMX,ABS(X(I)))
  250 NORME = AMAX1(NORME,ABS(R(I)))
      ERROR = 0.0
      IF (NORMX .NE. 0.0) ERROR = NORME/NORMX
  300 RETURN
      END
      SUBROUTINE ODE(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,WORK,IWORK)
C
C     SANDIA MATHEMATICAL PROGRAM LIBRARY
C     APPLIED MATHEMATICS DIVISION 2642
C     SANDIA LABORATORIES
C     ALBUQUERQUE, NEW MEXICO  87115
C     JANUARY 1976
C   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C   *                 ISSUED BY SANDIA LABORATORIES,
C   *                   A PRIME CONTRACTOR TO THE
C   *   UNITED STATES ENERGY RESEARCH AND DEVELOPMENT ADMINISTRATION
C   * * * * * * * * * * * * * *  NOTICE   * * * * * * * * * * * * * * *
C   * THIS REPORT WAS PREPARED AS AN ACCOUNT OF WORK SPONSORED BY THE
C   * UNITED STATES GOVERNMENT.  NEITHER THE UNITED STATES NOR THE
C   * UNITED STATES ENERGY RESEARCH AND DEVELOPMENT ADMINISTRATION,
C   * NOR ANY OF THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS,
C   * SUBCONTRACTORS, OR THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS
C   * OR IMPLIED, OR ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY
C   * FOR THE ACCURACY, COMPLETENESS OR USEFULNESS OF ANY INFORMATION,
C   * APPARATUS, PRODUCT OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS
C   * USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS.
C   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C   WRITTEN BY L. F. SHAMPINE AND M. K. GORDON
C
C   ABSTRACT
C
C   SUBROUTINE  ODE  INTEGRATES A SYSTEM OF  NEQN  FIRST ORDER
C   ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM
C             DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN))
C             Y(I) GIVEN AT  T .
C   THE SUBROUTINE INTEGRATES FROM  T  TO  TOUT .  ON RETURN THE
C   PARAMETERS IN THE CALL LIST ARE SET FOR CONTINUING THE INTEGRATION.
C   THE USER HAS ONLY TO DEFINE A NEW VALUE  TOUT  AND CALL  ODE  AGAIN.
C
C   THE DIFFERENTIAL EQUATIONS ARE ACTUALLY SOLVED BY A SUITE OF CODES
C   DE1,  STEP1, AND  INTRP .  ODE  ALLOCATES VIRTUAL STORAGE IN THE
C   ARRAYS  WORK  AND  IWORK  AND CALLS  DE1.  DE1 IS A SUPERVISOR WHICH
C   DIRECTS THE SOLUTION.  IT CALLS ON THE ROUTINES  STEP1 AND  INTRP
C   TO ADVANCE THE INTEGRATION AND TO INTERPOLATE AT OUTPUT POINTS.
C   STEP1 USES A MODIFIED DIVIDED DIFFERENCE FORM OF THE ADAMS PECE
C   FORMULAS AND LOCAL EXTRAPOLATION.  IT ADJUSTS THE ORDER AND STEP
C   SIZE TO CONTROL THE LOCAL ERROR PER UNIT STEP IN A GENERALIZED
C   SENSE.  NORMALLY EACH CALL TO  STEP1 ADVANCES THE SOLUTION ONE STEP
C   IN THE DIRECTION OF  TOUT .  FOR REASONS OF EFFICIENCY  DE1
C   INTEGRATES BEYOND  TOUT  INTERNALLY, THOUGH NEVER BEYOND
C   T+10*(TOUT-T), AND CALLS  INTRP  TO INTERPOLATE THE SOLUTION AT
C   TOUT .  AN OPTION IS PROVIDED TO STOP THE INTEGRATION AT  TOUT  BUT
C   IT SHOULD BE USED ONLY IF IT IS IMPOSSIBLE TO CONTINUE THE
C   INTEGRATION BEYOND  TOUT .
C
C   THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT,
C   COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS,  THE INITIAL
C   VALUE PROBLEM  BY L. F. SHAMPINE AND M. K. GORDON.
C
C   THE PARAMETERS REPRESENT...
C      F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES YP(I)=DY(I)/DT
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- SOLUTION VECTOR AT  T
C      T -- INDEPENDENT VARIABLE
C      TOUT -- POINT AT WHICH SOLUTION IS DESIRED
C      RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR LOCAL
C           ERROR TEST.  AT EACH STEP THE CODE REQUIRES
C             ABS(LOCAL ERROR) .LE. ABS(Y)*RELERR + ABSERR
C           FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION VECTORS
C      IFLAG -- INDICATES STATUS OF INTEGRATION
C      WORK(*),IWORK(*) -- ARRAYS TO HOLD INFORMATION INTERNAL TO CODE
C           WHICH IS NECESSARY FOR SUBSEQUENT CALLS
C
C   FIRST CALL TO ODE --
C
C   THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE ARRAYS
C   IN THE CALL LIST,
C      Y(NEQN), WORK(100+21*NEQN), IWORK(5),
C   DECLARE  F  IN AN EXTERNAL STATEMENT, SUPPLY THE SUBROUTINE
C   F(T,Y,YP) TO EVALUATE
C      DY(I)/DT = YP(I) = F(T,Y(1),Y(2),...,Y(NEQN))
C   AND INITIALIZE THE PARAMETERS...
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- VECTOR OF INITIAL CONDITIONS
C      T -- STARTING POINT OF INTEGRATION
C      TOUT -- POINT AT WHICH SOLUTION IS DESIRED
C      RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES
C      IFLAG -- +1,-1.  INDICATOR TO INITIALIZE THE CODE.  NORMAL INPUT
C           IS +1.  THE USER SHOULD SET IFLAG=-1 ONLY IF IT IS
C           IMPOSSIBLE TO CONTINUE THE INTEGRATION BEYOND  TOUT .
C   ALL PARAMETERS EXCEPT  F ,  NEQN  AND  TOUT  MAY BE ALTERED BY THE
C   CODE ON OUTPUT SO MUST BE VARIABLES IN THE CALLING PROGRAM.
C
C   OUTPUT FROM  ODE  --
C
C      NEQN -- UNCHANGED
C      Y(*) -- SOLUTION AT  T
C      T -- LAST POINT REACHED IN INTEGRATION.  NORMAL RETURN HAS
C           T = TOUT .
C      TOUT -- UNCHANGED
C      RELERR,ABSERR -- NORMAL RETURN HAS TOLERANCES UNCHANGED.  IFLAG=3
C           SIGNALS TOLERANCES INCREASED
C      IFLAG = 2 -- NORMAL RETURN.  INTEGRATION REACHED  TOUT
C            = 3 -- INTEGRATION DID NOT REACH  TOUT  BECAUSE ERROR
C                   TOLERANCES TOO SMALL.  RELERR ,  ABSERR  INCREASED
C                   APPROPRIATELY FOR CONTINUING
C            = 4 -- INTEGRATION DID NOT REACH  TOUT  BECAUSE MORE THAN
C                   MAXNUM STEPS NEEDED
C            = 5 -- INTEGRATION DID NOT REACH  TOUT  BECAUSE EQUATIONS
C                   APPEAR TO BE STIFF
C            = 6 -- INTEGRATION DID NOT REACH  TOUT  BECAUSE SOLUTION
C                   VANISHED MAKING PURE RELATIVE ERROR IMPOSSIBLE.
C                   MUST USE NON-ZERO  ABSERR  TO CONTINUE.
C            = 7 -- INVALID INPUT PARAMETERS (FATAL ERROR)
C           THE VALUE OF  IFLAG  IS RETURNED NEGATIVE WHEN THE INPUT
C           VALUE IS NEGATIVE AND THE INTEGRATION DOES NOT REACH  TOUT ,
C           I.E., -3, -4, -5, -6.
C      WORK(*),IWORK(*) -- INFORMATION GENERALLY OF NO INTEREST TO THE
C           USER BUT NECESSARY FOR SUBSEQUENT CALLS.
C
C   SUBSEQUENT CALLS TO  ODE --
C
C   SUBROUTINE  ODE  RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE
C   THE INTEGRATION.  IF THE INTEGRATION REACHED  TOUT , THE USER NEED
C   ONLY DEFINE A NEW  TOUT  AND CALL AGAIN.  IF THE INTEGRATION DID NOT
C   REACH  TOUT  AND THE USER WANTS TO CONTINUE, HE JUST CALLS AGAIN.
C   IN THE CASE  IFLAG=6 , THE USER MUST ALSO ALTER THE ERROR CRITERION.
C   THE OUTPUT VALUE OF  IFLAG  IS THE APPROPRIATE INPUT VALUE FOR
C   SUBSEQUENT CALLS.  THE ONLY SITUATION IN WHICH IT SHOULD BE ALTERED
C   IS TO STOP THE INTEGRATION INTERNALLY AT THE NEW  TOUT , I.E.,
C   CHANGE OUTPUT  IFLAG=2  TO INPUT  IFLAG=-2 .  ERROR TOLERANCES MAY
C   BE CHANGED BY THE USER BEFORE CONTINUING.  ALL OTHER PARAMETERS MUST
C   REMAIN UNCHANGED.
C
      LOGICAL START,PHASE1,NORND
      DIMENSION Y(NEQN),WORK(*),IWORK(5)
      EXTERNAL F
      DATA IALPHA,IBETA,ISIG,IV,IW,IG,IPHASE,IPSI,IX,IH,IHOLD,ISTART,
     1  ITOLD,IDELSN/1,13,25,38,50,62,75,76,88,89,90,91,92,93/
C
      IYY = 100
      IWT = IYY + NEQN
      IP = IWT + NEQN
      IYP = IP + NEQN
      IYPOUT = IYP + NEQN
      IPHI = IYPOUT + NEQN
      IF(IABS(IFLAG) .LT. 2  .OR.  IABS(IFLAG) .GT. 6) GO TO 1
      START = WORK(ISTART) .GT. 0.0
      PHASE1 = WORK(IPHASE) .GT. 0.0
      NORND = IWORK(2) .NE. -1
 1    CALL DE1(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,WORK(IYY),
     1  WORK(IWT),WORK(IP),WORK(IYP),WORK(IYPOUT),WORK(IPHI),
     2  WORK(IALPHA),WORK(IBETA),WORK(ISIG),WORK(IV),WORK(IW),WORK(IG),
     3  PHASE1,WORK(IPSI),WORK(IX),WORK(IH),WORK(IHOLD),START,
     4  WORK(ITOLD),WORK(IDELSN),IWORK(1),NORND,IWORK(3),IWORK(4),
     5  IWORK(5))
      WORK(ISTART) = -1.0
      IF(START) WORK(ISTART) = 1.0
      WORK(IPHASE) = -1.0
      IF(PHASE1) WORK(IPHASE) = 1.0
      IWORK(2) = -1
      IF(NORND) IWORK(2) = 1
      RETURN
      END
      SUBROUTINE DE1(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,
     1  YY,WT,P,YP,YPOUT,PHI,ALPHA,BETA,SIG,V,W,G,PHASE1,PSI,X,H,HOLD,
     2  START,TOLD,DELSGN,NS,NORND,K,KOLD,ISNOLD)
C
C   ODE  MERELY ALLOCATES STORAGE FOR  DE1 TO RELIEVE THE USER OF THE
C   INCONVENIENCE OF A LONG CALL LIST.  CONSEQUENTLY  DE1 IS USED AS
C   DESCRIBED IN THE COMMENTS FOR  ODE .
C
C   THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT,
C   COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS,  THE INITIAL
C   VALUE PROBLEM  BY L. F. SHAMPINE AND M. K. GORDON.
C
      LOGICAL STIFF,CRASH,START,PHASE1,NORND
      DIMENSION Y(NEQN),YY(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),
     1  YPOUT(NEQN),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13)
      EXTERNAL F
C
C   THE CONSTANT  MAXNUM  IS THE MAXIMUM NUMBER OF STEPS ALLOWED IN ONE
C   CALL TO  DE1.  THE USER MAY CHANGE THIS LIMIT BY ALTERING THE
C   FOLLOWING STATEMENT
C
      DATA MAXNUM/500/
C
C   ****** U IS A MACHINE DEPENDENT PARAMETER. U IS THE SMALLEST
C          POSITIVE NUMBER FOR WHICH 1.0 + U .GT. 1.0.
C
      U = SPMPAR(1)
      FOURU = 4.0*U
C
C            ***            ***            ***
C
C   TEST FOR IMPROPER PARAMETERS
C
      IF(NEQN .LT. 1) GO TO 10
      IF(T .EQ. TOUT) GO TO 10
      IF(RELERR .LT. 0.0  .OR.  ABSERR .LT. 0.0) GO TO 10
      EPS = AMAX1(RELERR,ABSERR)
      IF(EPS .LE. 0.0) GO TO 10
      IF(IFLAG .EQ. 0) GO TO 10
      ISN = ISIGN(1,IFLAG)
      IFLAG = IABS(IFLAG)
      IF(IFLAG .EQ. 1) GO TO 20
      IF(T .NE. TOLD) GO TO 10
      IF(IFLAG .GE. 2  .AND.  IFLAG .LE. 5) GO TO 20
      IF(IFLAG .EQ. 6  .AND.  ABSERR .GT. 0.0) GO TO 20
 10   IFLAG = 7
      RETURN
C
C   ON EACH CALL SET INTERVAL OF INTEGRATION AND COUNTER FOR NUMBER OF
C   STEPS.  ADJUST INPUT ERROR TOLERANCES TO DEFINE WEIGHT VECTOR FOR
C   SUBROUTINE  STEP1
C
 20   DEL = TOUT - T
      ABSDEL = ABS(DEL)
      TEND = T + 10.0*DEL
      IF(ISN .LT. 0) TEND = TOUT
      NOSTEP = 0
      KLE4 = 0
      STIFF = .FALSE.
      RELEPS = RELERR/EPS
      ABSEPS = ABSERR/EPS
      IF(IFLAG .EQ. 1) GO TO 30
      IF(ISNOLD .LT. 0) GO TO 30
      IF(DELSGN*DEL .GT. 0.0) GO TO 50
C
C   ON START AND RESTART ALSO SET WORK VARIABLES X AND YY(*), STORE THE
C   DIRECTION OF INTEGRATION AND INITIALIZE THE STEP SIZE
C
 30   START = .TRUE.
      X = T
      DO 40 L = 1,NEQN
 40     YY(L) = Y(L)
      DELSGN = SIGN(1.0,DEL)
      H = SIGN(AMAX1(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X)
C
C   IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN
C
 50   IF(ABS(X-T) .LT. ABSDEL) GO TO 60
      CALL INTRP(X,YY,TOUT,Y,YPOUT,NEQN,KOLD,PHI,PSI)
      IFLAG = 2
      T = TOUT
      TOLD = T
      ISNOLD = ISN
      RETURN
C
C   IF CANNOT GO PAST OUTPUT POINT AND SUFFICIENTLY CLOSE,
C   EXTRAPOLATE AND RETURN
C
 60   IF(ISN .GT. 0  .OR.  ABS(TOUT-X) .GE. FOURU*ABS(X)) GO TO 80
      H = TOUT - X
      CALL F(X,YY,YP)
      DO 70 L = 1,NEQN
 70     Y(L) = YY(L) + H*YP(L)
      IFLAG = 2
      T = TOUT
      TOLD = T
      ISNOLD = ISN
      RETURN
C
C   TEST FOR TOO MANY STEPS
C
 80   IF(NOSTEP .LT. MAXNUM) GO TO 100
      IFLAG = ISN*4
      IF(STIFF) IFLAG = ISN*5
      DO 90 L = 1,NEQN
 90     Y(L) = YY(L)
      T = X
      TOLD = T
      ISNOLD = 1
      RETURN
C
C   LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP
C
 100  H = SIGN(AMIN1(ABS(H),ABS(TEND-X)),H)
      DO 110 L = 1,NEQN
        WT(L) = RELEPS*ABS(YY(L)) + ABSEPS
        IF(WT(L) .LE. 0.0) GO TO 140
 110    CONTINUE
      CALL STEP1(F,NEQN,YY,X,H,EPS,WT,START,
     1  HOLD,K,KOLD,CRASH,PHI,P,YP,PSI,
     2  ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND)
C
C   TEST FOR TOLERANCES TOO SMALL
C
      IF(.NOT.CRASH) GO TO 130
      IFLAG = ISN*3
      RELERR = EPS*RELEPS
      ABSERR = EPS*ABSEPS
      DO 120 L = 1,NEQN
 120    Y(L) = YY(L)
      T = X
      TOLD = T
      ISNOLD = 1
      RETURN
C
C   AUGMENT COUNTER ON NUMBER OF STEPS AND TEST FOR STIFFNESS
C
 130  NOSTEP = NOSTEP + 1
      KLE4 = KLE4 + 1
      IF(KOLD .GT. 4) KLE4 = 0
      IF(KLE4 .GE. 50) STIFF = .TRUE.
      GO TO 50
C
C   RELATIVE ERROR CRITERION INAPPROPRIATE
C
 140  IFLAG = ISN*6
      DO 150 L = 1,NEQN
 150    Y(L) = YY(L)
      T = X
      TOLD = T
      ISNOLD = 1
      RETURN
      END
      SUBROUTINE STEP1(F,NEQN,Y,X,H,EPS,WT,START,
     1 HOLD,K,KOLD,CRASH,PHI,P,YP,PSI,
     2 ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND)
C
C   WRITTEN BY L. F. SHAMPINE AND M. K. GORDON
C
C   ABSTRACT
C
C   SUBROUTINE  STEP1  IS NORMALLY USED INDIRECTLY THROUGH SUBROUTINE
C   ODE .  BECAUSE  ODE  SUFFICES FOR MOST PROBLEMS AND IS MUCH EASIER
C   TO USE, USING IT SHOULD BE CONSIDERED BEFORE USING  STEP1  ALONE.
C
C   SUBROUTINE STEP1 INTEGRATES A SYSTEM OF  NEQN  FIRST ORDER ORDINARY
C   DIFFERENTIAL EQUATIONS ONE STEP, NORMALLY FROM X TO X+H, USING A
C   MODIFIED DIVIDED DIFFERENCE FORM OF THE ADAMS PECE FORMULAS.  LOCAL
C   EXTRAPOLATION IS USED TO IMPROVE ABSOLUTE STABILITY AND ACCURACY.
C   THE CODE ADJUSTS ITS ORDER AND STEP SIZE TO CONTROL THE LOCAL ERROR
C   PER UNIT STEP IN A GENERALIZED SENSE.  SPECIAL DEVICES ARE INCLUDED
C   TO CONTROL ROUNDOFF ERROR AND TO DETECT WHEN THE USER IS REQUESTING
C   TOO MUCH ACCURACY.
C
C   THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT,
C   COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS,  THE INITIAL
C   VALUE PROBLEM  BY L. F. SHAMPINE AND M. K. GORDON.
C
C
C   THE PARAMETERS REPRESENT...
C      F -- SUBROUTINE TO EVALUATE DERIVATIVES
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- SOLUTION VECTOR AT X
C      X -- INDEPENDENT VARIABLE
C      H -- APPROPRIATE STEP SIZE FOR NEXT STEP.  NORMALLY DETERMINED BY
C           CODE
C      EPS -- LOCAL ERROR TOLERANCE
C      WT(*) -- VECTOR OF WEIGHTS FOR ERROR CRITERION
C      START -- LOGICAL VARIABLE SET .TRUE. FOR FIRST STEP,  .FALSE.
C           OTHERWISE
C      HOLD -- STEP SIZE USED FOR LAST SUCCESSFUL STEP
C      K -- APPROPRIATE ORDER FOR NEXT STEP (DETERMINED BY CODE)
C      KOLD -- ORDER USED FOR LAST SUCCESSFUL STEP
C      CRASH -- LOGICAL VARIABLE SET .TRUE. WHEN NO STEP CAN BE TAKEN,
C           .FALSE. OTHERWISE.
C      YP(*) -- DERIVATIVE OF SOLUTION VECTOR AT  X  AFTER SUCCESSFUL
C           STEP
C   THE ARRAYS  PHI, PSI  ARE REQUIRED FOR THE INTERPOLATION SUBROUTINE
C   INTRP .  THE ARRAY  P  IS INTERNAL TO THE CODE.  THE REMAINING NINE
C   VARIABLES AND ARRAYS ARE INCLUDED IN THE CALL LIST ONLY TO ELIMINATE
C   LOCAL RETENTION OF VARIABLES BETWEEN CALLS.
C
C   INPUT TO STEP1
C
C      FIRST CALL --
C
C   THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR ALL ARRAYS
C   IN THE CALL LIST, NAMELY
C
C     DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12),
C    1  ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13)
C
C   THE USER MUST ALSO DECLARE  START ,  CRASH ,  PHASE1  AND  NORND
C   LOGICAL VARIABLES AND  F  AN EXTERNAL SUBROUTINE, SUPPLY THE
C   SUBROUTINE  F(X,Y,YP)  TO EVALUATE
C      DY(I)/DX = YP(I) = F(X,Y(1),Y(2),...,Y(NEQN))
C   AND INITIALIZE ONLY THE FOLLOWING PARAMETERS...
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- VECTOR OF INITIAL VALUES OF DEPENDENT VARIABLES
C      X -- INITIAL VALUE OF THE INDEPENDENT VARIABLE
C      H -- NOMINAL STEP SIZE INDICATING DIRECTION OF INTEGRATION
C           AND MAXIMUM SIZE OF STEP.  MUST BE VARIABLE
C      EPS -- LOCAL ERROR TOLERANCE PER STEP.  MUST BE VARIABLE
C      WT(*) -- VECTOR OF NON-ZERO WEIGHTS FOR ERROR CRITERION
C      START -- .TRUE.
C
C   STEP1  REQUIRES THAT THE L2 NORM OF THE VECTOR WITH COMPONENTS
C   LOCAL ERROR(L)/WT(L)  BE LESS THAN  EPS  FOR A SUCCESSFUL STEP.  THE
C   ARRAY  WT  ALLOWS THE USER TO SPECIFY AN ERROR TEST APPROPRIATE
C   FOR HIS PROBLEM.  FOR EXAMPLE,
C      WT(L) = 1.0  SPECIFIES ABSOLUTE ERROR,
C            = ABS(Y(L))  ERROR RELATIVE TO THE MOST RECENT VALUE OF THE
C                 L-TH COMPONENT OF THE SOLUTION,
C            = ABS(YP(L))  ERROR RELATIVE TO THE MOST RECENT VALUE OF
C                 THE L-TH COMPONENT OF THE DERIVATIVE,
C            = AMAX1(WT(L),ABS(Y(L)))  ERROR RELATIVE TO THE LARGEST
C                 MAGNITUDE OF L-TH COMPONENT OBTAINED SO FAR,
C            = ABS(Y(L))*RELERR/EPS + ABSERR/EPS  SPECIFIES A MIXED
C                 RELATIVE-ABSOLUTE TEST WHERE  RELERR  IS RELATIVE
C                 ERROR,  ABSERR  IS ABSOLUTE ERROR AND  EPS =
C                 AMAX1(RELERR,ABSERR) .
C
C      SUBSEQUENT CALLS --
C
C   SUBROUTINE  STEP1  IS DESIGNED SO THAT ALL INFORMATION NEEDED TO
C   CONTINUE THE INTEGRATION, INCLUDING THE STEP SIZE  H  AND THE ORDER
C   K , IS RETURNED WITH EACH STEP.  WITH THE EXCEPTION OF THE STEP
C   SIZE, THE ERROR TOLERANCE, AND THE WEIGHTS, NONE OF THE PARAMETERS
C   SHOULD BE ALTERED.  THE ARRAY  WT  MUST BE UPDATED AFTER EACH STEP
C   TO MAINTAIN RELATIVE ERROR TESTS LIKE THOSE ABOVE.  NORMALLY THE
C   INTEGRATION IS CONTINUED JUST BEYOND THE DESIRED ENDPOINT AND THE
C   SOLUTION INTERPOLATED THERE WITH SUBROUTINE  INTRP .  IF IT IS
C   IMPOSSIBLE TO INTEGRATE BEYOND THE ENDPOINT, THE STEP SIZE MAY BE
C   REDUCED TO HIT THE ENDPOINT SINCE THE CODE WILL NOT TAKE A STEP
C   LARGER THAN THE  H  INPUT.  CHANGING THE DIRECTION OF INTEGRATION,
C   I.E., THE SIGN OF  H , REQUIRES THE USER SET  START = .TRUE. BEFORE
C   CALLING  STEP1  AGAIN.  THIS IS THE ONLY SITUATION IN WHICH  START
C   SHOULD BE ALTERED.
C
C   OUTPUT FROM STEP1
C
C      SUCCESSFUL STEP --
C
C   THE SUBROUTINE RETURNS AFTER EACH SUCCESSFUL STEP WITH  START  AND
C   CRASH  SET .FALSE. .  X  REPRESENTS THE INDEPENDENT VARIABLE
C   ADVANCED ONE STEP OF LENGTH  HOLD  FROM ITS VALUE ON INPUT AND  Y
C   THE SOLUTION VECTOR AT THE NEW VALUE OF  X .  ALL OTHER PARAMETERS
C   REPRESENT INFORMATION CORRESPONDING TO THE NEW  X  NEEDED TO
C   CONTINUE THE INTEGRATION.
C
C      UNSUCCESSFUL STEP --
C
C   WHEN THE ERROR TOLERANCE IS TOO SMALL FOR THE MACHINE PRECISION,
C   THE SUBROUTINE RETURNS WITHOUT TAKING A STEP AND  CRASH = .TRUE. .
C   AN APPROPRIATE STEP SIZE AND ERROR TOLERANCE FOR CONTINUING ARE
C   ESTIMATED AND ALL OTHER INFORMATION IS RESTORED AS UPON INPUT
C   BEFORE RETURNING.  TO CONTINUE WITH THE LARGER TOLERANCE, THE USER
C   JUST CALLS THE CODE AGAIN.  A RESTART IS NEITHER REQUIRED NOR
C   DESIRABLE.
C
      LOGICAL START,CRASH,PHASE1,NORND
      DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12),
     1  ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13)
      DIMENSION TWO(13),GSTR(13)
      EXTERNAL F
C
      DATA TWO(1)/2.0/, TWO(2)/4.0/, TWO(3)/8.0/, TWO(4)/16.0/,
     1     TWO(5)/32.0/, TWO(6)/64.0/, TWO(7)/128.0/, TWO(8)/256.0/,
     2     TWO(9)/512.0/, TWO(10)/1024.0/, TWO(11)/2048.0/,
     3     TWO(12)/4096.0/, TWO(13)/8192.0/
      DATA GSTR(1)/0.500/, GSTR(2)/0.0833/, GSTR(3)/0.0417/,
     1     GSTR(4)/0.0264/, GSTR(5)/0.0188/, GSTR(6)/0.0143/,
     2     GSTR(7)/0.0114/, GSTR(8)/0.00936/, GSTR(9)/0.00789/,
     3     GSTR(10)/0.00679/, GSTR(11)/0.00592/, GSTR(12)/0.00524/,
     4     GSTR(13)/0.00468/
C
C   ****** U IS A MACHINE DEPENDENT PARAMETER. IT IS THE SMALLEST
C          POSITIVE NUMBER FOR WHICH 1.0 + U .GT. 1.0.
C
      U = SPMPAR(1)
      TWOU = 2.0*U
      FOURU = 4.0*U
C
C       ***     BEGIN BLOCK 0     ***
C
C   CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE
C   PRECISION.  IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A
C   STARTING STEP SIZE.
C
C                   ***
C
C   IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE
C
      CRASH = .TRUE.
      IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5
      H = SIGN(FOURU*ABS(X),H)
      RETURN
 5    P5EPS = 0.5*EPS
C
C   IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE
C
      ROUND = 0.0
      DO 10 L = 1,NEQN
 10     ROUND = ROUND + (Y(L)/WT(L))**2
      ROUND = TWOU*SQRT(ROUND)
      IF(P5EPS .GE. ROUND) GO TO 15
      EPS = 2.0*ROUND*(1.0 + FOURU)
      RETURN
 15   CRASH = .FALSE.
      G(1) = 1.0
      G(2) = 0.5
      SIG(1) = 1.0
      IF(.NOT.START) GO TO 99
C
C   INITIALIZE.  COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP
C
      CALL F(X,Y,YP)
      SUM = 0.0
      DO 20 L = 1,NEQN
        PHI(L,1) = YP(L)
        PHI(L,2) = 0.0
 20     SUM = SUM + (YP(L)/WT(L))**2
      SUM = SQRT(SUM)
      ABSH = ABS(H)
      IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM)
      H = SIGN(AMAX1(ABSH,FOURU*ABS(X)),H)
      HOLD = 0.0
      K = 1
      KOLD = 0
      START = .FALSE.
      PHASE1 = .TRUE.
      NORND = .TRUE.
      IF(P5EPS .GT. 100.0*ROUND) GO TO 99
      NORND = .FALSE.
      DO 25 L = 1,NEQN
 25     PHI(L,15) = 0.0
 99   IFAIL = 0
C
C       ***     END BLOCK 0     ***
C
C       ***     BEGIN BLOCK 1     ***
C
C   COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP.  AVOID COMPUTING
C   THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED.
C
C                   ***
C
 100  KP1 = K+1
      KP2 = K+2
      KM1 = K-1
      KM2 = K-2
C
C   NS IS THE NUMBER OF STEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT
C   ONE.  WHEN K.LT.NS, NO COEFFICIENTS CHANGE
C
      IF(H .NE. HOLD) NS = 0
      IF (NS.LE.KOLD) NS = NS+1
      NSP1 = NS+1
      IF (K .LT. NS) GO TO 199
C
C   COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH
C   ARE CHANGED
C
      BETA(NS) = 1.0
      REALNS = NS
      ALPHA(NS) = 1.0/REALNS
      TEMP1 = H*REALNS
      SIG(NSP1) = 1.0
      IF(K .LT. NSP1) GO TO 110
      DO 105 I = NSP1,K
        IM1 = I-1
        TEMP2 = PSI(IM1)
        PSI(IM1) = TEMP1
        BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2
        TEMP1 = TEMP2 + H
        ALPHA(I) = H/TEMP1
        REALI = I
 105    SIG(I+1) = REALI*ALPHA(I)*SIG(I)
 110  PSI(K) = TEMP1
C
C   COMPUTE COEFFICIENTS G(*)
C
C   INITIALIZE V(*) AND SET W(*).
C
      IF(NS .GT. 1) GO TO 120
      DO 115 IQ = 1,K
        TEMP3 = IQ*(IQ+1)
        V(IQ) = 1.0/TEMP3
 115    W(IQ) = V(IQ)
      GO TO 140
C
C   IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*)
C
 120  IF(K .LE. KOLD) GO TO 130
      TEMP4 = K*KP1
      V(K) = 1.0/TEMP4
      NSM2 = NS-2
      IF(NSM2 .LT. 1) GO TO 130
      DO 125 J = 1,NSM2
        I = K-J
 125    V(I) = V(I) - ALPHA(J+1)*V(I+1)
C
C   UPDATE V(*) AND SET W(*)
C
 130  LIMIT1 = KP1 - NS
      TEMP5 = ALPHA(NS)
      DO 135 IQ = 1,LIMIT1
        V(IQ) = V(IQ) - TEMP5*V(IQ+1)
 135    W(IQ) = V(IQ)
      G(NSP1) = W(1)
C
C   COMPUTE THE G(*) IN THE WORK VECTOR W(*)
C
 140  NSP2 = NS + 2
      IF(KP1 .LT. NSP2) GO TO 199
      DO 150 I = NSP2,KP1
        LIMIT2 = KP2 - I
        TEMP6 = ALPHA(I-1)
        DO 145 IQ = 1,LIMIT2
 145      W(IQ) = W(IQ) - TEMP6*W(IQ+1)
 150    G(I) = W(1)
 199    CONTINUE
C
C       ***     END BLOCK 1     ***
C
C       ***     BEGIN BLOCK 2     ***
C
C   PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED
C   SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K,
C   K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED.
C
C                   ***
C
C   CHANGE PHI TO PHI STAR
C
      IF(K .LT. NSP1) GO TO 215
      DO 210 I = NSP1,K
        TEMP1 = BETA(I)
        DO 205 L = 1,NEQN
 205      PHI(L,I) = TEMP1*PHI(L,I)
 210    CONTINUE
C
C   PREDICT SOLUTION AND DIFFERENCES
C
 215  DO 220 L = 1,NEQN
        PHI(L,KP2) = PHI(L,KP1)
        PHI(L,KP1) = 0.0
 220    P(L) = 0.0
      DO 230 J = 1,K
        I = KP1 - J
        IP1 = I+1
        TEMP2 = G(I)
        DO 225 L = 1,NEQN
          P(L) = P(L) + TEMP2*PHI(L,I)
 225      PHI(L,I) = PHI(L,I) + PHI(L,IP1)
 230    CONTINUE
      IF(NORND) GO TO 240
      DO 235 L = 1,NEQN
        TAU = H*P(L) - PHI(L,15)
        P(L) = Y(L) + TAU
 235    PHI(L,16) = (P(L) - Y(L)) - TAU
      GO TO 250
 240  DO 245 L = 1,NEQN
 245    P(L) = Y(L) + H*P(L)
 250  XOLD = X
      X = X + H
      ABSH = ABS(H)
      CALL F(X,P,YP)
C
C   ESTIMATE ERRORS AT ORDERS K,K-1,K-2
C
      ERKM2 = 0.0
      ERKM1 = 0.0
      ERK = 0.0
      DO 265 L = 1,NEQN
        TEMP3 = 1.0/WT(L)
        TEMP4 = YP(L) - PHI(L,1)
        IF(KM2)265,260,255
 255    ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2
 260    ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2
 265    ERK = ERK + (TEMP4*TEMP3)**2
      IF(KM2)280,275,270
 270  ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2)
 275  ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1)
 280  TEMP5 = ABSH*SQRT(ERK)
      ERR = TEMP5*(G(K)-G(KP1))
      ERK = TEMP5*SIG(KP1)*GSTR(K)
      KNEW = K
C
C   TEST IF ORDER SHOULD BE LOWERED
C
      IF(KM2)299,290,285
 285  IF(AMAX1(ERKM1,ERKM2) .LE. ERK) KNEW = KM1
      GO TO 299
 290  IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1
C
C   TEST IF STEP SUCCESSFUL
C
 299  IF(ERR .LE. EPS) GO TO 400
C
C       ***     END BLOCK 2     ***
C
C       ***     BEGIN BLOCK 3     ***
C
C   THE STEP IS UNSUCCESSFUL.  RESTORE  X, PHI(*,*), PSI(*) .
C   IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE.  IF STEP FAILS MORE
C   THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE.  DOUBLE ERROR
C   TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE
C   PRECISION.
C                   ***
C
C   RESTORE X, PHI(*,*) AND PSI(*)
C
      PHASE1 = .FALSE.
      X = XOLD
      DO 310 I = 1,K
        TEMP1 = 1.0/BETA(I)
        IP1 = I+1
        DO 305 L = 1,NEQN
 305      PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1))
 310    CONTINUE
      IF(K .LT. 2) GO TO 320
      DO 315 I = 2,K
 315    PSI(I-1) = PSI(I) - H
C
C   ON THIRD FAILURE, SET ORDER TO ONE.  THEREAFTER, USE OPTIMAL STEP
C   SIZE
C
 320  IFAIL = IFAIL + 1
      TEMP2 = 0.5
      IF(IFAIL - 3) 335,330,325
 325  IF(P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK)
 330  KNEW = 1
 335  H = TEMP2*H
      K = KNEW
      IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340
      CRASH = .TRUE.
      H = SIGN(FOURU*ABS(X),H)
      EPS = EPS + EPS
      RETURN
 340  GO TO 100
C
C       ***     END BLOCK 3     ***
C
C       ***     BEGIN BLOCK 4     ***
C
C   THE STEP IS SUCCESSFUL.  CORRECT THE PREDICTED SOLUTION, EVALUATE
C   THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE
C   DIFFERENCES.  DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP.
C
C                   ***
 400  KOLD = K
      HOLD = H
C
C   CORRECT AND EVALUATE
C
      TEMP1 = H*G(KP1)
      IF(NORND) GO TO 410
      DO 405 L = 1,NEQN
        RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16)
        Y(L) = P(L) + RHO
 405    PHI(L,15) = (Y(L) - P(L)) - RHO
      GO TO 420
 410  DO 415 L = 1,NEQN
 415    Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1))
 420  CALL F(X,Y,YP)
C
C   UPDATE DIFFERENCES FOR NEXT STEP
C
      DO 425 L = 1,NEQN
        PHI(L,KP1) = YP(L) - PHI(L,1)
 425    PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2)
      DO 435 I = 1,K
        DO 430 L = 1,NEQN
 430      PHI(L,I) = PHI(L,I) + PHI(L,KP1)
 435    CONTINUE
C
C   ESTIMATE ERROR AT ORDER K+1 UNLESS...
C     IN FIRST PHASE WHEN ALWAYS RAISE ORDER,
C     ALREADY DECIDED TO LOWER ORDER,
C     STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE
C
      ERKP1 = 0.0
      IF(KNEW .EQ. KM1  .OR.  K .EQ. 12) PHASE1 = .FALSE.
      IF(PHASE1) GO TO 450
      IF(KNEW .EQ. KM1) GO TO 455
      IF(KP1 .GT. NS) GO TO 460
      DO 440 L = 1,NEQN
 440    ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2
      ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1)
C
C   USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER
C   FOR NEXT STEP
C
      IF(K .GT. 1) GO TO 445
      IF(ERKP1 .GE. 0.5*ERK) GO TO 460
      GO TO 450
 445  IF(ERKM1 .LE. AMIN1(ERK,ERKP1)) GO TO 455
      IF(ERKP1 .GE. ERK  .OR.  K .EQ. 12) GO TO 460
C
C   HERE ERKP1 .LT. ERK .LT. AMAX1(ERKM1,ERKM2) ELSE ORDER WOULD HAVE
C   BEEN LOWERED IN BLOCK 2.  THUS ORDER IS TO BE RAISED
C
C   RAISE ORDER
C
 450  K = KP1
      ERK = ERKP1
      GO TO 460
C
C   LOWER ORDER
C
 455  K = KM1
      ERK = ERKM1
C
C   WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP
C
 460  HNEW = H + H
      IF(PHASE1) GO TO 465
      IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465
      HNEW = H
      IF(P5EPS .GE. ERK) GO TO 465
      TEMP2 = K+1
      R = (P5EPS/ERK)**(1.0/TEMP2)
      HNEW = ABSH*AMAX1(0.5,AMIN1(0.9,R))
      HNEW = SIGN(AMAX1(HNEW,FOURU*ABS(X)),H)
 465  H = HNEW
      RETURN
C
C       ***     END BLOCK 4     ***
C
      END
      SUBROUTINE INTRP(X,Y,XOUT,YOUT,YPOUT,NEQN,KOLD,PHI,PSI)
C
C   WRITTEN BY L. F. SHAMPINE AND M. K. GORDON
C
C   ABSTRACT
C
C   THE METHODS IN SUBROUTINE  STEP1  APPROXIMATE THE SOLUTION NEAR  X
C   BY A POLYNOMIAL.  SUBROUTINE  INTRP  APPROXIMATES THE SOLUTION AT
C   XOUT  BY EVALUATING THE POLYNOMIAL THERE.  INFORMATION DEFINING THIS
C   POLYNOMIAL IS PASSED FROM  STEP1  SO  INTRP  CANNOT BE USED ALONE.
C
C   THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT,
C   COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS,  THE INITIAL
C   VALUE PROBLEM  BY L. F. SHAMPINE AND M. K. GORDON.
C
C   INPUT TO INTRP --
C
C   THE USER PROVIDES STORAGE IN THE CALLING PROGRAM FOR THE ARRAYS IN
C   THE CALL LIST
C      DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),PSI(12)
C   AND DEFINES
C      XOUT -- POINT AT WHICH SOLUTION IS DESIRED.
C   THE REMAINING PARAMETERS ARE DEFINED IN  STEP1  AND PASSED TO  INTRP
C   FROM THAT SUBROUTINE.
C
C   OUTPUT FROM  INTRP --
C
C      YOUT(*) -- SOLUTION AT  XOUT
C      YPOUT(*) -- DERIVATIVE OF SOLUTION AT  XOUT
C   THE REMAINING PARAMETERS ARE RETURNED UNALTERED FROM THEIR INPUT
C   VALUES.  INTEGRATION WITH  STEP1  MAY BE CONTINUED.
C
      DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),PSI(12)
      DIMENSION G(13),W(13),RHO(13)
      DATA G(1)/1.0/,RHO(1)/1.0/
C
      HI = XOUT - X
      KI = KOLD + 1
      KIP1 = KI + 1
C
C   INITIALIZE W(*) FOR COMPUTING G(*)
C
      DO 5 I = 1,KI
        TEMP1 = I
 5      W(I) = 1.0/TEMP1
      TERM = 0.0
C
C   COMPUTE G(*)
C
      DO 15 J = 2,KI
        JM1 = J - 1
        PSIJM1 = PSI(JM1)
        GAMMA = (HI + TERM)/PSIJM1
        ETA = HI/PSIJM1
        LIMIT1 = KIP1 - J
        DO 10 I = 1,LIMIT1
 10       W(I) = GAMMA*W(I) - ETA*W(I+1)
        G(J) = W(1)
        RHO(J) = GAMMA*RHO(JM1)
 15     TERM = PSIJM1
C
C   INTERPOLATE
C
      DO 20 L = 1,NEQN
        YPOUT(L) = 0.0
 20     YOUT(L) = 0.0
      DO 30 J = 1,KI
        I = KIP1 - J
        TEMP2 = G(I)
        TEMP3 = RHO(I)
        DO 25 L = 1,NEQN
          YOUT(L) = YOUT(L) + TEMP2*PHI(L,I)
 25       YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I)
 30     CONTINUE
      DO 35 L = 1,NEQN
 35     YOUT(L) = Y(L) + HI*YOUT(L)
      RETURN
      END
      SUBROUTINE BRKF45 (FCN,NEQN,Y,T,TOUT,TEND,YP,RELERR,ABSERR,IFLAG,
     *                   WORK,IWORK)
C
C     BLOCK FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD ADVANCING
C     A BLOCK OF TWO EQUAL STEPS.  THE FORMULA AT THE FIRST STEP IS
C     5(4) WHILE AT THE SECOND STEP IT IS 6(4).
C
C     WRITTEN BY J.R.CASH,
C        DEPARTMENT OF MATHEMATICS,
C        IMPERIAL COLLEGE,
C        SOUTH KENSINGTON, LONDON SW7 2AZ,
C        ENGLAND.
C     MODIFIED BY D. HIGHAM AND A.H. MORRIS.
C
C    THIS IS A HEAVILY REVISED VERSION OF RKF45 OF L.F. SHAMPINE AND
C    H.A. WATTS.
C    BRKF45 IS PRIMARILY DESIGNED TO SOLVE NON-STIFF AND MILDLY STIFF
C    INITIAL VALUE ORDINARY DIFFERENTIAL EQUATIONS WHEN DERIVATIVE
C    EVALUATIONS ARE INEXPENSIVE. BRKF45 USES INTERPOLATION TO PRODUCE
C    OUTPUT AT OFF-STEP POINTS EFFICIENTLY. BRKF45 SHOULD GENERALLY
C    NOT BE USED WHEN THE USER IS DEMANDING HIGH ACCURACY.  IN SUCH
C    CASES A GOOD ADAMS CODE WILL OFTEN BE MORE EFFICIENT.
C
C***********************************************************************
C ABSTRACT
C***********************************************************************
C
C    SUBROUTINE  BRKF45  INTEGRATES A SYSTEM OF NEQN FIRST ORDER
C    ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM
C
C             DY(I)/DT = FCN(T,Y(1),Y(2),...,Y(NEQN))
C
C    WHERE THE Y(I) ARE KNOWN AT TIME T.
C    TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TEND
C    (WHILE RETURNING ANSWERS AT SPECIFIED OUTPUT POINTS TOUT), BUT
C    IT CAN ALSO BE USED AS A ONE-BLOCK INTEGRATOR TO ADVANCE THE
C    SOLUTION A SINGLE BLOCK STEP IN THE DIRECTION OF TEND.  ON RETURN
C    THE PARAMETERS IN THE CALL LIST ARE SET FOR CONTINUING THE
C    INTEGRATION. THE USER HAS ONLY TO CALL BRKF45 AGAIN (AND PERHAPS
C    DEFINE A NEW VALUE FOR TOUT). ACTUALLY, BRKF45 IS AN INTERFACING
C    ROUTINE WHICH CALLS SUBROUTINE RKFC FOR THE SOLUTION.  SUBROUTINE
C    RKFC COMPUTES AN APPROXIMATE SOLUTION OVER ONE BLOCK OF LENGTH 2H.
C    BRKF45 IS PARTICULARLY USEFUL WHEN OUTPUT IS REQUIRED AT MANY
C    OFF-STEP POINTS SINCE THE OUTPUT VALUES CAN BE OBTAINED BY
C    INTERPOLATION.  THIS IS IN CONTRAST TO MANY OTHER RUNGE-KUTTA
C    PROGRAMS WHICH CHOOSE THE STEP SEQUENCE SO AS TO HIT ALL OUTPUT
C    POINTS EXACTLY AND SO BECOME INEFFICIENT WHEN OUTPUT IS REQUIRED
C    AT MANY POINTS WITHIN A STEP.
C    BRKF45 USES THE (5,4), (6,4) BLOCK FORMULA DESCRIBED IN
C    J.R. CASH,  A BLOCK 6(4) RUNGE-KUTTA FORMULA FOR NON-STIFF
C    INITIAL VALUE PROBLEMS, ACM TRANS. MATH SOFTWARE 15 (1989),
C    PP. 15-28.
C
C    THE PARAMETERS REPRESENT-
C      FCN -- SUBROUTINE FCN(T,Y,YP) TO EVALUATE DERIVATIVES
C              YP(I)=DY(I)/DT
C      NEQN -- NUMBER OF DIFFERENTIAL EQUATIONS TO BE INTEGRATED.
C      Y(*) -- APPROXIMATION TO THE SOLUTION VECTOR AT T.
C      T -- INDEPENDENT VARIABLE.
C      TOUT -- THE NEXT POINT WHERE INTERMEDIATE OUTPUT IS
C              REQUIRED.  APPROXIMATE SOLUTIONS AT THESE POINTS
C              WILL BE OBAINED BY INTERPOLATION.
C      TEND -- END OF THE INTEGRATION RANGE.  THIS WILL BE HIT EXACTLY.
C      YP(*) -- APPROXIMATION TO THE DERIVATIVE VECTOR DY/DT AT T.
C      RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR
C            LOCAL ERROR TEST. AT THE NTH POINT OF EACH BLOCK (N=1,2)
C            THE CODE REQUIRES THAT
C                 ABS(LOCAL ERROR)/N .LE. RELERR*ABS(Y) + ABSERR
C            FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION VECTORS
C      IFLAG -- INDICATOR FOR STATUS OF INTEGRATION.
C      WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO BRKF45 WHICH
C            IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED
C            AT LEAST  6+9*NEQN
C      IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL TO
C            BRKF45 WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE
C            DIMENSIONED AT LEAST  5
C
C***********************************************************************
C  FIRST CALL TO BRKF45
C***********************************************************************
C
C    THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE ARRAYS
C    IN THE CALL LIST  -  Y(NEQN) , YP(NEQN) , WORK(6+9*NEQN)
C    IWORK(5), DECLARE FCN IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE
C    FCN(T,Y,YP) AND INITIALIZE THE FOLLOWING PARAMETERS-
C
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED.  (NEQN .GE. 1)
C      Y(*) -- VECTOR OF INITIAL CONDITIONS.
C      T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE.
C      TOUT -- OUTPUT POINT AT WHICH SOLUTION, AND POSSIBLY THE
C              DERIVATIVE, IS DESIRED.
C      TEND -- END OF THE RANGE OF INTEGRATION. IF THE SOLUTION IS
C              REQUIRED ONLY AT TEND THEN THE USER SHOULD SET TOUT=TEND.
C      RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES
C            WHICH MUST BE NON-NEGATIVE. RELERR MUST BE A VARIABLE WHILE
C            ABSERR MAY BE A CONSTANT. THE CODE SHOULD NORMALLY NOT BE
C            USED WITH RELATIVE ERROR CONTROL SMALLER THAN ABOUT 1.E-8,
C            UNLESS AN APPROPRIATE NONZERO ABSOLUTE TOLERANCE IS GIVEN.
C            TO AVOID LIMITING PRECISION DIFFICULTIES THE CODE REQUIRES
C            RELERR TO BE LARGER THAN AN INTERNALLY COMPUTED RELATIVE
C            ERROR PARAMETER WHICH IS MACHINE DEPENDENT. IN PARTICULAR,
C            PURE ABSOLUTE ERROR IS NOT PERMITTED. IF A SMALLER THAN
C            ALLOWABLE VALUE OF RELERR IS ATTEMPTED, BRKF45 INCREASES
C            RELERR APPROPRIATELY AND RETURNS CONTROL TO THE USER BEFORE
C            CONTINUING THE INTEGRATION.
C      IFLAG -- +1,-1  INDICATOR TO INITIALIZE THE CODE FOR EACH NEW
C            PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG=-1
C            ONLY WHEN ONE-BLOCK INTEGRATOR CONTROL IS ESSENTIAL. IN
C            THIS CASE, BRKF45 ATTEMPTS TO ADVANCE THE SOLUTION A
C            SINGLE BLOCK IN THE DIRECTION OF TEND EACH TIME IT IS
C            CALLED.  SINCE THIS MODE OF OPERATION RESULTS IN EXTRA
C            COMPUTING OVERHEAD, IT SHOULD BE AVOIDED UNLESS NEEDED.
C
C***********************************************************************
C  OUTPUT FROM BRKF45
C***********************************************************************
C
C      Y(*) -- COMPUTED SOLUTION APPROXIMATION AT T.
C      T -- VALUE OF THE INDEPENDENT VARIABLE WHERE THE SOLUTION IS
C           REPORTED.
C      IFLAG = 2 -- SUCCESSFUL RETURN.  EITHER THE INTEGRATION REACHED
C                   T=TEND OR A SUCCESSFUL INTERPOLATION HAS BEEN
C                   PERFORMED AT T=TOUT.  IF T.EQ.TEND THEN THE
C                   INTEGRATION IS FINISHED.  IF NOT, THE CODE SHOULD BE
C                   CALLED WITH THE NEXT VALUE OF TOUT AND WITH IFLAG=+2
C                   FOR NORMAL INTEGRATION OR IFLAG=-2 FOR ONE-BLOCK
C                   INTEGRATION.
C            =-2 -- A SINGLE SUCCESSFUL BLOCK IN THE DIRECTION OF TEND
C                   HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING
C                   INTEGRATION ONE BLOCK AT A TIME.
C            = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE RELATIVE ERROR
C                   TOLERANCE WAS TOO SMALL. RELERR HAS BEEN INCREASED
C                   APPROPRIATELY FOR CONTINUING.
C            = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN
C                   18000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS
C                   IS APPROXIMATELY 2000 BLOCKS.
C            = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION
C                   VANISHED MAKING A PURE RELATIVE ERROR TEST
C                   IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE.
C                   USING THE ONE-BLOCK INTEGRATION MODE FOR ONE BLOCK
C                   IS A GOOD WAY TO PROCEED.
C            = 6 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED
C                   ACCURACY COULD NOT BE ACHIEVED USING SMALLEST
C                   ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR
C                   TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE
C                   ATTEMPTED.
C            = 7 -- INVALID INPUT PARAMETERS
C                   THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS
C                   SATISFIED -   NEQN .LE. 0
C                                 T = TEND
C                                 RELERR OR ABSERR .LT. 0.
C                                 ABS(IFLAG) .LT. 1 OR .GT. 7
C      WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO INTEREST
C                   TO THE USER BUT NECESSARY FOR SUBSEQUENT CALLS.
C                   WORK(1),...,WORK(NEQN) CONTAIN THE SOLUTION VECTOR
C                   AND WORK(NEQN+1),...,WORK(2*NEQN) CONTAIN THE
C                   DERIVATIVE VECTOR AT THE END POINT (WHICH IS ITSELF
C                   CONTAINED IN WORK(2*NEQN+1)) OF THE BLOCK STEP JUST
C                   COMPUTED. WORK(2*NEQN+2) CONTAINS THE STEPSIZE H
C                   JUST USED. (THIS IS THE STEPSIZE BEING USED BY THE
C                   INTERPOLANT OVER THIS BLOCK.) WORK(2*NEQN+3)
C                   CONTAINS THE STEPSIZE H TO BE ATTEMPTED ON THE NEXT
C                   BLOCK. IWORK(1) CONTAINS THE DERIVATIVE EVALUATION
C                   COUNTER.
C
C***********************************************************************
C  SUBSEQUENT CALLS TO BRKF45
C***********************************************************************
C
C    SUBROUTINE BRKF45 RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE
C    THE INTEGRATION. AFTER THE CODE REPORTS A SUCCESSFUL SOLUTION AT
C    TOUT (INDICATED BY IFLAG=2), THE USER NEEDS TO DEFINE A NEW TOUT
C    BEFORE SIMPLY CALLING BRKF45 AGAIN TO CONTINUE IN THE NORMAL MODE.
C    (BUT THE USER MUST FIRST RESET IFLAG TO -2 TO CONTINUE IN THE
C    ONE-BLOCK INTEGRATOR MODE.)
C    IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS TO
C    CONTINUE (IFLAG=3,4), HE JUST CALLS BRKF45 AGAIN. IN THE CASE
C    IFLAG=3 THE RELERR PARAMETER HAS BEEN ADJUSTED APPROPRIATELY FOR
C    CONTINUING THE INTEGRATION. IN THE CASE OF IFLAG=4 THE FUNCTION
C    COUNTER WILL BE RESET TO 0 AND ANOTHER 18000 FUNCTION EVALUATIONS
C    ARE ALLOWED.
C    HOWEVER,IN THE CASE IFLAG=5, THE USER MUST FIRST ALTER THE ERROR
C    CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE INTEGRATION CAN
C    PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED.
C    ALSO,IN THE CASE IFLAG=6, IT IS NECESSARY FOR THE USER TO RESET
C    IFLAG TO 2 (OR -2 WHEN THE ONE-BLOCK INTEGRATION MODE IS BEING
C    USED) AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH BEFORE
C    THE INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, EXECUTION
C    WILL BE TERMINATED. THE OCCURRENCE OF IFLAG=6 INDICATES A TROUBLE
C    SPOT(SOLUTION IS CHANGING RAPIDLY,SINGULARITY MAY BE PRESENT) AND
C    IT OFTEN IS INADVISABLE TO CONTINUE.
C    IF IFLAG=7 IS OBTAINED, INTEGRATION CAN NOT BE CONTINUED UNLESS
C    THE INVALID INPUT PARAMETERS ARE CORRECTED.
C    IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN INFORMATION
C    REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, WORK AND IWORK
C    SHOULD NOT BE ALTERED.
C
C***********************************************************************
C  USER CALLS TO THE INTERPOLANT ROUTINE EXTRA
C***********************************************************************
C
C    SUBROUTINE EXTRA CAN ALSO BE CALLED BY THE USER, IN CONJUNCTION
C    WITH USAGE OF BRKF45, TO PROVIDE APPROXIMATE SOLUTIONS AT OFF-STEP
C    POINTS BY USE OF THE INTERPOLATING POLYNOMIAL. WHILE BRKF45
C    HANDLES THE USUAL SITUATIONS, IT CAN BE HELPFUL TO THE USER TO BE
C    ABLE TO ACCESS THE INTERPOLANT DIRECTLY, SUCH AS WHEN DOING ROOT
C    FINDING. ALSO, IT IS POSSIBLE THAT THE USER MAY HAVE SOME NEED FOR
C    EXTRAPOLATING OUTSIDE OF THE BLOCK STEP ON WHICH THE UNDERLYING
C    INTERPOLANT IS BASED. BRKF45 WILL NOT DO THIS.
C    THE FORM OF THE USAGE CALL IS
C
C    CALL EXTRA ( NEQN, WORK(6*NEQN+4), WORK(NEQN+1), WORK(2*NEQN+1),
C                WORK(2*NEQN+2), WORK(2*NEQN+4), WORK(3*NEQN+4),
C                WORK(4*NEQN+4), WORK(5*NEQN+4), TEX, YEX, YPEX )
C
C    WHERE YEX AND YPEX ARE THE SOLUTION VECTOR AND DERIVATIVE VECTOR
C    APPROXIMATIONS DEFINED BY THE INTERPOLANT AT THE POINT TEX, AND
C    WORK IS THE WORKING ARRAY SET UP BY BRKF45. THIS VERSION OF
C    EXTRA HAS BEEN WRITTEN BY D. HIGMAN (SEE BELOW).
C
C***********************************************************************
C  MORE ABOUT THE INTERPOLANT ROUTINE EXTRA
C***********************************************************************
C
C    THE FIRST DERIVATIVE APPROXIMATIONS GIVEN BY J.R. CASH HAVE BEEN
C    MODIFIED BY D. HIGMAN. THREE CHANGES HAVE BEEN MADE AND ARE
C    CLEARLY DOCUMENTED IN THE CODE. JUST SEARCH FOR THE WORD *CHANGES*.
C    FOR AN EXPLANATION OF THESE MODIFICATIONS SEE
C    REMARK ON ALGORITHM 669, BY D. HIGHAM,
C    ACM TRANS. MATH SOFTWARE 17, PP. 424-426.
C
C***********************************************************************
C
      LOGICAL ENDPNT,BLKOUT
      DIMENSION Y(NEQN),YP(NEQN),WORK(*),IWORK(5)
      EXTERNAL FCN
C
C     COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY
C
      KW = 1
      KWP = KW + NEQN
      KX = KWP + NEQN
      KHI = KX + 1
      KH = KHI + 1
      KY1 = KH + 1
      KY2 = KY1 + NEQN
      KF1 = KY2 + NEQN
      KF2 = KF1 + NEQN
      KF3 = KF2 + NEQN
      KF4 = KF3 + NEQN
      KF7 = KF4 + NEQN
      KSR = KF7 + NEQN
      KSA = KSR + 1
      KT = KSA + 1
C
C     THE WORK SPACE TOTALS  6 + 9*NEQN .
C
      IF (IABS(IFLAG) .EQ. 1) GO TO 10
         ENDPNT = (IWORK(4) .EQ. -1)
         BLKOUT = (IWORK(5) .EQ. -1)
C
C***********************************************************************
C     THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG
C     CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE
C     ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER,
C     HE MUST USE RKFC DIRECTLY.
C***********************************************************************
C
   10 CALL RKFC (FCN,NEQN,Y,T,TOUT,TEND,YP,RELERR,ABSERR,IFLAG,WORK(KW),
     *      WORK(KWP),WORK(KX),WORK(KHI),WORK(KH),WORK(KY1),WORK(KY2),
     *      WORK(KF1),WORK(KF2),WORK(KF3),WORK(KF4),WORK(KF7),WORK(KSR),
     *      WORK(KSA),WORK(KT),IWORK(1),IWORK(2),IWORK(3),ENDPNT,BLKOUT)
C
      IWORK(4) = 0
      IF (ENDPNT) IWORK(4) = -1
      IWORK(5) = 0
      IF (BLKOUT) IWORK(5) = -1
C
      RETURN
      END
      SUBROUTINE RKFC (FCN,NEQN,Y,T,TOUT,TEND,YP,RELERR,ABSERR,IFLAG,
     *                 W,WP,X,HINT,H,Y1,Y2,F1,F2,F3,F4,F7,SAVRE,SAVAE,
     *                 TOLD,NFE,JFLAG,KFLAG,ENDPNT,BLKOUT)
C
C     TWO STEP BLOCK RUNGE-KUTTA FEHLBERG METHOD.
C     A STANDARD 5(4) FORMULA IS USED AT THE FIRST POINT IN THE BLOCK
C     AND A 6(4) FORMULA IS USED AT THE SECOND POINT.
C
      LOGICAL HFAILD,ENDPNT,INTERP,BLKOUT
      DIMENSION Y(NEQN),YP(NEQN),Y1(NEQN),Y2(NEQN),F1(NEQN),F2(NEQN),
     *          F3(NEQN),F4(NEQN),F7(NEQN),W(NEQN),WP(NEQN)
      EXTERNAL FCN
C
C***********************************************************************
C
C     COEFFICIENTS DEFINING THE METHOD ...
C
C                C2=0.25E+0
C                C3=3.0E+0/8.0E+0
C                C4=12.0E+0/13.0E+0
C                C6=0.5E+0
C                C8=3.0E+0/2.0E+0
C                C9=2.0E+0
C
C                A21=1.0E+0/4.0E+0
C                A31=3.0E+0/32.0E+0
C                A32=9.0E+0/32.0E+0
C                A41=1932.0E+0/2197.0E+0
C                A42=-7200.0E+0/2197.0E+0
C                A43=7296.0E+0/2197.0E+0
C                A51=439.0E+0/216.0E+0
C                A52=-8.0E+0
C                A53=3680.0E+0/513.0E+0
C                A54=-845.0E+0/4104.0E+0
C                A61=-8.0E+0/27.0E+0
C                A62=2.0E+0
C                A63=-3544.0E+0/2565.0E+0
C                A64=1859.0E+0/4104.0E+0
C                A65=-11.0E+0/40.0E+0
C
C                B1B=16.0E+0/135.0E+0
C                B3B=6656.0E+0/12825.0E+0
C                B4B=28561.0E+0/56430.0E+0
C                B5B=-9.0E+0/50.0E+0
C                B6B=2.0E+0/55.0E+0
C
C                ERC11=1.0E+0/360.0E+0
C                ERC13=-128.0E+0/4275.0E+0
C                ERC14=-2197.0E+0/75240.0E+0
C                ERC15=1.0E+0/50.0E+0
C
      DATA C2 /.250000000000000E+00/, C3 /.375000000000000E+00/,
     *     C4 /.923076923076923E+00/, C6 /.500000000000000E+00/,
     *     C8 /.150000000000000E+01/, C9 /.200000000000000E+01/
C
      DATA A21 / .250000000000000E+00/, A31 / .937500000000000E-01/,
     *     A32 / .281250000000000E+00/, A41 / .879380974055530E+00/,
     *     A42 /-.327719617660446E+01/, A43 / .332089212562585E+01/,
     *     A51 / .203240740740741E+01/, A52 /-.800000000000000E+01/,
     *     A53 / .717348927875244E+01/, A54 /-.205896686159844E+00/,
     *     A61 /-.296296296296296E+00/, A62 / .200000000000000E+01/,
     *     A63 /-.138167641325536E+01/, A64 / .452972709551657E+00/,
     *     A65 /-.275000000000000E+00/
C
      DATA B1B /.118518518518519E+00/, B3B / .518986354775828E+00/,
     *     B4B /.506131490342017E+00/, B5B /-.180000000000000E+00/,
     *     B6B /.363636363636364E-01/
C
      DATA ERC11/ .277777777777778E-02/, ERC13/-.299415204678363E-01/,
     *     ERC14/-.291998936735779E-01/, ERC15/ .200000000000000E-01/
C
C     THE ABOVE DEFINE THE COEFFICIENTS FOR BRKF45 USED TO GENERATE
C     THE SOLUTION AT THE FIRST BLOCK POINT. BELOW ARE ADDITIONAL
C     COEFFICIENTS NEEDED TO GENERATE THE SOLUTION AT THE SECOND BLOCK
C     POINT.
C
C                B1=931.0E+0/6480.0E+0
C                B3=315392.0E+0/1500525.0E+0
C                B4=371293.0E+0/615600.0E+0
C                B5=1.0E+0/50.0E+0
C                B6=0.4E+0
C                B7=-4.0E+0/15.0E+0
C                B8=85006.0E+0/115425.0E+0
C                B9=239.0E+0/1560.0E+0
C
C                A81=-119397029895.0E+0/151948225000.0E+0
C                A82=78390.0E+0/29081.0E+0
C                A83=-51517464.0E+0/132821875.0E+0
C                A84=-3780749193.0E+0/1168832500.0E+0
C                A85=79268193.0E+0/55925000.0E+0
C                A86=-11370591.0E+0/15379375.0E+0
C                A87=5670.0E+0/2237.0E+0
C
C                A91=23406188597.0E+0/8429231250.0E+0
C                A92=-62928.0E+0/13623.0E+0
C                A93=-31066887488.0E+0/5747203125.0E+0
C                A94=164486461399.0E+0/8429231250.0E+0
C                A95=-70336084.0E+0/11203125.0E+0
C                A96=185680664.0E+0/24646875.0E+0
C                A97=-3385330161.0E+0/243117160.0E+0
C                A98=232648.0E+0/96795.0E+0
C
      DATA B1 /.143672839506173E+00/, B3 / .210187767614668E+00/,
     *     B4 /.603140025990903E+00/, B5 / .200000000000000E-01/,
     *     B6 /.400000000000000E+00/, B7 /-.266666666666667E+00/,
     *     B8 /.736460905349794E+00/, B9 / .153205128205128E+00/
C
      DATA A81 /-.785774430040232E+00/, A82 / .269557443004023E+01/,
     *     A83 /-.387868820553843E+00/, A84 /-.323463729234086E+01/,
     *     A85 / .141740175234689E+01/, A86 /-.739340252773601E+00/,
     *     A87 / .253464461332141E+01/
C
      DATA A91 / .277678804896947E+01/, A92 /-.461924686192469E+01/,
     *     A93 /-.540556629238679E+01/, A94 / .195138152603181E+02/,
     *     A95 /-.627825575453278E+01/, A96 / .753363921389629E+01/,
     *     A97 /-.139246861924514E+02/, A98 / .240351257812904E+01/
C
C     NEXT WE DEFINE COEFFICIENTS FOR THE ERROR ESTIMATE FORMULA.
C
C     B3E = 1067091077380.0E+0/1829119027671.0E+0
C     B4E = 3284168845918.0E+0/21339721989495.0E+0
C     B5E = 110317750789.0E+0/240996319200.0E+0-
C    *      4448925830089.0E+0/12329617149531.0E+0
C     B6E = 1.0E+0/25.0E+0
C     B7E = 0.2E+0
C     B8E = 239992027043.0E+0/361494478800.0E+0
C     B9E = 1273.0E+0/7800.0E+0
C     B1E = 2.0E+0-B3E-B4E-B5E-B6E-B7E-B8E-B9E
C
C     ERC21 = (B1-B1E)/2.0E+0
C     ERC23 = (B3-B3E)/2.0E+0
C     ERC24 = (B4-B4E)/2.0E+0
C     ERC25 = (B5-B5E)/2.0E+0
C     ERC26 = 9.0E+0/50.0E+0
C     ERC27 = -7.0E+0/30.0E+0
C     ERC28 = (B8 - B8E)/2.0E+0
C     ERC29 = -0.005E+0
C
      DATA ERC21 /.224905375494686E-01/, ERC23 /-.186601479161668E+00/,
     *     ERC24 /.224620349650851E+00/, ERC25 /-.384622777202128E-01/,
     *     ERC26 /.180000000000000E+00/, ERC27 /-.233333333333333E+00/,
     *     ERC28 /.362862030148937E-01/, ERC29 /-.500000000000000E-02/
C
C***********************************************************************
C
C  REMIN IS A TOLERANCE THRESHOLD WHICH IS ALSO DETERMINED BY THE
C  INTEGRATION METHOD. IN PARTICULAR, A FIFTH ORDER METHOD WILL
C  GENERALLY NOT BE CAPABLE OF DELIVERING ACCURACIES NEAR LIMITING
C  PRECISION ON COMPUTERS WITH LONG WORDLENGTHS. THIS DOES NOT HAVE
C  TO BE CHANGED FOR DIFFERENT MACHINES.
C
      DATA REMIN / 1.E-12 /
C
C***********************************************************************
C
C     THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER
C     OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE.
C
      DATA MAXNFE / 18000 /
C
C***********************************************************************
C
C  THE COMPUTER UNIT ROUNDOFF ERROR U IS THE SMALLEST POSITIVE VALUE
C  REPRESENTABLE IN THE MACHINE SUCH THAT  1 + U .GT. 1.
C
       U = SPMPAR(1)
C
C***********************************************************************
C
C     CHECK INPUT PARAMETERS
C
      IF (NEQN .LT. 1) GO TO 500
      IF (RELERR .LT. 0.0 .OR. ABSERR .LT. 0.0) GO TO 500
      IF (T .EQ. TEND) GO TO 500
      MFLAG = IABS(IFLAG)
      IF (MFLAG .NE. 1) GO TO 10
         TOLD = T
         IF (TOUT .EQ. T) GO TO 70
         IF (SIGN(1.0, TEND-T) .NE. SIGN(1.0, TOUT-T)) GO TO 500
         GO TO 70
   10 IF (MFLAG .EQ. 0 .OR. MFLAG .GT. 7) GO TO 500
      IF (TOUT .EQ. TOLD) GO TO 20
      IF (SIGN(1.0, TEND-TOLD) .NE. SIGN(1.0, TOUT-TOLD)) GO TO 500
C
C     CHECK CONTINUATION POSSIBILITIES
C
   20 IF (MFLAG .NE. 2) GO TO 30
C
C     IFLAG = +2 OR -2
C
      IF (KFLAG .LT. 3) GO TO 70
      IF (KFLAG .EQ. 3) GO TO 60
      IF (KFLAG .EQ. 4) GO TO 50
      IF (KFLAG .EQ. 5 .AND. ABSERR .EQ. 0.0) GO TO 40
      IF (KFLAG .EQ. 6 .AND. RELERR .LE. SAVRE .AND. ABSERR .LE. SAVAE)
     *    GO TO 40
      GO TO 70
C
C     IFLAG = 3,4,5,6 OR 7
C
   30 IF (IFLAG .EQ. 3) GO TO 60
      IF (IFLAG .EQ. 4) GO TO 50
      IF (IFLAG .EQ. 5 .AND. ABSERR .GT. 0.0) GO TO 60
C
C     INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO
C     THE INSTRUCTIONS PERTAINING TO IFLAG=5,6 OR 7
C
   40 STOP
C
C***********************************************************************
C
C     RESET FUNCTION EVALUATION COUNTER
C
   50 NFE = 0
      IF (MFLAG .EQ. 2) GO TO 70
C
C     RESET FLAG VALUE FROM PREVIOUS CALL
C
   60 IFLAG = JFLAG
      IF (KFLAG .EQ. 3) MFLAG = IABS(IFLAG)
C
C     SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT
C     INPUT CHECKING
C
   70 JFLAG = IFLAG
      KFLAG = 0
C
C     SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS
C
      SAVRE = RELERR
      SAVAE = ABSERR
C
C     RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS
C     2U+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING FROM
C     IMPOSSIBLE ACCURACY REQUESTS. IF TOLERANCE TOO SMALL, INCREASE
C     AND RETURN.
C
      RER = 2.0*U + REMIN
      IF (RELERR .LT. RER) GO TO 520
C
      U26 = 26.0*U
      IF (MFLAG .NE. 1) GO TO 100
C
C***********************************************************************
C
C     INITIALIZATION --
C                       DEFINE INTEGRATION INDEPENDENT VARIABLE X
C                       EVALUATE INITIAL DERIVATIVES
C                       SET UP WORKING ARRAYS FOR INTEGRATION VARIABLES
C                       SET COUNTER FOR FUNCTION EVALUATIONS,NFE
C                       ESTIMATE STARTING STEPSIZE
C
      X = T
      ENDPNT = .FALSE.
      BLKOUT = .FALSE.
C
      A = T
      CALL FCN (A, Y, YP)
      NFE = 1
      DO 80 N = 1, NEQN
         W(N) = Y(N)
         WP(N) = YP(N)
   80 CONTINUE
C
C     COMPUTE INITIAL STEPLENGTH.
C
      DT = TOUT - T
      IF (DT .EQ. 0.0) DT = TEND - T
      H = ABS(DT)
      TOLN = 0.0
      DO 90 K = 1, NEQN
         TOL = RELERR*ABS(Y(K)) + ABSERR
         IF (TOL .LE. 0.0) GO TO 90
         TOLN = TOL
         YPK = ABS(YP(K))
         IF (YPK*H**5 .GT. TOL) H = (TOL/YPK)**0.2
   90 CONTINUE
      IF (TOLN .LE. 0.0) H = 0.0
      H = AMAX1(H, U26*AMAX1(ABS(T),ABS(DT)))
      JFLAG = ISIGN(2,IFLAG)
      H = SIGN(H,DT)
C
C     INITIAL STEPLENGTH NOW COMPUTED. COMPUTE FIRST SOLUTION.
C
C***********************************************************************
C
C     TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION,
C     SCALE THE ERROR TOLERANCES.
C
  100 SCALE = 2.0/RELERR
      AE = SCALE*ABSERR
C
C     SET SAFETY FACTOR FOR STEPSIZE ADJUSTMENT, BASED ON TOLERANCES.
C
      TOLER = AMAX1(ABSERR,RELERR)
      SF = 0.85
      IF (TOLER .GE. 1.E-5) SF = 0.8
      IF (TOLER .LE. 1.E-9) SF = 0.9
C
C     RESTORE INTEGRATION VARIABLE TO END OF LAST BLOCK STEP TAKEN
C     AND SET THE SIGN OF THE DIRECTION OF INTEGRATION.
C
      T = X
      DTSIGN = SIGN(1.0, TEND-T)
C
C     HAVE WE ALREADY INTEGRATED PAST THE PRESENT DATA OUTPUT POINT?
C     IF SO JUMP TO 390 AND PERFORM INTERPOLATION.
C     IF NOT, SEE IF WE HAVE REACHED THE END POINT OF INTEGRATION.
C     IF NOT, SEE IF RESULTS AT THE END OF THE BLOCK STEP NEED TO BE
C     REPORTED.
C
      IF ((TOUT-T)*DTSIGN .GT. 0.0) GO TO 110
         IF (TOUT .EQ. T) GO TO 510
         GO TO 390
  110 IF (ENDPNT) GO TO 510
      IF (IFLAG .NE. -2  .OR. .NOT.BLKOUT) GO TO 150
         BLKOUT = .FALSE.
         GO TO 400
C
C***********************************************************************
C***********************************************************************
C     BLOCK BY BLOCK INTEGRATION
C
C     SEE IF WE ARE TOO CLOSE TO THE END POINT.  IF SO, DO LINEAR
C     EXTRAPOLATION AND RETURN.
C
  150 IF (ABS(TEND-T) .GT. U26*ABS(T)) GO TO 190
      IF (DTSIGN*(TEND-TOUT) .LE. 0.0) GO TO 160
         DT = TOUT - T
         ENDPNT = .FALSE.
         T = TOUT
         GO TO 170
  160 DT = TEND - T
      ENDPNT = .TRUE.
      T = TEND
      X = TEND
C
  170 DO 171 K = 1, NEQN
         Y(K) = W(K) + DT*WP(K)
  171 CONTINUE
      CALL FCN (T, Y, YP)
      NFE = NFE + 1
      IFLAG = 2
      IF (.NOT.ENDPNT) RETURN
C
      DO 180 N = 1,NEQN
         W(N) = Y(N)
         WP(N) = YP(N)
  180 CONTINUE
      ENDPNT = .FALSE.
      RETURN
C
C     SET SMALLEST ALLOWABLE STEPSIZE AND STEP FAILURE FLAG.
C     ADJUST STEPSIZE IF NECESSARY TO HIT THE END POINT OF INTEGRATION.
C
  190 HMIN = U26*ABS(T)
      HFAILD = .FALSE.
      HSTOP = 0.5*(TEND-T)
      IF (ABS(HSTOP) .GT. ABS(H)) GO TO 200
      ENDPNT = .TRUE.
      H = HSTOP
C
C***********************************************************************
C     CORE INTEGRATOR FOR A SINGLE BLOCK
C***********************************************************************
C     THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW IN
C     COMPUTING THE ERROR TOLERANCE FUNCTION ERRTOL.
C     TO AVOID PROBLEMS WITH ZERO CROSSINGS,RELATIVE ERROR IS MEASURED
C     USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE
C     BEGINNING AND END  POINTS OF A BLOCK.
C     TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED
C     TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T.
C     PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO
C     SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE
C     CHATTERING ON PROBLEMS HAVING DISCONTINUITIES.
C***********************************************************************
C
C     TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS.
C     IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H
C
  200 IF (NFE .GT. MAXNFE) GO TO 530
C
C     ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H
C
      DO 210 N = 1, NEQN
         Y1(N) = W(N) + A21*H*WP(N)
  210 CONTINUE
      CALL FCN (T + C2*H, Y1, F2)
      DO 220 N = 1, NEQN
         Y1(N) = W(N) + H*(A31*WP(N) + A32*F2(N))
  220 CONTINUE
      CALL FCN (T + C3*H, Y1, F3)
      DO 230 N = 1, NEQN
         Y1(N) = W(N) + H*(A41*WP(N) + A42*F2(N) + A43*F3(N))
  230 CONTINUE
      CALL FCN (T + C4*H, Y1, F4)
      DO 240 N = 1, NEQN
         Y1(N) = W(N) + H*(A51*WP(N)+A52*F2(N)+A53*F3(N)+A54*F4(N))
  240 CONTINUE
      CALL FCN (T + H, Y1, Y)
      DO 250 N = 1, NEQN
         Y1(N) = W(N) + H*(A61*WP(N)+A62*F2(N)+A63*F3(N)+A64*F4(N)+
     *                     A65*Y(N))
  250 CONTINUE
      CALL FCN (T + C6*H, Y1, YP)
      NFE = NFE + 5
      EEOET = 0.0
      DO 270 N = 1, NEQN
         Y1(N) = W(N) + H*(B1B*WP(N)+B3B*F3(N)+B4B*F4(N)+B5B*Y(N)+
     *                     B6B*YP(N))
         ERRTOL = ABS(W(N)) + ABS(Y1(N)) + AE
         IF (ERRTOL .LE. 0.0) GO TO 540
         EZ = ABS(H*(ERC11*WP(N)+ERC13*F3(N)+ERC14*F4(N)+ERC15*Y(N)+
     *               B6B*YP(N)))
         EEOET = AMAX1(EEOET,EZ/ERRTOL)
  270 CONTINUE
      ESTTOL = EEOET*SCALE
C
C     CHECK THE ERROR ESTIMATE. IF STEPLENGTH HAS FAILED FOR FIRST STEP
C     IN THE BLOCK, GO AND COMPUTE A SMALLER STEP FOR A RE-TRY.
C
      IF (ESTTOL .GT. 1.0) GO TO 320
C
C     INTEGRATION SUCCESSFUL FOR FIRST STEP.  NOW INTEGRATE OVER
C     THE SECOND STEP IN THE BLOCK
C
      CALL FCN (T + H, Y1, F1)
      DO 290 N = 1, NEQN
         Y2(N) = W(N) + H*(A81*WP(N)+A82*F2(N)+A83*F3(N)+A84*F4(N)+
     *                     A85*Y(N)+A86*YP(N)+A87*F1(N))
  290 CONTINUE
      CALL FCN (T + C8*H, Y2, F7)
      DO 300 N = 1, NEQN
         Y2(N) = W(N) + H*(A91*WP(N)+A92*F2(N)+A93*F3(N)+A94*F4(N)+
     *                     A95*Y(N)+A96*YP(N)+A97*F1(N)+A98*F7(N))
  300 CONTINUE
      CALL FCN (T + C9*H, Y2, F2)
      NFE = NFE + 3
      EEOET = 0.0
      DO 310 N = 1, NEQN
         EE = ABS(H*(ERC21*WP(N)+ERC23*F3(N)+ERC24*F4(N)+ERC25*Y(N)+
     *               ERC26*YP(N)+ERC27*F1(N)+ERC28*F7(N)+ERC29*F2(N)))
         Y2(N) = W(N)+H*(B1*WP(N)+B3*F3(N)+B4*F4(N)+B5*Y(N)+B6*YP(N)+
     *                   B7*F1(N)+B8*F7(N)+B9*F2(N))
         ERRTOL = ABS(Y2(N)) + ABS(Y1(N)) + AE
         IF (ERRTOL .LE. 0.0) GO TO 540
         EEOET = AMAX1(EEOET,EE/ERRTOL)
  310 CONTINUE
      ESTTOL = EEOET*SCALE
C
C     THE FIRST OF THE THREE CHANGES NEEDED TO MAKE THE INTERPOLANT
C     DERIVATIVE MORE STABLE IS THE FOLLOWING DO-LOOP.
C
      DO 315 N = 1, NEQN
         Y1(N) = B1B*WP(N)+B3B*F3(N)+B4B*F4(N)+B5B*Y(N)+
     *           B6B*YP(N)
         F3(N) = B1*WP(N)+B3*F3(N)+B4*F4(N)+B5*Y(N)+B6*YP(N)+
     *           B7*F1(N)+B8*F7(N)+B9*F2(N)
  315 CONTINUE
C
C     CHECK THE ERROR ESTIMATE OVER THE SECOND STEP OF THE BLOCK.
C
      IF (ESTTOL .LE. 1.0) GO TO 330
C
C     UNSUCCESSFUL BLOCK
C     REDUCE THE STEPSIZE , TRY AGAIN
C     THE DECREASE IS LIMITED TO A FACTOR OF ABOUT 1/10
C
  320 HFAILD = .TRUE.
      S = 0.1
      ENDPNT = .FALSE.
      IF (ESTTOL .LT. 1.0E+5) S = SF/ESTTOL**0.2
      H = S*H
      IF (ABS(H) .LT. HMIN) GO TO 550
      GO TO 200
C
C     SUCCESSFUL BLOCK. CHECK FOR NEED TO INTERPOLATE.
C     STORE SOLUTION AT T+2*H.
C
  330 T = T + 2.0*H
      IF (ENDPNT) T = TEND
      TOLD = X
      X = T
      HINT = H
      INTERP = .FALSE.
      IF ((T-TOUT)*DTSIGN .GE. 0.0) INTERP = .TRUE.
C
      IF (INTERP) GO TO 350
         DO 340 N = 1,NEQN
            W(N) = Y2(N)
  340    CONTINUE
         GO TO 360
C
  350 DO 351 N = 1,NEQN
         SWAP = W(N)
         W(N) = Y2(N)
         Y2(N) = SWAP
         F2(N) = WP(N)
  351 CONTINUE
C
  360 A = T
      CALL FCN (A, W, WP)
      NFE = NFE + 1
C
C     CHOOSE NEXT STEPSIZE
C     THE INCREASE IS LIMITED TO A FACTOR OF ABOUT 10
C     IF STEP FAILURE HAS JUST OCCURED, NEXT STEP IS NOT ALLOWED
C     TO INCREASE.
C
      S = 10.0
      IF (ESTTOL .GT. 1.E-5) S = SF/ESTTOL**0.2
      IF (HFAILD) S = AMIN1(S,1.0)
      H = SIGN(AMAX1(S*ABS(H),HMIN), H)
C
C     HAVE WE INTEGRATED PAST AN OUTPUT POINT?
C     IF SO, CALL THE INTERPOLATION ROUTINE AT T=TOUT.
C     IF NOT, SEE IF WE ARE AT THE END POINT OF INTEGRATION.
C     OTHERWISE, CHECK IF USER WANTS SOLUTIONS AT THE END OF THE BLOCK
C     STEP, OR ELSE CONTINUE THE INTEGRATION.
C
      IF (INTERP) GO TO 390
      IF (ENDPNT) GO TO 510
      IF (IFLAG .GT. 0) GO TO 150
      IFLAG = -2
      GO TO 400
C
C     INTERPOLATE TO GET DATA AT OFF-STEP POINT AND RETURN.
C
C     THE SECOND OF THE THREE CHANGES NEEDED TO MAKE THE INTERPOLANT
C     DERIVATIVE MORE STABLE IS THE NEW STATEMENT 390 GIVEN BELOW.
C
  390 CALL EXTRA (NEQN,F3,WP,X,HINT,Y1,Y2,F1,F2,TOUT,Y,YP)
      T = TOUT
      IF (IFLAG .LT. 0 .AND. TOUT .NE. X) BLKOUT = .TRUE.
      IFLAG = 2
      RETURN
C
C     RETURN WITH THE SOLUTION AT THE END OF THE LAST SUCCESSFUL
C     BLOCK STEP.
C
  400 DO 410 N = 1,NEQN
         Y(N) = W(N)
         YP(N) = WP(N)
  410 CONTINUE
      RETURN
C
C     INVALID INPUT, RETURN
C
  500 IFLAG = 7
      RETURN
C
C     WE HAVE REACHED THE ENDPOINT
C
  510 IFLAG = 2
      ENDPNT = .FALSE.
      GO TO 400
C
C     RELATIVE ERROR TOLERANCE TOO SMALL
C
  520 RELERR = RER
      IFLAG = 3
      KFLAG = 3
      RETURN
C
C     TOO MUCH WORK
C
  530 IFLAG = 4
      KFLAG = 4
      GO TO 400
C
C     INAPPROPRIATE ERROR TOLERANCE
C
  540 IFLAG = 5
      KFLAG = 5
      GO TO 400
C
C     REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE
C
  550 IFLAG = 6
      KFLAG = 6
      GO TO 400
      END
      SUBROUTINE EXTRA (NEQN,YINC2,F2,T,H,YINC1,Y,F1,F,TEX,YEX,YPEX)
C
C     THIS VERSION OF EXTRA IS THE THIRD OF THE THREE CHANGES
C     NEEDED TO MAKE THE INTERPOLANT DERIVATIVE MORE STABLE.
C
C     T IS THE INDEPENDENT VARIABLE.
C     Y IS THE VALUE AT T-2H. THE VALUES AT T-H AND T ARE
C     Y + H*YINC1 AND Y + H*YINC2 RESPECTIVELY.
C     F,F1 AND F2 ARE THE DERIVATIVES AT T-2H, T-H AND T.
C     TEX IS THE POINT WHERE THE OUTPUT IS REQUIRED.
C     YEX WILL HOLD THE APPROXIMATE SOLUTION AT TEX AND YPEX WILL
C     HOLD THE DERIVATIVE APPROXIMATION AT THIS POINT.
C
      DIMENSION Y(NEQN),YINC1(NEQN),YINC2(NEQN),F(NEQN),F1(NEQN),
     *          F2(NEQN),YEX(NEQN),YPEX(NEQN)
C
C     PERFORM QUINTIC INTERPOLATION BASED ON THE VALUES
C     Y(N),Y(N)+H*YINC1(N),Y(N)+H*YINC2(N),F(N),F1(N),F2(N) AT THE
C     POINTS T-2H, T-H, T.  THIS POLYNOMIAL IS EVALUATED AT THE POINT
C     TEX TO OBTAIN THE APPROXIMATE VALUE OF Y(TEX) AND THIS IS STORED
C     IN THE ARRAY YEX.  THE DERIVATIVE OF THE INTERPOLATING POLYNOMIAL
C     IS ALSO EVALUATED AT TEX TO OBTAIN AN APPROXIMATION TO DY/DT
C     AT THIS POINT AND THIS APPROXIMATION IS STORED IN YPEX.
C
      SIG = (TEX - T)/H + 2.0
      DO 10 N = 1, NEQN
         HF = H*F(N)
         HF1 = H*F1(N)
         HF2 = H*F2(N)
         A1 = 2.0*(HF2 + HF) - 6.0*H*YINC2(N) + 8.0*HF1
         A2 = H*YINC2(N) + 4.0*H*YINC1(N) - 4.0*HF1 - 2.0*HF
         A3 = HF1 + HF - 2.0*H*YINC1(N)
         A4 = H*YINC1(N) - HF
         YEX(N) = ((((A1*0.125*(SIG - 2.0) + 0.25*A2)*(SIG - 1.0) +
     *                A3)*(SIG - 1.0) + A4)*SIG + HF)*SIG + Y(N)
         YPEX(N) = ((((0.625*A1*SIG + (A2 - 2.0*A1))*SIG + (1.875*A1 -
     *                 1.5*A2 + 3.0*A3))*SIG + (0.5*(A2 - A1) -
     *                 2.0*(A3 - A4)))*SIG + HF)/H
   10 CONTINUE
      RETURN
      END
      SUBROUTINE RKF45 (F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,WORK,IWORK)
C
C     FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD
C
C     WRITTEN BY H.A.WATTS AND L.F.SHAMPINE
C                   SANDIA LABORATORIES
C                  ALBUQUERQUE,NEW MEXICO
C
C    RKF45 IS PRIMARILY DESIGNED TO SOLVE NON-STIFF AND MILDLY STIFF
C    DIFFERENTIAL EQUATIONS WHEN DERIVATIVE EVALUATIONS ARE INEXPENSIVE.
C    RKF45 SHOULD GENERALLY NOT BE USED WHEN THE USER IS DEMANDING
C    HIGH ACCURACY.
C
C ABSTRACT
C
C    SUBROUTINE  RKF45  INTEGRATES A SYSTEM OF NEQN FIRST ORDER
C    ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM
C             DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN))
C              WHERE THE Y(I) ARE GIVEN AT T .
C    TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TOUT BUT IT
C    CAN BE USED AS A ONE-STEP INTEGRATOR TO ADVANCE THE SOLUTION A
C    SINGLE STEP IN THE DIRECTION OF TOUT.  ON RETURN THE PARAMETERS IN
C    THE CALL LIST ARE SET FOR CONTINUING THE INTEGRATION. THE USER HAS
C    ONLY TO CALL RKF45 AGAIN (AND PERHAPS DEFINE A NEW VALUE FOR TOUT).
C    ACTUALLY, RKF45 IS AN INTERFACING ROUTINE WHICH CALLS SUBROUTINE
C    RKFS FOR THE SOLUTION.  RKFS IN TURN CALLS SUBROUTINE  FEHL WHICH
C    COMPUTES AN APPROXIMATE SOLUTION OVER ONE STEP.
C
C    RKF45  USES THE RUNGE-KUTTA-FEHLBERG (4,5)  METHOD DESCRIBED
C    IN THE REFERENCE
C    E.FEHLBERG , LOW-ORDER CLASSICAL RUNGE-KUTTA FORMULAS WITH STEPSIZE
C                 CONTROL , NASA TR R-315
C
C    THE PARAMETERS REPRESENT-
C      F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES YP(I)=DY(I)/DT
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- SOLUTION VECTOR AT T
C      T -- INDEPENDENT VARIABLE
C      TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED
C      RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR LOCAL
C            ERROR TEST. AT EACH STEP THE CODE REQUIRES THAT
C                 ABS(LOCAL ERROR) .LE. RELERR*ABS(Y) + ABSERR
C            FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION VECTORS
C      IFLAG -- INDICATOR FOR STATUS OF INTEGRATION
C      WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO RKF45 WHICH IS
C            NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED
C            AT LEAST  3+6*NEQN
C      IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL TO
C            RKF45 WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE
C            DIMENSIONED AT LEAST  5
C
C  FIRST CALL TO RKF45
C
C    THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE ARRAYS
C    IN THE CALL LIST  -      Y(NEQN) , WORK(3+6*NEQN) , IWORK(5)  ,
C    DECLARE F IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE F(T,Y,YP) AND
C    INITIALIZE THE FOLLOWING PARAMETERS-
C
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED.  (NEQN .GE. 1)
C      Y(*) -- VECTOR OF INITIAL CONDITIONS
C      T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE
C      TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED.
C            T=TOUT IS ALLOWED ON THE FIRST CALL ONLY, IN WHICH CASE
C            RKF45 RETURNS WITH IFLAG=2 IF CONTINUATION IS POSSIBLE.
C      RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES
C            WHICH MUST BE NON-NEGATIVE. RELERR MUST BE A VARIABLE WHILE
C            ABSERR MAY BE A CONSTANT. THE CODE SHOULD NORMALLY NOT BE
C            USED WITH RELATIVE ERROR CONTROL SMALLER THAN ABOUT 1.E-8 .
C            TO AVOID LIMITING PRECISION DIFFICULTIES THE CODE REQUIRES
C            RELERR TO BE LARGER THAN AN INTERNALLY COMPUTED RELATIVE
C            ERROR PARAMETER WHICH IS MACHINE DEPENDENT. IN PARTICULAR,
C            PURE ABSOLUTE ERROR IS NOT PERMITTED. IF A SMALLER THAN
C            ALLOWABLE VALUE OF RELERR IS ATTEMPTED, RKF45 INCREASES
C            RELERR APPROPRIATELY AND RETURNS CONTROL TO THE USER BEFORE
C            CONTINUING THE INTEGRATION.
C      IFLAG -- +1,-1  INDICATOR TO INITIALIZE THE CODE FOR EACH NEW
C            PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG=-1
C            ONLY WHEN ONE-STEP INTEGRATOR CONTROL IS ESSENTIAL. IN THIS
C            CASE, RKF45 ATTEMPTS TO ADVANCE THE SOLUTION A SINGLE STEP
C            IN THE DIRECTION OF TOUT EACH TIME IT IS CALLED. SINCE THIS
C            MODE OF OPERATION RESULTS IN EXTRA COMPUTING OVERHEAD, IT
C            SHOULD BE AVOIDED UNLESS NEEDED.
C
C  OUTPUT FROM RKF45
C
C      Y(*) -- SOLUTION AT T
C      T -- LAST POINT REACHED IN INTEGRATION.
C      IFLAG = 2 -- INTEGRATION REACHED TOUT.
C            =-2 -- A SINGLE SUCCESSFUL STEP IN THE DIRECTION OF TOUT
C                   HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING
C                   INTEGRATION ONE STEP AT A TIME.
C            = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE RELATIVE ERROR
C                   TOLERANCE WAS TOO SMALL. RELERR HAS BEEN INCREASED
C                   APPROPRIATELY FOR CONTINUING.
C            = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN
C                   3000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS
C                   IS APPROXIMATELY 500 STEPS.
C            = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION
C                   VANISHED MAKING A PURE RELATIVE ERROR TEST
C                   IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE.
C                   USING THE ONE-STEP INTEGRATION MODE FOR ONE STEP
C                   IS A GOOD WAY TO PROCEED.
C            = 6 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED
C                   ACCURACY COULD NOT BE ACHIEVED USING SMALLEST
C                   ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR
C                   TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE
C                   ATTEMPTED.
C            = 7 -- IT IS LIKELY THAT RKF45 IS INEFFICIENT FOR SOLVING
C                   THIS PROBLEM. TOO MUCH OUTPUT IS RESTRICTING THE
C                   NATURAL STEPSIZE CHOICE. USE THE ONE-STEP INTEGRATOR
C                   MODE.
C            = 8 -- INVALID INPUT PARAMETERS
C                   THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS
C                   SATISFIED -   NEQN .LE. 0
C                                 T=TOUT  AND  IFLAG .NE. +1 OR -1
C                                 RELERR OR ABSERR .LT. 0.
C                                 IFLAG .EQ. 0  OR  .LT. -2  OR  .GT. 8
C      WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO INTEREST
C                   TO THE USER BUT NECESSARY FOR SUBSEQUENT CALLS.
C                   WORK(1),...,WORK(NEQN) CONTAIN THE FIRST DERIVATIVES
C                   OF THE SOLUTION VECTOR Y AT T. WORK(NEQN+1) CONTAINS
C                   THE STEPSIZE H TO BE ATTEMPTED ON THE NEXT STEP.
C                   IWORK(1) CONTAINS THE DERIVATIVE EVALUATION COUNTER.
C
C  SUBSEQUENT CALLS TO RKF45
C
C    SUBROUTINE RKF45 RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE
C    INTEGRATION. IF THE INTEGRATION REACHED TOUT, THE USER NEED ONLY
C    DEFINE A NEW TOUT AND CALL RKF45 AGAIN. IN THE ONE-STEP INTEGRATOR
C    MODE (IFLAG=-2) THE USER MUST KEEP IN MIND THAT EACH STEP TAKEN IS
C    IN THE DIRECTION OF THE CURRENT TOUT. UPON REACHING TOUT (INDICATED
C    BY CHANGING IFLAG TO 2),THE USER MUST THEN DEFINE A NEW TOUT AND
C    RESET IFLAG TO -2 TO CONTINUE IN THE ONE-STEP INTEGRATOR MODE.
C
C    IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS TO
C    CONTINUE (IFLAG=3,4 CASES), HE JUST CALLS RKF45 AGAIN. WITH IFLAG=3
C    THE RELERR PARAMETER HAS BEEN ADJUSTED APPROPRIATELY FOR CONTINUING
C    THE INTEGRATION. IN THE CASE OF IFLAG=4 THE FUNCTION COUNTER WILL
C    BE RESET TO 0 AND ANOTHER 3000 FUNCTION EVALUATIONS ARE ALLOWED.
C
C    HOWEVER,IN THE CASE IFLAG=5, THE USER MUST FIRST ALTER THE ERROR
C    CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE INTEGRATION CAN
C    PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED.
C
C    ALSO,IN THE CASE IFLAG=6, IT IS NECESSARY FOR THE USER TO RESET
C    IFLAG TO 2 (OR -2 WHEN THE ONE-STEP INTEGRATION MODE IS BEING USED)
C    AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH BEFORE THE
C    INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, EXECUTION WILL
C    BE TERMINATED. THE OCCURRENCE OF IFLAG=6 INDICATES A TROUBLE SPOT
C    (SOLUTION IS CHANGING RAPIDLY,SINGULARITY MAY BE PRESENT) AND IT
C    OFTEN IS INADVISABLE TO CONTINUE.
C
C    IF IFLAG=7 IS ENCOUNTERED, THE USER SHOULD USE THE ONE-STEP MODE
C    OR SWITCH TO ANOTHER ROUTINE. IF THE USER INSISTS UPON CONTINUING
C    THE INTEGRATION WITH RKF45, THEN HE MUST RESET IFLAG TO 2 OR -2
C    BEFORE RECALLING RKF45. OTHERWISE, EXECUTION WILL BE TERMINATED.
C
C    IF IFLAG=8 IS OBTAINED, INTEGRATION CANNOT BE CONTINUED UNLESS
C    THE INVALID INPUT PARAMETERS ARE CORRECTED.
C
C    IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN INFORMATION
C    REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, WORK AND IWORK
C    SHOULD NOT BE ALTERED.
C
      INTEGER NEQN,IFLAG,IWORK(5)
      REAL Y(NEQN),T,TOUT,RELERR,ABSERR,WORK(*)
C
      EXTERNAL F
C
      INTEGER K1,K2,K3,K4,K5,K6,K1M
C
C     COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY
C
      K1M=NEQN+1
      K1=K1M+1
      K2=K1+NEQN
      K3=K2+NEQN
      K4=K3+NEQN
      K5=K4+NEQN
      K6=K5+NEQN
C
C     THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG
C     CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE
C     ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER,
C     HE MUST USE RKFS DIRECTLY.
C
      CALL RKFS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,WORK(1),WORK(K1M),
     1          WORK(K1),WORK(K2),WORK(K3),WORK(K4),WORK(K5),WORK(K6),
     2          WORK(K6+1),IWORK(1),IWORK(2),IWORK(3),IWORK(4),IWORK(5))
C
      RETURN
      END
      SUBROUTINE RKFS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,YP,H,F1,F2,F3,
     1                F4,F5,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,KFLAG)
C
C
C     RKFS INTEGRATES A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL
C     EQUATIONS AS DESCRIBED IN THE COMMENTS FOR RKF45 .
C     THE ARRAYS YP,F1,F2,F3,F4,AND F5 (OF DIMENSION AT LEAST NEQN) AND
C     THE VARIABLES H,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,AND KFLAG ARE USED
C     INTERNALLY BY THE CODE AND APPEAR IN THE CALL LIST TO ELIMINATE
C     LOCAL RETENTION OF VARIABLES BETWEEN CALLS. ACCORDINGLY, THEY
C     SHOULD NOT BE ALTERED. ITEMS OF POSSIBLE INTEREST ARE
C         YP - DERIVATIVE OF SOLUTION VECTOR AT T
C         H  - AN APPROPRIATE STEPSIZE TO BE USED FOR THE NEXT STEP
C         NFE- COUNTER ON THE NUMBER OF DERIVATIVE FUNCTION EVALUATIONS
C
      LOGICAL HFAILD,OUTPUT
C
      INTEGER  NEQN,IFLAG,NFE,KOP,INIT,JFLAG,KFLAG
      REAL  Y(NEQN),T,TOUT,RELERR,ABSERR,H,YP(NEQN),
     1  F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN),SAVRE,
     2  SAVAE
C
      EXTERNAL F
C
      REAL  A,AE,DT,EE,EEOET,ESTTOL,ET,HMIN,REMIN,RER,S,
     1  SCALE,TOL,TOLN,U26,EPS,YPK,SPMPAR
C
      INTEGER  K,MAXNFE,MFLAG
C
C     REMIN IS THE MINIMUM ACCEPTABLE VALUE OF RELERR.  ATTEMPTS
C     TO OBTAIN HIGHER ACCURACY WITH THIS SUBROUTINE ARE USUALLY
C     VERY EXPENSIVE AND OFTEN UNSUCCESSFUL.
C
      DATA REMIN/1.E-12/
C
C     THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER
C     OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE.
C     AS SET, THIS CORRESPONDS TO ABOUT 500 STEPS.
C
      DATA MAXNFE/3000/
C
C     CHECK INPUT PARAMETERS
C
      IF (NEQN .LT. 1) GO TO 10
      IF (RELERR .LT. 0.0 .OR. ABSERR .LT. 0.0) GO TO 10
      MFLAG = IABS(IFLAG)
      IF (MFLAG .EQ. 0 .OR. MFLAG .GT. 8) GO TO 10
C
C     COMPUTE THE RELATIVE MACHINE PRECISION
C
      EPS = SPMPAR(1)
      U26 = 26.0*EPS
      IF (MFLAG .NE. 1) GO TO 20
      GO TO 50
C
C     INVALID INPUT
C
   10 IFLAG = 8
      RETURN
C
C     CHECK CONTINUATION POSSIBILITIES
C
   20 IF (T .EQ. TOUT .AND. KFLAG .NE. 3) GO TO 10
      IF (MFLAG .NE. 2) GO TO 25
C
C     IFLAG = +2 OR -2
C
      IF (KFLAG .EQ. 3) GO TO 45
      IF (INIT .EQ. 0) GO TO 45
      IF (KFLAG .EQ. 4) GO TO 40
      IF ((KFLAG .EQ. 5)  .AND.  (ABSERR .EQ. 0.0)) GO TO 30
      IF ((KFLAG .EQ. 6)  .AND.  (RELERR .LE. SAVRE)  .AND.
     1    (ABSERR .LE. SAVAE)) GO TO 30
      GO TO 50
C
C     IFLAG = 3,4,5,6,7 OR 8
C
   25 IF (IFLAG .EQ. 3) GO TO 45
      IF (IFLAG .EQ. 4) GO TO 40
      IF (IFLAG .EQ. 5 .AND. ABSERR .GT. 0.0) GO TO 45
C
C     INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO
C     THE INSTRUCTIONS PERTAINING TO IFLAG=5,6,7 OR 8
C
   30 STOP
C
C     RESET FUNCTION EVALUATION COUNTER
C
   40 NFE = 0
      IF (MFLAG .EQ. 2) GO TO 50
C
C     RESET FLAG VALUE FROM PREVIOUS CALL
C
   45 IFLAG = JFLAG
      IF (KFLAG .EQ. 3) MFLAG = IABS(IFLAG)
C
C     SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT
C     INPUT CHECKING
C
   50 JFLAG = IFLAG
      KFLAG = 0
C
C     SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS
C
      SAVRE = RELERR
      SAVAE = ABSERR
C
C     RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS
C     2*EPS+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING
C     FROM IMPOSSIBLE ACCURACY REQUESTS
C
      RER = 2.0*EPS + REMIN
      IF (RELERR .GE. RER) GO TO 55
C
C     RELATIVE ERROR TOLERANCE TOO SMALL
C
      RELERR = RER
      IFLAG = 3
      KFLAG = 3
      RETURN
C
   55 DT = TOUT - T
C
      IF (MFLAG .EQ. 1) GO TO 60
      IF (INIT .EQ. 0) GO TO 65
      GO TO 80
C
C     INITIALIZATION --
C                       SET INITIALIZATION COMPLETION INDICATOR,INIT
C                       SET INDICATOR FOR TOO MANY OUTPUT POINTS,KOP
C                       EVALUATE INITIAL DERIVATIVES
C                       SET COUNTER FOR FUNCTION EVALUATIONS,NFE
C                       ESTIMATE STARTING STEPSIZE
C
   60 INIT = 0
      KOP = 0
C
      A = T
      CALL F(A,Y,YP)
      NFE = 1
      IF (T .NE. TOUT) GO TO 65
      IFLAG = 2
      RETURN
C
   65 INIT = 1
      H = ABS(DT)
      TOLN = 0.0
      DO 70 K = 1,NEQN
         TOL = RELERR*ABS(Y(K)) + ABSERR
         IF (TOL .LE. 0.) GO TO 70
         TOLN = TOL
         YPK = ABS(YP(K))
         IF (YPK*H**5 .GT. TOL) H=(TOL/YPK)**0.2
   70 CONTINUE
      IF (TOLN .LE. 0.0) H=0.0
      H = AMAX1(H,U26*AMAX1(ABS(T),ABS(DT)))
      JFLAG = ISIGN(2,IFLAG)
C
C     SET STEPSIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT
C
   80 H = SIGN(H,DT)
C
C     TEST TO SEE IF RKF45 IS BEING SEVERELY IMPACTED BY TOO MANY
C     OUTPUT POINTS
C
      IF (ABS(H) .GE. 2.0*ABS(DT)) KOP = KOP + 1
      IF (KOP .NE. 100) GO TO 85
C
C     UNNECESSARY FREQUENCY OF OUTPUT
      KOP = 0
      IFLAG = 7
      RETURN
C
   85 IF (ABS(DT) .GT. U26*ABS(T)) GO TO 95
C
C     IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN
C
      DO 90 K=1,NEQN
   90    Y(K) = Y(K) + DT*YP(K)
      A = TOUT
      CALL F(A,Y,YP)
      NFE = NFE + 1
      GO TO 300
C
C
C     INITIALIZE OUTPUT POINT INDICATOR
C
   95 OUTPUT = .FALSE.
C
C     TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION,
C     SCALE THE ERROR TOLERANCES
C
      SCALE = 2.0/RELERR
      AE = SCALE*ABSERR
C
C     STEP BY STEP INTEGRATION
C
  100 HFAILD = .FALSE.
C
C     SET SMALLEST ALLOWABLE STEPSIZE
C
      HMIN = U26*ABS(T)
C
C     ADJUST STEPSIZE IF NECESSARY TO HIT THE OUTPUT POINT.
C     LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEPSIZE AND
C     THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE.
C
      DT = TOUT - T
      IF (ABS(DT) .GE. 2.0*ABS(H)) GO TO 200
      IF (ABS(DT) .GT. ABS(H)) GO TO 150
C
C     THE NEXT SUCCESSFUL STEP WILL COMPLETE THE INTEGRATION TO THE
C     OUTPUT POINT
C
      OUTPUT = .TRUE.
      H = DT
      GO TO 200
C
  150 H=0.5*DT
C
C
C     CORE INTEGRATOR FOR TAKING A SINGLE STEP
C
C     THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW IN
C     COMPUTING THE ERROR TOLERANCE FUNCTION ET.
C     TO AVOID PROBLEMS WITH ZERO CROSSINGS,RELATIVE ERROR IS MEASURED
C     USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE
C     BEGINNING AND END OF A STEP.
C     THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF
C     SIGNIFICANCE.
C     TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED
C     TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T.
C     PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO
C     SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE
C     CHATTERING ON PROBLEMS HAVING DISCONTINUITIES.
C     TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE STEPSIZE
C     IT ESTIMATES WILL SUCCEED.
C     AFTER A STEP FAILURE, THE STEPSIZE IS NOT ALLOWED TO INCREASE FOR
C     THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE EFFICIENT ON
C     PROBLEMS HAVING DISCONTINUITIES AND MORE EFFECTIVE IN GENERAL
C     SINCE LOCAL EXTRAPOLATION IS BEING USED AND EXTRA CAUTION SEEMS
C     WARRANTED.
C
C     TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS.
C     IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H
C
  200 IF (NFE .LE. MAXNFE) GO TO 220
C
C     TOO MUCH WORK
C
      IFLAG = 4
      KFLAG = 4
      RETURN
C
C     ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H
C
  220 CALL FEHL (F,NEQN,Y,T,H,YP,F1,F2,F3,F4,F5,F1)
      NFE = NFE + 5
C
C     COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR ESTIMATES
C     AND REMOVE SCALING OF TOLERANCES. NOTE THAT RELATIVE ERROR IS
C     MEASURED WITH RESPECT TO THE AVERAGE OF THE MAGNITUDES OF THE
C     SOLUTION AT THE BEGINNING AND END OF THE STEP.
C
      EEOET = 0.0
      DO 250 K = 1,NEQN
         ET = ABS(Y(K)) + ABS(F1(K)) + AE
         IF (ET .GT. 0.0) GO TO 240
C
C        INAPPROPRIATE ERROR TOLERANCE
C
         IFLAG = 5
         RETURN
C
  240    EE = ABS((-2090.0*YP(K)+(21970.0*F3(K)-15048.0*F4(K)))+
     1                           (22528.0*F2(K)-27360.0*F5(K)))
  250    EEOET = AMAX1(EEOET,EE/ET)
C
      ESTTOL = ABS(H)*EEOET*SCALE/752400.0
      IF (ESTTOL .LE. 1.0) GO TO 260
C
C     UNSUCCESSFUL STEP
C                       REDUCE THE STEPSIZE , TRY AGAIN
C                       THE DECREASE IS LIMITED TO A FACTOR OF 1/10
C
      HFAILD = .TRUE.
      OUTPUT = .FALSE.
      S = 0.1
      IF (ESTTOL .LT. 59049.0) S = 0.9/ESTTOL**0.2
      H = S*H
      IF (ABS(H) .GT. HMIN) GO TO 200
C
C     REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE
C
      IFLAG = 6
      KFLAG = 6
      RETURN
C
C     SUCCESSFUL STEP
C                        STORE SOLUTION AT T+H
C                        AND EVALUATE DERIVATIVES THERE
C
  260 T = T + H
      DO 270 K = 1,NEQN
  270    Y(K) = F1(K)
      A = T
      CALL F(A,Y,YP)
      NFE = NFE + 1
C
C                       CHOOSE NEXT STEPSIZE
C                       THE INCREASE IS LIMITED TO A FACTOR OF 5
C                       IF STEP FAILURE HAS JUST OCCURRED, NEXT
C                          STEPSIZE IS NOT ALLOWED TO INCREASE
C
      S=5.0
      IF (ESTTOL .GT. 1.889568E-4) S=0.9/ESTTOL**0.2
      IF (HFAILD) S=AMIN1(S,1.0)
      H=SIGN(AMAX1(S*ABS(H),HMIN),H)
C
C     END OF CORE INTEGRATOR
C
C
C     SHOULD WE TAKE ANOTHER STEP
C
      IF (OUTPUT) GO TO 300
      IF (IFLAG .GT. 0) GO TO 100
C
C     INTEGRATION SUCCESSFULLY COMPLETED
C
C     ONE-STEP MODE
C
      IFLAG = -2
      RETURN
C
C     INTERVAL MODE
C
  300 T = TOUT
      IFLAG = 2
      RETURN
      END
      SUBROUTINE FEHL(F,NEQN,Y,T,H,YP,F1,F2,F3,F4,F5,S)
C
C     FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD
C
C    FEHL INTEGRATES A SYSTEM OF NEQN FIRST ORDER
C    ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM
C             DY(I)/DT=F(T,Y(1),---,Y(NEQN))
C    WHERE THE INITIAL VALUES Y(I) AND THE INITIAL DERIVATIVES
C    YP(I) ARE SPECIFIED AT THE STARTING POINT T. FEHL ADVANCES
C    THE SOLUTION OVER THE FIXED STEP H AND RETURNS
C    THE FIFTH ORDER (SIXTH ORDER ACCURATE LOCALLY) SOLUTION
C    APPROXIMATION AT T+H IN ARRAY S(I).
C    F1,---,F5 ARE ARRAYS OF DIMENSION NEQN WHICH ARE NEEDED
C    FOR INTERNAL STORAGE.
C    THE FORMULAS HAVE BEEN GROUPED TO CONTROL LOSS OF SIGNIFICANCE.
C    FEHL SHOULD BE CALLED WITH AN H NOT SMALLER THAN 13 UNITS OF
C    ROUNDOFF IN T SO THAT THE VARIOUS INDEPENDENT ARGUMENTS CAN BE
C    DISTINGUISHED.
C
C
      INTEGER  NEQN
      REAL  Y(NEQN),T,H,YP(NEQN),F1(NEQN),F2(NEQN),
     1  F3(NEQN),F4(NEQN),F5(NEQN),S(NEQN)
C
      REAL  CH
      INTEGER  K
      EXTERNAL F
C
      CH=H/4.0
      DO 221 K=1,NEQN
  221   F5(K)=Y(K)+CH*YP(K)
      CALL F(T+CH,F5,F1)
C
      CH=3.0*H/32.0
      DO 222 K=1,NEQN
  222   F5(K)=Y(K)+CH*(YP(K)+3.0*F1(K))
      CALL F(T+3.0*H/8.0,F5,F2)
C
      CH=H/2197.0
      DO 223 K=1,NEQN
  223   F5(K)=Y(K)+CH*(1932.0*YP(K)+(7296.0*F2(K)-7200.0*F1(K)))
      CALL F(T+12.0*H/13.0,F5,F3)
C
      CH=H/4104.0
      DO 224 K=1,NEQN
  224   F5(K)=Y(K)+CH*((8341.0*YP(K)-845.0*F3(K))+
     1                            (29440.0*F2(K)-32832.0*F1(K)))
      CALL F(T+H,F5,F4)
C
      CH=H/20520.0
      DO 225 K=1,NEQN
  225   F1(K)=Y(K)+CH*((-6080.0*YP(K)+(9295.0*F3(K)-
     1         5643.0*F4(K)))+(41040.0*F1(K)-28352.0*F2(K)))
      CALL F(T+H/2.0,F1,F5)
C
C     COMPUTE APPROXIMATE SOLUTION AT T+H
C
      CH=H/7618050.0
      DO 230 K=1,NEQN
  230   S(K)=Y(K)+CH*((902880.0*YP(K)+(3855735.0*F3(K)-
     1        1371249.0*F4(K)))+(3953664.0*F2(K)+
     2        277020.0*F5(K)))
C
      RETURN
      END
      SUBROUTINE GERK(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,GERROR,
     1                WORK,IWORK)
C
C     FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH
C     GLOBAL ERROR ASSESSMENT
C
C     WRITTEN BY H.A.WATTS AND L.F.SHAMPINE
C                   SANDIA LABORATORIES
C
C    GERK IS DESIGNED TO SOLVE SYSTEMS OF DIFFERENTIAL EQUATIONS WHEN
C    IT IS IMPORTANT TO HAVE A READILY AVAILABLE GLOBAL ERROR ESTIMATE.
C    PARALLEL INTEGRATION IS PERFORMED TO YIELD TWO SOLUTIONS ON
C    DIFFERENT MESH SPACINGS AND GLOBAL EXTRAPOLATION IS APPLIED TO
C    PROVIDE AN ESTIMATE OF THE GLOBAL ERROR IN THE MORE ACCURATE
C    SOLUTION.
C
C***********************************************************************
C ABSTRACT
C***********************************************************************
C
C    SUBROUTINE  GERK  INTEGRATES A SYSTEM OF NEQN FIRST ORDER
C    ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM
C             DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN))
C              WHERE THE Y(I) ARE GIVEN AT T .
C    TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TOUT BUT IT
C    CAN BE USED AS A ONE-STEP INTEGRATOR TO ADVANCE THE SOLUTION A
C    SINGLE STEP IN THE DIRECTION OF TOUT. ON RETURN,AN ESTIMATE OF THE
C    GLOBAL ERROR IN THE SOLUTION AT T IS PROVIDED AND THE PARAMETERS IN
C    THE CALL LIST ARE SET FOR CONTINUING THE INTEGRATION. THE USER HAS
C    ONLY TO CALL GERK AGAIN (AND PERHAPS DEFINE A NEW VALUE FOR TOUT).
C    ACTUALLY, GERK  IS MERELY AN INTERFACING ROUTINE WHICH ALLOCATES
C    VIRTUAL STORAGE IN THE ARRAYS WORK,IWORK AND CALLS SUBROUTINE GERKS
C    FOR THE SOLUTION.  GERKS  IN TURN CALLS SUBROUTINE  FEHL  WHICH
C    COMPUTES AN APPROXIMATE SOLUTION OVER ONE STEP.
C
C    GERK  USES THE RUNGE-KUTTA-FEHLBERG (4,5)  METHOD DESCRIBED
C    IN THE REFERENCE
C    E.FEHLBERG , LOW-ORDER CLASSICAL RUNGE-KUTTA FORMULAS WITH STEPSIZE
C                 CONTROL , NASA TR R-315
C
C
C    THE PARAMETERS REPRESENT-
C      F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES YP(I)=DY(I)/DT
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED
C      Y(*) -- SOLUTION VECTOR AT T
C      T -- INDEPENDENT VARIABLE
C      TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED
C      RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR LOCAL
C            ERROR TEST. AT EACH STEP THE CODE REQUIRES THAT
C                 ABS(LOCAL ERROR) .LE. RELERR*ABS(Y) + ABSERR
C            FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION VECTORS
C      IFLAG -- INDICATOR FOR STATUS OF INTEGRATION
C      GERROR(*) -- VECTOR WHICH ESTIMATES THE GLOBAL ERROR AT T. THAT
C                   IS, GERROR(I) APPROXIMATES  Y(I)-TRUE SOLUTION(I).
C      WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO GERK WHICH IS
C            NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED
C            AT LEAST  3+8*NEQN.
C      IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL TO
C            GERK WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE
C            DIMENSIONED AT LEAST  5.
C
C
C***********************************************************************
C  FIRST CALL TO GERK
C***********************************************************************
C
C    THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE ARRAYS
C    IN THE CALL LIST  -      Y(NEQN) , WORK(3+8*NEQN) , IWORK(5)  ,
C    DECLARE F IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE F(T,Y,YP) AND
C    INITIALIZE THE FOLLOWING PARAMETERS-
C
C      NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED.  (NEQN .GE. 1)
C      Y(*) -- VECTOR OF INITIAL CONDITIONS
C      T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE
C      TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED.
C            T=TOUT IS ALLOWED ON THE FIRST CALL ONLY,IN WHICH CASE GERK
C            RETURNS WITH IFLAG=2 IF CONTINUATION IS POSSIBLE.
C      RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES
C            WHICH MUST BE NON-NEGATIVE BUT MAY BE CONSTANTS. WE CAN
C            USUALLY EXPECT THE GLOBAL ERRORS TO BE SOMEWHAT SMALLER
C            THAN THE REQUESTED LOCAL ERROR TOLERANCES. TO AVOID
C            LIMITING PRECISION DIFFICULTIES THE CODE ALWAYS USES THE
C            LARGER OF RELERR AND AN INTERNAL RELATIVE ERROR PARAMETER
C            WHICH IS MACHINE DEPENDENT.
C      IFLAG -- +1,-1  INDICATOR TO INITIALIZE THE CODE FOR EACH NEW
C            PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG=-1
C            ONLY WHEN ONE-STEP INTEGRATOR CONTROL IS ESSENTIAL. IN THIS
C            CASE, GERK ATTEMPTS TO ADVANCE THE SOLUTION A SINGLE STEP
C            IN THE DIRECTION OF TOUT EACH TIME IT IS CALLED. SINCE THIS
C            MODE OF OPERATION RESULTS IN EXTRA COMPUTING OVERHEAD, IT
C            SHOULD BE AVOIDED UNLESS NEEDED.
C
C
C***********************************************************************
C  OUTPUT FROM GERK
C***********************************************************************
C
C      Y(*) -- SOLUTION AT T
C      T -- LAST POINT REACHED IN INTEGRATION.
C      IFLAG = 2 -- INTEGRATION REACHED TOUT.INDICATES SUCCESSFUL RETURN
C                   AND IS THE NORMAL MODE FOR CONTINUING INTEGRATION.
C            =-2 -- A SINGLE SUCCESSFUL STEP IN THE DIRECTION OF TOUT
C                   HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING
C                   INTEGRATION ONE STEP AT A TIME.
C            = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN
C                   9000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS
C                   IS APPROXIMATELY 500 STEPS.
C            = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION
C                   VANISHED MAKING A PURE RELATIVE ERROR TEST
C                   IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE.
C                   USING THE ONE-STEP INTEGRATION MODE FOR ONE STEP
C                   IS A GOOD WAY TO PROCEED.
C            = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED
C                   ACCURACY COULD NOT BE ACHIEVED USING SMALLEST
C                   ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR
C                   TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE
C                   ATTEMPTED.
C            = 6 -- GERK IS BEING USED INEFFICIENTLY IN SOLVING
C                   THIS PROBLEM. TOO MUCH OUTPUT IS RESTRICTING THE
C                   NATURAL STEPSIZE CHOICE. USE THE ONE-STEP
C                   INTEGRATOR MODE.
C            = 7 -- INVALID INPUT PARAMETERS
C                   THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS
C                   SATISFIED -   NEQN .LE. 0
C                                 T=TOUT  AND  IFLAG .NE. +1 OR -1
C                                 RELERR OR ABSERR .LT. 0.
C                                 IFLAG .EQ. 0  OR  .LT. -2  OR  .GT. 7
C      GERROR(*) -- ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T
C      WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO INTEREST
C                   TO THE USER BUT NECESSARY FOR SUBSEQUENT CALLS.
C                   WORK(1),...,WORK(NEQN) CONTAIN THE FIRST DERIVATIVES
C                   OF THE SOLUTION VECTOR Y AT T. WORK(NEQN+1) CONTAINS
C                   THE STEPSIZE H TO BE ATTEMPTED ON THE NEXT STEP.
C                   IWORK(1) CONTAINS THE DERIVATIVE EVALUATION COUNTER.
C
C
C***********************************************************************
C  SUBSEQUENT CALLS TO GERK
C***********************************************************************
C
C    SUBROUTINE GERK RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE THE
C    INTEGRATION. IF THE INTEGRATION REACHED TOUT,THE USER NEED ONLY
C    DEFINE A NEW TOUT AND CALL GERK AGAIN. IN THE ONE-STEP INTEGRATOR
C    MODE (IFLAG=-2) THE USER MUST KEEP IN MIND THAT EACH STEP TAKEN IS
C    IN THE DIRECTION OF THE CURRENT TOUT. UPON REACHING TOUT (INDICATED
C    BY CHANGING IFLAG TO 2),THE USER MUST THEN DEFINE A NEW TOUT AND
C    RESET IFLAG TO -2 TO CONTINUE IN THE ONE-STEP INTEGRATOR MODE.
C
C    IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS TO
C    CONTINUE (IFLAG=3 CASE), HE JUST CALLS GERK AGAIN. THE FUNCTION
C    COUNTER IS THEN RESET TO 0 AND ANOTHER 9000 FUNCTION EVALUATIONS
C    ARE ALLOWED.
C
C    HOWEVER,IN THE CASE IFLAG=4, THE USER MUST FIRST ALTER THE ERROR
C    CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE INTEGRATION CAN
C    PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED.
C
C    ALSO,IN THE CASE IFLAG=5, IT IS NECESSARY FOR THE USER TO RESET
C    IFLAG TO 2 (OR -2 WHEN THE ONE-STEP INTEGRATION MODE IS BEING USED)
C    AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH BEFORE THE
C    INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, EXECUTION WILL
C    BE TERMINATED. THE OCCURRENCE OF IFLAG=5 INDICATES A TROUBLE SPOT
C    (SOLUTION IS CHANGING RAPIDLY,SINGULARITY MAY BE PRESENT) AND IT
C    OFTEN IS INADVISABLE TO CONTINUE.
C
C    IF IFLAG=6 IS ENCOUNTERED, THE USER SHOULD USE THE ONE-STEP
C    INTEGRATION MODE WITH THE STEPSIZE DETERMINED BY THE CODE. IF THE
C    USER INSISTS UPON CONTINUING THE INTEGRATION WITH GERK IN THE
C    INTERVAL MODE, HE MUST RESET IFLAG TO 2 BEFORE CALLING GERK AGAIN.
C    OTHERWISE,EXECUTION WILL BE TERMINATED.
C
C    IF IFLAG=7 IS OBTAINED, INTEGRATION CAN NOT BE CONTINUED UNLESS
C    THE INVALID INPUT PARAMETERS ARE CORRECTED.
C
C    IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN INFORMATION
C    REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, WORK AND IWORK
C    SHOULD NOT BE ALTERED.
C
C***********************************************************************
C
      DIMENSION Y(NEQN),GERROR(NEQN),WORK(*),IWORK(5)
C
      EXTERNAL F
C
C
C     COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY
C
      K1M=NEQN+1
      K1=K1M+1
      K2=K1+NEQN
      K3=K2+NEQN
      K4=K3+NEQN
      K5=K4+NEQN
      K6=K5+NEQN
      K7=K6+NEQN
      K8=K7+NEQN
C
C***********************************************************************
C     THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG
C     CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE
C     ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER,
C     HE MUST USE GERKS DIRECTLY.
C***********************************************************************
C
      CALL GERKS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,GERROR,
     1          WORK(1),WORK(K1M),WORK(K1),WORK(K2),WORK(K3),WORK(K4),
     2          WORK(K5),WORK(K6),WORK(K7),WORK(K8),WORK(K8+1),
     3          IWORK(1),IWORK(2),IWORK(3),IWORK(4),IWORK(5))
C
      RETURN
      END
      SUBROUTINE GERKS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,GERROR,
     1                YP,H,F1,F2,F3,F4,F5,YG,YGP,SAVRE,SAVAE,
     2                NFE,KOP,INIT,JFLAG,KFLAG)
C
C     FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH
C     GLOBAL ERROR ASSESSMENT
C
C***********************************************************************
C
C     GERKS INTEGRATES A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL
C     EQUATIONS AS DESCRIBED IN THE COMMENTS FOR GERK.  THE ARRAYS
C     YP,F1,F2,F3,F4,F5,YG AND YGP (OF DIMENSION AT LEAST NEQN) AND
C     THE VARIABLES H,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,AND KFLAG ARE USED
C     INTERNALLY BY THE CODE AND APPEAR IN THE CALL LIST TO ELIMINATE
C     LOCAL RETENTION OF VARIABLES BETWEEN CALLS. ACCORDINGLY, THEY
C     SHOULD NOT BE ALTERED. ITEMS OF POSSIBLE INTEREST ARE
C         YP - DERIVATIVE OF SOLUTION VECTOR AT T
C         H  - AN APPROPRIATE STEPSIZE TO BE USED FOR THE NEXT STEP
C         NFE- COUNTER ON THE NUMBER OF DERIVATIVE FUNCTION EVALUATIONS
C
C***********************************************************************
C
      LOGICAL HFAILD,OUTPUT
C
      DIMENSION Y(NEQN),YP(NEQN),F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),
     1          F5(NEQN),YG(NEQN),YGP(NEQN),GERROR(NEQN)
C
      EXTERNAL F
C
C***********************************************************************
C  THE COMPUTER UNIT ROUNDOFF ERROR U IS THE SMALLEST POSITIVE VALUE
C  REPRESENTABLE IN THE MACHINE SUCH THAT  1.+ U .GT. 1.
C
      U = SPMPAR(1)
C
C***********************************************************************
C
C  REMIN IS A TOLERANCE THRESHOLD WHICH IS ALSO DETERMINED BY THE
C  INTEGRATION METHOD. IN PARTICULAR, A FIFTH ORDER METHOD WILL
C  GENERALLY NOT BE CAPABLE OF DELIVERING ACCURACIES NEAR LIMITING
C  PRECISION ON COMPUTERS WITH LONG WORDLENGTHS.
C
      REMIN = 3.E-11
C
C***********************************************************************
C
C     THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER
C     OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE.
C     AS SET,THIS CORRESPONDS TO ABOUT 500 STEPS.
C
      MAXNFE = 9000
C
C***********************************************************************
C
C
C     CHECK INPUT PARAMETERS
C
C
      IF (NEQN .LT. 1) GO TO 10
      IF ((RELERR .LT. 0.)  .OR.  (ABSERR .LT. 0.)) GO TO 10
      MFLAG=IABS(IFLAG)
      IF ((MFLAG .GE. 1)  .AND.  (MFLAG .LE. 7)) GO TO 20
C
C     INVALID INPUT
   10 IFLAG=7
      RETURN
C
C     IS THIS THE FIRST CALL
   20 IF (MFLAG .EQ. 1) GO TO 50
C
C     CHECK CONTINUATION POSSIBILITIES
C
      IF (T .EQ. TOUT) GO TO 10
      IF (MFLAG .NE. 2) GO TO 25
C
C     IFLAG = +2 OR -2
      IF (INIT .EQ. 0) GO TO 45
      IF (KFLAG .EQ. 3) GO TO 40
      IF ((KFLAG .EQ. 4)  .AND.  (ABSERR .EQ. 0.)) GO TO 30
      IF ((KFLAG .EQ. 5)  .AND.  (RELERR .LE. SAVRE)  .AND.
     1    (ABSERR .LE. SAVAE)) GO TO 30
      GO TO 50
C
C     IFLAG = 3,4,5,6, OR 7
   25 IF (IFLAG .EQ. 3) GO TO 40
      IF ((IFLAG .EQ. 4) .AND. (ABSERR .GT. 0.)) GO TO 45
C
C     INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO
C     THE INSTRUCTIONS PERTAINING TO IFLAG=4,5,6 OR 7
   30 STOP
C
C***********************************************************************
C
C     RESET FUNCTION EVALUATION COUNTER
   40 NFE=0
      IF (MFLAG .EQ. 2) GO TO 50
C
C     RESET FLAG VALUE FROM PREVIOUS CALL
   45 IFLAG=JFLAG
C
C     SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT
C     INPUT CHECKING
   50 JFLAG=IFLAG
      KFLAG=0
C
C     SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS
      SAVRE=RELERR
      SAVAE=ABSERR
C
C     RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS
C     32U+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING FROM
C     IMPOSSIBLE ACCURACY REQUESTS
C
      RER=AMAX1(RELERR,32.*U+REMIN)
C
      U26=26.*U
C
      DT=TOUT-T
C
      IF (MFLAG .EQ. 1) GO TO 60
      IF (INIT .EQ. 0) GO TO 65
      GO TO 80
C
C
C***********************************************************************
C
C     INITIALIZATION --
C                       SET INITIALIZATION COMPLETION INDICATOR,INIT
C                       SET INDICATOR FOR TOO MANY OUTPUT POINTS,KOP
C                       EVALUATE INITIAL DERIVATIVES
C                       COPY INITIAL VALUES AND DERIVATIVES FOR THE
C                             PARALLEL SOLUTION
C                       SET COUNTER FOR FUNCTION EVALUATIONS,NFE
C                       ESTIMATE STARTING STEPSIZE
C
   60 INIT=0
      KOP=0
C
      A=T
      CALL F(A,Y,YP)
      NFE=1
      IF (T .NE. TOUT) GO TO 65
      IFLAG=2
      RETURN
C
C
   65 INIT=1
      H=ABS(DT)
      TOLN=0.
      DO 70 K=1,NEQN
        YG(K)=Y(K)
        YGP(K)=YP(K)
        TOL=RER*ABS(Y(K))+ABSERR
        IF (TOL .LE. 0.) GO TO 70
        TOLN=TOL
        YPK=ABS(YP(K))
        IF (YPK*H**5 .GT. TOL) H=(TOL/YPK)**0.2
   70   CONTINUE
      IF (TOLN .LE. 0.) H=0.
      H=AMAX1(H,U26*AMAX1(ABS(T),ABS(DT)))
C
C
C***********************************************************************
C
C     SET STEPSIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT
C
   80 H=SIGN(H,DT)
C
C     TEST TO SEE IF GERK IS BEING SEVERELY IMPACTED BY TOO MANY
C     OUTPUT POINTS
C
      IF (ABS(H) .GT. 2.*ABS(DT)) KOP=KOP+1
      IF (KOP .NE. 100) GO TO 85
      KOP=0
      IFLAG=6
      RETURN
C
   85 IF (ABS(DT) .GT. U26*ABS(T)) GO TO 95
C
C     IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN
C
      DO 90 K=1,NEQN
        YG(K)=YG(K)+DT*YGP(K)
   90   Y(K)=Y(K)+DT*YP(K)
      A=TOUT
      CALL F(A,YG,YGP)
      CALL F(A,Y,YP)
      NFE=NFE+2
      GO TO 300
C
C     INITIALIZE OUTPUT POINT INDICATOR
C
   95 OUTPUT= .FALSE.
C
C     TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION,
C     SCALE THE ERROR TOLERANCES
C
      SCALE=2./RER
      AE=SCALE*ABSERR
C
C
C***********************************************************************
C***********************************************************************
C     STEP BY STEP INTEGRATION
C
  100 HFAILD= .FALSE.
C
C     SET SMALLEST ALLOWABLE STEPSIZE
C
      HMIN=U26*ABS(T)
C
C     ADJUST STEPSIZE IF NECESSARY TO HIT THE OUTPUT POINT.
C     LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEPSIZE
C     AND THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE.
C
      DT=TOUT-T
      IF (ABS(DT) .GE. 2.*ABS(H)) GO TO 200
      IF (ABS(DT) .GT. ABS(H)) GO TO 150
C
C     THE NEXT SUCCESSFUL STEP WILL COMPLETE THE INTEGRATION TO THE
C     OUTPUT POINT
C
      OUTPUT= .TRUE.
      H=DT
      GO TO 200
C
  150 H=0.5*DT
C
C
C
C***********************************************************************
C     CORE INTEGRATOR FOR TAKING A SINGLE STEP
C***********************************************************************
C     THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW IN
C     COMPUTING THE ERROR TOLERANCE FUNCTION ET.
C     TO AVOID PROBLEMS WITH ZERO CROSSINGS,RELATIVE ERROR IS MEASURED
C     USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE
C     BEGINNING AND END OF A STEP.
C     THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF
C     SIGNIFICANCE.
C     TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED
C     TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T.
C     PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO
C     SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE
C     CHATTERING ON PROBLEMS HAVING DISCONTINUITIES.
C     TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE STEPSIZE
C     IT ESTIMATES WILL SUCCEED.
C     AFTER A STEP FAILURE, THE STEPSIZE IS NOT ALLOWED TO INCREASE FOR
C     THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE EFFICIENT ON
C     PROBLEMS HAVING DISCONTINUITIES AND MORE EFFECTIVE IN GENERAL
C     SINCE LOCAL EXTRAPOLATION IS BEING USED AND THE ERROR ESTIMATE
C     MAY BE UNRELIABLE OR UNACCEPTABLE WHEN A STEP FAILS.
C***********************************************************************
C
C
C     TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS.
C     IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H
C
  200 IF (NFE .LE. MAXNFE) GO TO 220
C
C     TOO MUCH WORK
      IFLAG=3
      KFLAG=3
      RETURN
C
C     ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H
C
  220 CALL FEHL(F,NEQN,YG,T,H,YGP,F1,F2,F3,F4,F5,F1)
      NFE=NFE+5
C
C     COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR ESTIMATES
C     AND REMOVE SCALING OF TOLERANCES. NOTE THAT RELATIVE ERROR IS
C     MEASURED WITH RESPECT TO THE AVERAGE OF THE MAGNITUDES OF THE
C     SOLUTION AT THE BEGINNING AND END OF THE STEP.
C
      EEOET=0.
      DO 250 K=1,NEQN
        ET=ABS(YG(K))+ABS(F1(K))+AE
        IF (ET .GT. 0.) GO TO 240
C
C       INAPPROPRIATE ERROR TOLERANCE
        IFLAG=4
        KFLAG=4
        RETURN
C
  240   EE=ABS((-2090.*YGP(K)+(21970.*F3(K)-15048.*F4(K)))+
     1                        (22528.*F2(K)-27360.*F5(K)))
  250   EEOET=AMAX1(EEOET,EE/ET)
C
      ESTTOL=ABS(H)*EEOET*SCALE/752400.
C
      IF (ESTTOL .LE. 1.) GO TO 260
C
C
C     UNSUCCESSFUL STEP
C                       REDUCE THE STEPSIZE , TRY AGAIN
C                       THE DECREASE IS LIMITED TO A FACTOR OF 1/10
C
      HFAILD= .TRUE.
      OUTPUT= .FALSE.
      S=0.1
      IF (ESTTOL .LT. 59049.) S=0.9/ESTTOL**0.2
      H=S*H
      IF (ABS(H) .GT. HMIN) GO TO 200
C
C     REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE
      IFLAG=5
      KFLAG=5
      RETURN
C
C
C     SUCCESSFUL STEP
C                        STORE ONE-STEP SOLUTION YG AT T+H
C                        AND EVALUATE DERIVATIVES THERE
C
  260 TS=T
      T=T+H
      DO 270 K=1,NEQN
  270   YG(K)=F1(K)
      A=T
      CALL F(A,YG,YGP)
      NFE=NFE+1
C
C                        NOW ADVANCE THE Y SOLUTION OVER TWO STEPS OF
C                        LENGTH H/2 AND EVALUATE DERIVATIVES THERE
C
      HH=0.5*H
      CALL FEHL(F,NEQN,Y,TS,HH,YP,F1,F2,F3,F4,F5,Y)
      TS=TS+HH
      A=TS
      CALL F(A,Y,YP)
      CALL FEHL(F,NEQN,Y,TS,HH,YP,F1,F2,F3,F4,F5,Y)
      A=T
      CALL F(A,Y,YP)
      NFE=NFE+12
C
C
C                       CHOOSE NEXT STEPSIZE
C                       THE INCREASE IS LIMITED TO A FACTOR OF 5
C                       IF STEP FAILURE HAS JUST OCCURRED, NEXT
C                          STEPSIZE IS NOT ALLOWED TO INCREASE
C
      S=5.
      IF (ESTTOL .GT. 1.889568E-4) S=0.9/ESTTOL**0.2
      IF (HFAILD) S=AMIN1(S,1.)
      H=SIGN(AMAX1(S*ABS(H),HMIN),H)
C
C***********************************************************************
C     END OF CORE INTEGRATOR
C***********************************************************************
C
C
C
C     SHOULD WE TAKE ANOTHER STEP
C
      IF (OUTPUT) GO TO 300
      IF (IFLAG .GT. 0) GO TO 100
C
C***********************************************************************
C***********************************************************************
C
C
C     INTEGRATION SUCCESSFULLY COMPLETED
C
C     ONE-STEP MODE
      IFLAG=-2
      GO TO 400
C
C     INTERVAL MODE
  300 T=TOUT
      IFLAG=2
C
  400 DO 450 K=1,NEQN
  450   GERROR(K)=(YG(K)-Y(K))/31.
C
      RETURN
      END
      SUBROUTINE SFODE (F,NEQ,Y,T,TOUT,INFO,RERR,AERR,IDID,
     *                  RWORK,LRW,IWORK,LIW,RPAR,IPAR)
C     --------------
      EXTERNAL F, ZZZJAC
      REAL Y(NEQ), RTOL(1), ATOL(1), RWORK(LRW), RPAR(*)
      INTEGER INFO(*), INFO1(15), IWORK(LIW), IPAR(*)
C     --------------
      INFO1(1) = INFO(1)
      INFO1(2) = 0
      INFO1(3) = INFO(2)
      INFO1(4) = INFO(3)
      INFO1(5) = 0
      INFO1(6) = INFO(4)
C
      RTOL(1) = RERR
      ATOL(1) = AERR
      CALL STFODE (F,NEQ,Y,T,TOUT,INFO1,RTOL,ATOL,IDID,
     *             RWORK,LRW,IWORK,LIW,RPAR,IPAR,ZZZJAC)
      INFO(1) = INFO1(1)
      RERR = RTOL(1)
      AERR = ATOL(1)
      RETURN
      END
      SUBROUTINE SFODE1 (F,NEQ,Y,T,TOUT,INFO,RTOL,ATOL,IDID,
     *                   RWORK,LRW,IWORK,LIW,RPAR,IPAR)
C     --------------
      EXTERNAL F, ZZZJAC
      REAL Y(NEQ), RTOL(NEQ), ATOL(NEQ), RWORK(LRW), RPAR(*)
      INTEGER INFO(*), INFO1(15), IWORK(LIW), IPAR(*)
C     --------------
      INFO1(1) = INFO(1)
      INFO1(2) = 1
      INFO1(3) = INFO(2)
      INFO1(4) = INFO(3)
      INFO1(5) = 0
      INFO1(6) = INFO(4)
C
      CALL STFODE (F,NEQ,Y,T,TOUT,INFO1,RTOL,ATOL,IDID,
     *             RWORK,LRW,IWORK,LIW,RPAR,IPAR,ZZZJAC)
      INFO(1) = INFO1(1)
      RETURN
      END
      SUBROUTINE ZZZJAC(T,Y,PD,N,RPAR,IPAR)
C     -------------
C     DUMMY JACOBIAN SUBROUTINE
C     -------------
      DIMENSION Y(N), PD(N,*)
      DIMENSION RPAR(*), IPAR(*)
C     -------------
      T = 0.0
      RETURN
      END
      SUBROUTINE STFODE (F,NEQ,Y,T,TOUT,INFO,RTOL,ATOL,IDID,
     1                   RWORK,LRW,IWORK,LIW,RPAR,IPAR,JAC)
C***********************************************************************
C***PURPOSE
C   STFODE SOLVES INITIAL VALUE PROBLEMS IN ORDINARY DIFFERENTIAL
C   EQUATIONS USING BACKWARD DIFFERENTIATION FORMULAS. IT IS
C   BOTH VARIABLE ORDER (1-5) AND VARIABLE STEP.
C***DESCRIPTION
C
C   THIS IS A MODIFICATION BY A. H. MORRIS (NSWC) OF THE CODE
C   DEBDF, DESIGNED BY  L. F. SHAMPINE AND H. A. WATTS (1980).
C   DEBDF IS DOCUMENTED IN
C        SAND79-2374 , DEPAC - DESIGN OF A USER ORIENTED PACKAGE
C                              OF ODE SOLVERS.
C
C   STFODE IS A DRIVER FOR A MODIFICATION OF THE CODE LSODE WRITTEN BY
C             A. C. HINDMARSH
C             LAWRENCE LIVERMORE LABORATORY
C             LIVERMORE, CALIFORNIA 94550
C
C***********************************************************************
C** ABSTRACT **
C**************
C
C   SUBROUTINE STFODE USES THE BACKWARD DIFFERENTIATION FORMULAS OF
C   ORDERS ONE THROUGH FIVE TO INTEGRATE A SYSTEM OF NEQ FIRST ORDER
C   ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM
C                         DU/DX = F(X,U)
C   WHEN THE VECTOR Y(*) OF INITIAL VALUES FOR U(*) AT X=T IS GIVEN.
C   THE SUBROUTINE INTEGRATES FROM T TO TOUT. IT IS EASY TO CONTINUE THE
C   INTEGRATION TO GET RESULTS AT ADDITIONAL TOUT. THIS IS THE INTERVAL
C   MODE OF OPERATION. IT IS ALSO EASY FOR THE ROUTINE TO RETURN WITH
C   THE SOLUTION AT EACH INTERMEDIATE STEP ON THE WAY TO TOUT. THIS IS
C   THE INTERMEDIATE-OUTPUT MODE OF OPERATION.
C
C   STFODE USES SUBPROGRAMS LSOD1, INTYD, STOD, CFOD, PJAC, SLVS,VNWRMS,
C   HSTART, VNORM, SVCO, RSCO, SPMPAR, AND THE LINPACK ROUTINES SGEFA,
C   SGESL, SGBFA, SGBSL (WHICH ALSO USE THE BLAS ROUTINES SAXPY, SSCAL,
C   ISAMAX AND SDOT). THE ONLY MACHINE DEPENDENT PARAMETERS USED APPEAR
C   IN SPMPAR.
C
C***********************************************************************
C** DESCRIPTION OF THE ARGUMENTS TO STFODE (AN OVERVIEW) **
C**********************************************************
C
C   THE PARAMETERS ARE
C
C      F -- THIS IS THE NAME OF A SUBROUTINE WHICH YOU PROVIDE TO
C             DEFINE THE DIFFERENTIAL EQUATIONS.
C
C      NEQ -- THIS IS THE NUMBER OF (FIRST ORDER) DIFFERENTIAL
C             EQUATIONS TO BE INTEGRATED.
C
C      T -- THIS IS A VALUE OF THE INDEPENDENT VARIABLE.
C
C      Y(*) -- THIS ARRAY CONTAINS THE SOLUTION COMPONENTS AT T.
C
C      TOUT -- THIS IS A POINT AT WHICH A SOLUTION IS DESIRED.
C
C      INFO(*) -- THE BASIC TASK OF THE CODE IS TO INTEGRATE THE
C             DIFFERENTIAL EQUATIONS FROM T TO TOUT AND RETURN AN
C             ANSWER AT TOUT. INFO(*) IS AN INTEGER ARRAY WHICH IS USED
C             TO COMMUNICATE EXACTLY HOW YOU WANT THIS TASK TO BE
C             CARRIED OUT.
C
C      RTOL, ATOL -- THESE QUANTITIES REPRESENT RELATIVE AND ABSOLUTE
C             ERROR TOLERANCES WHICH YOU PROVIDE TO INDICATE HOW
C             ACCURATELY YOU WISH THE SOLUTION TO BE COMPUTED. YOU MAY
C             CHOOSE THEM TO BE BOTH SCALARS OR ELSE BOTH VECTORS.
C
C      IDID -- THIS SCALAR QUANTITY IS AN INDICATOR REPORTING WHAT
C             THE CODE DID. YOU MUST MONITOR THIS INTEGER VARIABLE TO
C             DECIDE WHAT ACTION TO TAKE NEXT.
C
C      RWORK(*), LRW -- RWORK(*) IS A REAL WORK ARRAY OF LENGTH LRW
C             WHICH PROVIDES THE CODE WITH NEEDED STORAGE SPACE.
C
C      IWORK(*), LIW -- IWORK(*) IS AN INTEGER WORK ARRAY OF LENGTH LIW
C             WHICH PROVIDES THE CODE WITH NEEDED STORAGE SPACE.
C
C      RPAR, IPAR -- THESE ARE REAL AND INTEGER PARAMETER ARRAYS WHICH
C             YOU CAN USE FOR COMMUNICATION BETWEEN YOUR CALLING
C             PROGRAM AND THE F SUBROUTINE (AND THE JAC SUBROUTINE).
C
C      JAC -- THIS IS THE NAME OF A SUBROUTINE WHICH YOU MAY CHOOSE TO
C             PROVIDE FOR DEFINING THE JACOBIAN MATRIX OF PARTIAL
C             DERIVATIVES DF/DU.
C
C  QUANTITIES WHICH ARE USED AS INPUT ITEMS ARE
C             NEQ, T, Y(*), TOUT, INFO(*),
C             RTOL, ATOL, RWORK(1), LRW,
C             IWORK(1), IWORK(2), AND LIW.
C
C  QUANTITIES WHICH MAY BE ALTERED BY THE CODE ARE
C             T, Y(*), INFO(1), RTOL, ATOL,
C             IDID, RWORK(*) AND IWORK(*).
C
C***********************************************************************
C** INPUT -- WHAT TO DO ON THE FIRST CALL TO STFODE **
C*****************************************************
C
C   THE FIRST CALL OF THE CODE IS DEFINED TO BE THE START OF EACH NEW
C   PROBLEM. READ THROUGH THE DESCRIPTIONS OF ALL THE FOLLOWING ITEMS,
C   PROVIDE SUFFICIENT STORAGE SPACE FOR DESIGNATED ARRAYS, SET
C   APPROPRIATE VARIABLES FOR THE INITIALIZATION OF THE PROBLEM, AND
C   GIVE INFORMATION ABOUT HOW YOU WANT THE PROBLEM TO BE SOLVED.
C
C
C      F -- PROVIDE A SUBROUTINE OF THE FORM
C                               F(X,U,UPRIME,RPAR,IPAR)
C             TO DEFINE THE SYSTEM OF FIRST ORDER DIFFERENTIAL EQUATIONS
C             WHICH IS TO BE SOLVED. FOR THE GIVEN VALUES OF X AND THE
C             VECTOR  U(*)=(U(1),U(2),...,U(NEQ)) , THE SUBROUTINE MUST
C             EVALUATE THE NEQ COMPONENTS OF THE SYSTEM OF DIFFERENTIAL
C             EQUATIONS  DU/DX=F(X,U)  AND STORE THE DERIVATIVES IN THE
C             ARRAY UPRIME(*), THAT IS,  UPRIME(I) = * DU(I)/DX *  FOR
C             EQUATIONS I=1,...,NEQ.
C
C             SUBROUTINE F MUST NOT ALTER X OR U(*). YOU MUST DECLARE
C             THE NAME F IN AN EXTERNAL STATEMENT IN YOUR PROGRAM THAT
C             CALLS STFODE. YOU MUST DIMENSION U AND UPRIME IN F.
C
C             RPAR AND IPAR ARE REAL AND INTEGER PARAMETER ARRAYS WHICH
C             YOU CAN USE FOR COMMUNICATION BETWEEN YOUR CALLING PROGRAM
C             AND SUBROUTINE F. THEY ARE NOT USED OR ALTERED BY STFODE.
C             IF YOU DO NOT NEED RPAR OR IPAR, IGNORE THESE PARAMETERS
C             BY TREATING THEM AS DUMMY ARGUMENTS. IF YOU DO CHOOSE TO
C             USE THEM, DIMENSION THEM IN YOUR CALLING PROGRAM AND IN F
C             AS ARRAYS OF APPROPRIATE LENGTH.
C
C      NEQ -- SET IT TO THE NUMBER OF DIFFERENTIAL EQUATIONS.
C             (NEQ .GE. 1)
C
C      T -- SET IT TO THE INITIAL POINT OF THE INTEGRATION.
C             YOU MUST USE A PROGRAM VARIABLE FOR T BECAUSE THE CODE
C             CHANGES ITS VALUE.
C
C      Y(*) -- SET THIS VECTOR TO THE INITIAL VALUES OF THE NEQ SOLUTION
C             COMPONENTS AT THE INITIAL POINT. YOU MUST DIMENSION Y AT
C             LEAST NEQ IN YOUR CALLING PROGRAM.
C
C      TOUT -- SET IT TO THE FIRST POINT AT WHICH A SOLUTION
C             IS DESIRED. YOU CAN TAKE TOUT = T, IN WHICH CASE THE CODE
C             WILL EVALUATE THE DERIVATIVE OF THE SOLUTION AT T AND
C             RETURN. INTEGRATION EITHER FORWARD IN T  (TOUT .GT. T)  OR
C             BACKWARD IN T  (TOUT .LT. T)  IS PERMITTED.
C
C             THE CODE ADVANCES THE SOLUTION FROM T TO TOUT USING
C             STEP SIZES WHICH ARE AUTOMATICALLY SELECTED SO AS TO
C             ACHIEVE THE DESIRED ACCURACY. IF YOU WISH, THE CODE WILL
C             RETURN WITH THE SOLUTION AND ITS DERIVATIVE FOLLOWING
C             EACH INTERMEDIATE STEP (INTERMEDIATE-OUTPUT MODE) SO THAT
C             YOU CAN MONITOR THEM, BUT YOU STILL MUST PROVIDE TOUT IN
C             ACCORD WITH THE BASIC AIM OF THE CODE.
C
C             THE FIRST STEP TAKEN BY THE CODE IS A CRITICAL ONE
C             BECAUSE IT MUST REFLECT HOW FAST THE SOLUTION CHANGES NEAR
C             THE INITIAL POINT. THE CODE AUTOMATICALLY SELECTS AN
C             INITIAL STEP SIZE WHICH IS PRACTICALLY ALWAYS SUITABLE FOR
C             THE PROBLEM. BY USING THE FACT THAT THE CODE WILL NOT STEP
C             PAST TOUT IN THE FIRST STEP, YOU COULD, IF NECESSARY,
C             RESTRICT THE LENGTH OF THE INITIAL STEP SIZE.
C
C             FOR SOME PROBLEMS IT MAY NOT BE PERMISSIBLE TO INTEGRATE
C             PAST A POINT TSTOP BECAUSE A DISCONTINUITY OCCURS THERE
C             OR THE SOLUTION OR ITS DERIVATIVE IS NOT DEFINED BEYOND
C             TSTOP. WHEN YOU HAVE DECLARED A TSTOP POINT (SEE INFO(4)
C             AND RWORK(1)), YOU HAVE TOLD THE CODE NOT TO INTEGRATE
C             PAST TSTOP. IN THIS CASE ANY TOUT BEYOND TSTOP IS INVALID
C             INPUT.
C
C      INFO(*) -- USE THE INFO ARRAY TO GIVE THE CODE MORE DETAILS ABOUT
C             HOW YOU WANT YOUR PROBLEM SOLVED. THIS ARRAY SHOULD BE
C             DIMENSIONED OF LENGTH 15 TO ACCOMODATE OTHER MEMBERS OF
C             DEPAC OR POSSIBLE FUTURE EXTENSIONS, THOUGH STFODE USES
C             ONLY THE FIRST SIX ENTRIES. YOU MUST RESPOND TO ALL OF
C             THE FOLLOWING ITEMS WHICH ARE ARRANGED AS QUESTIONS. THE
C             SIMPLEST USE OF THE CODE CORRESPONDS TO ANSWERING ALL
C             QUESTIONS AS YES ,I.E. SETTING ALL ENTRIES OF INFO TO 0.
C
C        INFO(1) -- THIS PARAMETER ENABLES THE CODE TO INITIALIZE
C               ITSELF. YOU MUST SET IT TO INDICATE THE START OF EVERY
C               NEW PROBLEM.
C
C            **** IS THIS THE FIRST CALL FOR THIS PROBLEM ...
C                  YES -- SET INFO(1) = 0
C                   NO -- NOT APPLICABLE HERE.
C                         SEE BELOW FOR CONTINUATION CALLS.  ****
C
C        INFO(2) -- HOW MUCH ACCURACY YOU WANT OF YOUR SOLUTION
C               IS SPECIFIED BY THE ERROR TOLERANCES RTOL AND ATOL.
C               THE SIMPLEST USE IS TO TAKE THEM BOTH TO BE SCALARS.
C               TO OBTAIN MORE FLEXIBILITY, THEY CAN BOTH BE VECTORS.
C               THE CODE MUST BE TOLD YOUR CHOICE.
C
C            **** ARE BOTH ERROR TOLERANCES RTOL, ATOL SCALARS ...
C                  YES -- SET INFO(2) = 0
C                         AND INPUT SCALARS FOR BOTH RTOL AND ATOL
C                   NO -- SET INFO(2) = 1
C                         AND INPUT ARRAYS FOR BOTH RTOL AND ATOL ****
C
C        INFO(3) -- THE CODE INTEGRATES FROM T IN THE DIRECTION
C               OF TOUT BY STEPS. IF YOU WISH, IT WILL RETURN THE
C               COMPUTED SOLUTION AND DERIVATIVE AT THE NEXT
C               INTERMEDIATE STEP (THE INTERMEDIATE-OUTPUT MODE) OR
C               TOUT, WHICHEVER COMES FIRST. THIS IS A GOOD WAY TO
C               PROCEED IF YOU WANT TO SEE THE BEHAVIOR OF THE SOLUTION.
C               IF YOU MUST HAVE SOLUTIONS AT A GREAT MANY SPECIFIC
C               TOUT POINTS, THIS CODE WILL COMPUTE THEM EFFICIENTLY.
C
C            **** DO YOU WANT THE SOLUTION ONLY AT
C                 TOUT (AND NOT AT THE NEXT INTERMEDIATE STEP) ...
C                  YES -- SET INFO(3) = 0
C                   NO -- SET INFO(3) = 1 ****
C
C        INFO(4) -- TO HANDLE SOLUTIONS AT A GREAT MANY SPECIFIC
C               VALUES TOUT EFFICIENTLY, THIS CODE MAY INTEGRATE PAST
C               TOUT AND INTERPOLATE TO OBTAIN THE RESULT AT TOUT.
C               SOMETIMES IT IS NOT POSSIBLE TO INTEGRATE BEYOND SOME
C               POINT TSTOP BECAUSE THE EQUATION CHANGES THERE OR IT IS
C               NOT DEFINED PAST TSTOP. THEN YOU MUST TELL THE CODE
C               NOT TO GO PAST.
C
C            **** CAN THE INTEGRATION BE CARRIED OUT WITHOUT ANY
C                 RESTRICTIONS ON THE INDEPENDENT VARIABLE T ...
C                  YES -- SET INFO(4)=0
C                   NO -- SET INFO(4)=1
C                         AND DEFINE THE STOPPING POINT TSTOP BY
C                         SETTING RWORK(1)=TSTOP ****
C
C        INFO(5) -- TO SOLVE STIFF PROBLEMS IT IS NECESSARY TO USE THE
C               JACOBIAN MATRIX OF PARTIAL DERIVATIVES OF THE SYSTEM
C               OF DIFFERENTIAL EQUATIONS. IF YOU DO NOT PROVIDE A
C               SUBROUTINE TO EVALUATE IT ANALYTICALLY (SEE THE
C               DESCRIPTION OF THE ITEM JAC IN THE CALL LIST), IT WILL
C               BE APPROXIMATED BY NUMERICAL DIFFERENCING IN THIS CODE.
C               ALTHOUGH IT IS LESS TROUBLE FOR YOU TO HAVE THE CODE
C               COMPUTE PARTIAL DERIVATIVES BY NUMERICAL DIFFERENCING,
C               THE SOLUTION WILL BE MORE RELIABLE IF YOU PROVIDE THE
C               DERIVATIVES VIA JAC. SOMETIMES NUMERICAL DIFFERENCING
C               IS CHEAPER THAN EVALUATING DERIVATIVES IN JAC AND
C               SOMETIMES IT IS NOT - THIS DEPENDS ON YOUR PROBLEM.
C
C               IF YOUR PROBLEM IS LINEAR, I.E. HAS THE FORM
C               DU/DX = F(X,U) = J(X)*U + G(X)   FOR SOME MATRIX J(X)
C               AND VECTOR G(X), THE JACOBIAN MATRIX  DF/DU = J(X).
C               SINCE YOU MUST PROVIDE A SUBROUTINE TO EVALUATE F(X,U)
C               ANALYTICALLY, IT IS LITTLE EXTRA TROUBLE TO PROVIDE
C               SUBROUTINE JAC FOR EVALUATING J(X) ANALYTICALLY.
C               FURTHERMORE, IN SUCH CASES, NUMERICAL DIFFERENCING IS
C               MUCH MORE EXPENSIVE THAN ANALYTIC EVALUATION.
C
C            **** DO YOU WANT THE CODE TO EVALUATE THE PARTIAL
C                 DERIVATIVES AUTOMATICALLY BY NUMERICAL DIFFERENCES ...
C                  YES -- SET INFO(5)=0
C                   NO -- SET INFO(5)=1
C                         AND PROVIDE SUBROUTINE JAC FOR EVALUATING THE
C                         JACOBIAN MATRIX ****
C
C        INFO(6) -- STFODE WILL PERFORM MUCH BETTER IF THE JACOBIAN
C               MATRIX IS BANDED AND THE CODE IS TOLD THIS. IN THIS
C               CASE, THE STORAGE NEEDED WILL BE GREATLY REDUCED,
C               NUMERICAL DIFFERENCING WILL BE PERFORMED MORE CHEAPLY,
C               AND A NUMBER OF IMPORTANT ALGORITHMS WILL EXECUTE MUCH
C               FASTER. THE DIFFERENTIAL EQUATION IS SAID TO HAVE
C               HALF-BANDWIDTHS ML (LOWER) AND MU (UPPER) IF EQUATION I
C               INVOLVES ONLY UNKNOWNS Y(J) WITH
C                              I-ML .LE. J .LE. I+MU
C               FOR ALL I=1,2,...,NEQ. THUS, ML AND MU ARE THE WIDTHS
C               OF THE LOWER AND UPPER PARTS OF THE BAND, RESPECTIVELY,
C               WITH THE MAIN DIAGONAL BEING EXCLUDED. IF YOU DO NOT
C               INDICATE THAT THE EQUATION HAS A BANDED JACOBIAN,
C               THE CODE WORKS WITH A FULL MATRIX OF NEQ**2 ELEMENTS
C               (STORED IN THE CONVENTIONAL WAY). COMPUTATIONS WITH
C               BANDED MATRICES COST LESS TIME AND STORAGE THAN WITH
C               FULL MATRICES IF  2*ML+MU .LT. NEQ.  IF YOU TELL THE
C               CODE THAT THE JACOBIAN MATRIX HAS A BANDED STRUCTURE AND
C               YOU WANT TO PROVIDE SUBROUTINE JAC TO COMPUTE THE
C               PARTIAL DERIVATIVES, THEN YOU MUST BE CAREFUL TO STORE
C               THE ELEMENTS OF THE JACOBIAN MATRIX IN THE SPECIAL FORM
C               INDICATED IN THE DESCRIPTION OF JAC.
C
C            **** DO YOU WANT TO SOLVE THE PROBLEM USING A FULL
C                 (DENSE) JACOBIAN MATRIX (AND NOT A SPECIAL BANDED
C                 STRUCTURE) ...
C                  YES -- SET INFO(6)=0
C                   NO -- SET INFO(6)=1
C                         AND PROVIDE THE LOWER (ML) AND UPPER (MU)
C                         BANDWIDTHS BY SETTING
C                         IWORK(1)=ML
C                         IWORK(2)=MU ****
C
C      RTOL, ATOL -- YOU MUST ASSIGN RELATIVE (RTOL) AND ABSOLUTE (ATOL)
C             ERROR TOLERANCES TO TELL THE CODE HOW ACCURATELY YOU WANT
C             THE SOLUTION TO BE COMPUTED. THEY MUST BE DEFINED AS
C             PROGRAM VARIABLES BECAUSE THE CODE MAY CHANGE THEM. YOU
C             HAVE TWO CHOICES --
C                  BOTH RTOL AND ATOL ARE SCALARS. (INFO(2)=0)
C                  BOTH RTOL AND ATOL ARE VECTORS. (INFO(2)=1)
C             IN EITHER CASE ALL COMPONENTS MUST BE NON-NEGATIVE.
C
C             THE TOLERANCES ARE USED BY THE CODE IN A LOCAL ERROR TEST
C             AT EACH STEP WHICH REQUIRES ROUGHLY THAT
C                     ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL
C             FOR EACH VECTOR COMPONENT.
C             (MORE SPECIFICALLY, A ROOT-MEAN-SQUARE NORM IS USED TO
C             MEASURE THE SIZE OF VECTORS, AND THE ERROR TEST USES THE
C             MAGNITUDE OF THE SOLUTION AT THE BEGINNING OF THE STEP.)
C
C             THE TRUE (GLOBAL) ERROR IS THE DIFFERENCE BETWEEN THE TRUE
C             SOLUTION OF THE INITIAL VALUE PROBLEM AND THE COMPUTED
C             APPROXIMATION. PRACTICALLY ALL PRESENT DAY CODES,
C             INCLUDING THIS ONE, CONTROL THE LOCAL ERROR AT EACH STEP
C             AND DO NOT EVEN ATTEMPT TO CONTROL THE GLOBAL ERROR
C             DIRECTLY. ROUGHLY SPEAKING, THEY PRODUCE A SOLUTION Y(T)
C             WHICH SATISFIES THE DIFFERENTIAL EQUATIONS WITH A
C             RESIDUAL R(T),    DY(T)/DT = F(T,Y(T)) + R(T)   ,
C             AND, ALMOST ALWAYS, R(T) IS BOUNDED BY THE ERROR
C             TOLERANCES. USUALLY, BUT NOT ALWAYS, THE TRUE ACCURACY OF
C             THE COMPUTED Y IS COMPARABLE TO THE ERROR TOLERANCES. THIS
C             CODE WILL USUALLY, BUT NOT ALWAYS, DELIVER A MORE ACCURATE
C             SOLUTION IF YOU REDUCE THE TOLERANCES AND INTEGRATE AGAIN.
C             BY COMPARING TWO SUCH SOLUTIONS YOU CAN GET A FAIRLY
C             RELIABLE IDEA OF THE TRUE ERROR IN THE SOLUTION AT THE
C             BIGGER TOLERANCES.
C
C             SETTING ATOL=0. RESULTS IN A PURE RELATIVE ERROR TEST ON
C             THAT COMPONENT. SETTING RTOL=0. RESULTS IN A PURE ABSOLUTE
C             ERROR TEST ON THAT COMPONENT. A MIXED TEST WITH NON-ZERO
C             RTOL AND ATOL CORRESPONDS ROUGHLY TO A RELATIVE ERROR
C             TEST WHEN THE SOLUTION COMPONENT IS MUCH BIGGER THAN ATOL
C             AND TO AN ABSOLUTE ERROR TEST WHEN THE SOLUTION COMPONENT
C             IS SMALLER THAN THE THRESHOLD ATOL.
C
C             PROPER SELECTION OF THE ABSOLUTE ERROR CONTROL PARAMETERS
C             ATOL  REQUIRES YOU TO HAVE SOME IDEA OF THE SCALE OF THE
C             SOLUTION COMPONENTS. TO ACQUIRE THIS INFORMATION MAY MEAN
C             THAT YOU WILL HAVE TO SOLVE THE PROBLEM MORE THAN ONCE. IN
C             THE ABSENCE OF SCALE INFORMATION, YOU SHOULD ASK FOR SOME
C             RELATIVE ACCURACY IN ALL THE COMPONENTS (BY SETTING  RTOL
C             VALUES NON-ZERO) AND PERHAPS IMPOSE EXTREMELY SMALL
C             ABSOLUTE ERROR TOLERANCES TO PROTECT AGAINST THE DANGER OF
C             A SOLUTION COMPONENT BECOMING ZERO.
C
C             THE CODE WILL NOT ATTEMPT TO COMPUTE A SOLUTION AT AN
C             ACCURACY UNREASONABLE FOR THE MACHINE BEING USED. IT WILL
C             ADVISE YOU IF YOU ASK FOR TOO MUCH ACCURACY AND INFORM
C             YOU AS TO THE MAXIMUM ACCURACY IT BELIEVES POSSIBLE.
C
C      RWORK(*) -- DIMENSION THIS REAL WORK ARRAY OF LENGTH LRW IN YOUR
C             CALLING PROGRAM.
C
C      RWORK(1) -- IF YOU HAVE SET INFO(4)=0, YOU CAN IGNORE THIS
C             OPTIONAL INPUT PARAMETER. OTHERWISE YOU MUST DEFINE A
C             STOPPING POINT TSTOP BY SETTING   RWORK(1) = TSTOP.
C             (FOR SOME PROBLEMS IT MAY NOT BE PERMISSIBLE TO INTEGRATE
C             PAST A POINT TSTOP BECAUSE A DISCONTINUITY OCCURS THERE
C             OR THE SOLUTION OR ITS DERIVATIVE IS NOT DEFINED BEYOND
C             TSTOP.)
C
C      LRW -- SET IT TO THE DECLARED LENGTH OF THE RWORK ARRAY.
C             YOU MUST HAVE
C                  LRW .GE. 250+10*NEQ+NEQ**2
C             FOR THE FULL (DENSE) JACOBIAN CASE (WHEN INFO(6)=0),  OR
C                  LRW .GE. 250+10*NEQ+(2*ML+MU+1)*NEQ
C             FOR THE BANDED JACOBIAN CASE (WHEN INFO(6)=1).
C
C      IWORK(*) -- DIMENSION THIS INTEGER WORK ARRAY OF LENGTH LIW IN
C             YOUR CALLING PROGRAM.
C
C      IWORK(1), IWORK(2) -- IF YOU HAVE SET INFO(6)=0, YOU CAN IGNORE
C             THESE OPTIONAL INPUT PARAMETERS. OTHERWISE YOU MUST DEFINE
C             THE HALF-BANDWIDTHS ML (LOWER) AND MU (UPPER) OF THE
C             JACOBIAN MATRIX BY SETTING    IWORK(1) = ML   AND
C             IWORK(2) = MU.  (THE CODE WILL WORK WITH A FULL MATRIX
C             OF NEQ**2 ELEMENTS UNLESS IT IS TOLD THAT THE PROBLEM HAS
C             A BANDED JACOBIAN, IN WHICH CASE THE CODE WILL WORK WITH
C             A MATRIX CONTAINING AT MOST  (2*ML+MU+1)*NEQ  ELEMENTS.)
C
C      LIW -- SET IT TO THE DECLARED LENGTH OF THE IWORK ARRAY.
C             YOU MUST HAVE LIW .GE. 55+NEQ.
C
C      RPAR, IPAR -- THESE ARE PARAMETER ARRAYS, OF REAL AND INTEGER
C             TYPE, RESPECTIVELY. YOU CAN USE THEM FOR COMMUNICATION
C             BETWEEN YOUR PROGRAM THAT CALLS STFODE AND THE  F
C             SUBROUTINE (AND THE JAC SUBROUTINE). THEY ARE NOT USED OR
C             ALTERED BY STFODE. IF YOU DO NOT NEED RPAR OR IPAR, IGNORE
C             THESE PARAMETERS BY TREATING THEM AS DUMMY ARGUMENTS. IF
C             YOU DO CHOOSE TO USE THEM, DIMENSION THEM IN YOUR CALLING
C             PROGRAM AND IN F (AND IN JAC) AS ARRAYS OF APPROPRIATE
C             LENGTH.
C
C      JAC -- IF YOU HAVE SET INFO(5)=0, YOU CAN IGNORE THIS PARAMETER
C             BY TREATING IT AS A DUMMY ARGUMENT. (FOR SOME COMPILERS
C             YOU MAY HAVE TO WRITE A DUMMY SUBROUTINE NAMED  JAC  IN
C             ORDER TO AVOID PROBLEMS ASSOCIATED WITH MISSING EXTERNAL
C             ROUTINE NAMES.)  OTHERWISE, YOU MUST PROVIDE A SUBROUTINE
C             OF THE FORM
C                          JAC(X,U,PD,NROWPD,RPAR,IPAR)
C             TO DEFINE THE JACOBIAN MATRIX OF PARTIAL DERIVATIVES DF/DU
C             OF THE SYSTEM OF DIFFERENTIAL EQUATIONS   DU/DX = F(X,U).
C             FOR THE GIVEN VALUES OF X AND THE VECTOR
C             U(*)=(U(1),U(2),...,U(NEQ)), THE SUBROUTINE MUST EVALUATE
C             THE NON-ZERO PARTIAL DERIVATIVES  DF(I)/DU(J)  FOR EACH
C             DIFFERENTIAL EQUATION I=1,...,NEQ AND EACH SOLUTION
C             COMPONENT J=1,...,NEQ , AND STORE THESE VALUES IN THE
C             MATRIX PD. THE ELEMENTS OF PD ARE SET TO ZERO BEFORE EACH
C             CALL TO JAC SO ONLY NON-ZERO ELEMENTS NEED TO BE DEFINED.
C
C             SUBROUTINE JAC MUST NOT ALTER X, U(*), OR NROWPD. YOU MUST
C             DECLARE THE NAME JAC IN AN EXTERNAL STATEMENT IN YOUR
C             PROGRAM THAT CALLS STFODE. NROWPD IS THE ROW DIMENSION OF
C             THE PD MATRIX AND IS ASSIGNED BY THE CODE. THEREFORE YOU
C             MUST DIMENSION PD IN JAC ACCORDING TO
C                              DIMENSION PD(NROWPD,1)
C             YOU MUST ALSO DIMENSION U IN JAC.
C
C             THE WAY YOU MUST STORE THE ELEMENTS INTO THE PD MATRIX
C             DEPENDS ON THE STRUCTURE OF THE JACOBIAN WHICH YOU
C             INDICATED BY INFO(6).
C             *** INFO(6)=0 -- FULL (DENSE) JACOBIAN ***
C                 WHEN YOU EVALUATE THE (NON-ZERO) PARTIAL DERIVATIVE
C                 OF EQUATION I WITH RESPECT TO VARIABLE J, YOU MUST
C                 STORE IT IN PD ACCORDING TO
C                                PD(I,J) = * DF(I)/DU(J) *
C             *** INFO(6)=1 -- BANDED JACOBIAN WITH ML LOWER AND MU
C                 UPPER DIAGONAL BANDS (REFER TO INFO(6) DESCRIPTION OF
C                 ML AND MU) ***
C                 WHEN YOU EVALUATE THE (NON-ZERO) PARTIAL DERIVATIVE
C                 OF EQUATION I WITH RESPECT TO VARIABLE J, YOU MUST
C                 STORE IT IN PD ACCORDING TO
C                                IROW = I - J + ML + MU + 1
C                                PD(IROW,J) = * DF(I)/DU(J) *
C
C             RPAR AND IPAR ARE REAL AND INTEGER PARAMETER ARRAYS WHICH
C             YOU CAN USE FOR COMMUNICATION BETWEEN YOUR CALLING
C             PROGRAM AND YOUR JACOBIAN SUBROUTINE JAC. THEY ARE NOT
C             ALTERED BY STFODE. IF YOU DO NOT NEED RPAR OR IPAR, IGNORE
C             THESE PARAMETERS BY TREATING THEM AS DUMMY ARGUMENTS. IF
C             YOU DO CHOOSE TO USE THEM, DIMENSION THEM IN YOUR CALLING
C             PROGRAM AND IN JAC AS ARRAYS OF APPROPRIATE LENGTH.
C
C***********************************************************************
C** OUTPUT -- AFTER ANY RETURN FROM STFODE **
C********************************************
C
C   THE PRINCIPAL AIM OF THE CODE IS TO RETURN A COMPUTED SOLUTION AT
C   TOUT, ALTHOUGH IT IS ALSO POSSIBLE TO OBTAIN INTERMEDIATE RESULTS
C   ALONG THE WAY. TO FIND OUT WHETHER THE CODE ACHIEVED ITS GOAL
C   OR IF THE INTEGRATION PROCESS WAS INTERRUPTED BEFORE THE TASK WAS
C   COMPLETED, YOU MUST CHECK THE IDID PARAMETER.
C
C
C      T -- THE SOLUTION WAS SUCCESSFULLY ADVANCED TO THE
C             OUTPUT VALUE OF T.
C
C      Y(*) -- CONTAINS THE COMPUTED SOLUTION APPROXIMATION AT T.
C             YOU MAY ALSO BE INTERESTED IN THE APPROXIMATE DERIVATIVE
C             OF THE SOLUTION AT T. IT IS CONTAINED IN
C             RWORK(21),...,RWORK(20+NEQ).
C
C      IDID -- REPORTS WHAT THE CODE DID
C
C                         *** TASK COMPLETED ***
C                   REPORTED BY POSITIVE VALUES OF IDID
C
C             IDID = 1 -- A STEP WAS SUCCESSFULLY TAKEN IN THE
C                       INTERMEDIATE-OUTPUT MODE. THE CODE HAS NOT
C                       YET REACHED TOUT.
C
C             IDID = 2 -- THE INTEGRATION TO TOUT WAS SUCCESSFULLY
C                       COMPLETED (T=TOUT) BY STEPPING EXACTLY TO TOUT.
C
C             IDID = 3 -- THE INTEGRATION TO TOUT WAS SUCCESSFULLY
C                       COMPLETED (T=TOUT) BY STEPPING PAST TOUT.
C                       Y(*) IS OBTAINED BY INTERPOLATION.
C
C                         *** TASK INTERRUPTED ***
C                   REPORTED BY NEGATIVE VALUES OF IDID
C
C             IDID = -1 -- A LARGE AMOUNT OF WORK HAS BEEN EXPENDED.
C                       (500 STEPS PERFORMED)
C
C             IDID = -2 -- THE ERROR TOLERANCES ARE TOO STRINGENT.
C
C             IDID = -3 -- THE LOCAL ERROR TEST CANNOT BE SATISFIED
C                       SINCE THE L-TH SOLUTION COMPONENT IS 0 AND
C                       THE CORRESPONDING ABSOLUTE ERROR TOLERANCE
C                       IS 0 FOR L = -INFO(1). A PURE RELATIVE ERROR
C                       TEST CANNOT BE APPLIED TO THIS COMPONENT.
C
C             IDID = -4,-5  -- NOT APPLICABLE FOR THIS CODE.
C
C             IDID = -6 -- STFODE HAD REPEATED CONVERGENCE TEST FAILURES
C                       ON THE LAST ATTEMPTED STEP.
C
C             IDID = -7 -- STFODE HAD REPEATED ERROR TEST FAILURES ON
C                       THE LAST ATTEMPTED STEP.
C
C             IDID = -8,..,-32  -- NOT APPLICABLE FOR THIS CODE.
C
C                         *** TASK TERMINATED ***
C                 REPORTED BY THE VALUE OF IDID .LE. -33
C
C             IDID = -33  -- NEQ .LT. 1
C
C             IDID = -34  -- RTOL(K) .LT. 0 FOR SOME K
C
C             IDID = -35  -- ATOL(K) .LT. 0 FOR SOME K
C
C             IDID = -36  -- THE CODE HAS BEEN CALLED WITH TOUT BUT
C                       THE CODE HAS ALSO BEEN TOLD NOT TO INTEGRATE
C                       PAST THE POINT TSTOP.
C
C             IDID = -37  -- THE CODE HAS BEEN CALLED WITH T = TOUT.
C                       THIS IS NOT PERMITTED ON CONTINUATION CALLS.
C
C             IDID = -38  -- THE USER HAS MODIFIED THE VALUE OF T.
C                       THIS IS NOT PERMITTED ON CONTINUATION CALLS.
C
C             IDID = -39  -- BY CALLING THE CODE WITH TOUT, AN
C                       ATTEMPT IS BEING MADE TO CHANGE THE DIRECTION
C                       OF INTEGRATION WITHOUT RESTARTING.
C
C             IDID = -40  -- THE JACOBIAN MATRIX IS BANDED. HOWEVER
C                       THE BANDWIDTHS ML AND MU DO NOT SATISFY THE
C                       CONSTRAINTS  0 .LE. ML,MU .LT. NEQ.
C
C             IDID = -41  -- LRW .LT. 250 + 10*NEQ + NEQ*NEQ
C
C             IDID = -42  -- LRW .LT. 250 + 10*NEQ + (2*ML+MU+1)*NEQ
C
C             IDID = -43  -- LIW .LT. 55 + NEQ
C
C             IDID = -44  -- INFO(1) IS INCORRECT.
C
C      RTOL, ATOL -- THESE QUANTITIES REMAIN UNCHANGED EXCEPT WHEN
C             IDID = -2. IN THIS CASE, THE ERROR TOLERANCES HAVE BEEN
C             INCREASED BY THE CODE TO VALUES WHICH ARE ESTIMATED TO BE
C             APPROPRIATE FOR CONTINUING THE INTEGRATION. HOWEVER, THE
C             REPORTED SOLUTION AT T WAS OBTAINED USING THE INPUT VALUES
C             OF RTOL AND ATOL.
C
C      RWORK, IWORK -- CONTAIN INFORMATION WHICH IS USUALLY OF NO
C             INTEREST TO THE USER BUT NECESSARY FOR SUBSEQUENT CALLS.
C             HOWEVER, YOU MAY FIND USE FOR
C
C             RWORK(11)--WHICH CONTAINS THE STEP SIZE H TO BE
C                        ATTEMPTED ON THE NEXT STEP.
C
C             RWORK(12)--IF THE TOLERANCES HAVE BEEN INCREASED BY THE
C                        CODE (IDID = -2) , THEY WERE MULTIPLIED BY THE
C                        VALUE IN RWORK(12).
C
C             RWORK(13)--WHICH CONTAINS THE CURRENT VALUE OF THE
C                        INDEPENDENT VARIABLE, I.E. THE FARTHEST POINT
C                        INTEGRATION HAS REACHED. THIS WILL BE DIFFERENT
C                        FROM T ONLY WHEN INTERPOLATION HAS BEEN
C                        PERFORMED (IDID=3).
C
C             RWORK(20+I)--WHICH CONTAINS THE APPROXIMATE DERIVATIVE
C                        OF THE SOLUTION COMPONENT Y(I). IN STFODE IT IS
C                        NEVER OBTAINED BY CALLING SUBROUTINE F TO
C                        EVALUATE THE DIFFERENTIAL EQUATION USING T AND
C                        Y(*), EXCEPT AT THE INITIAL POINT OF
C                        INTEGRATION.
C
C***********************************************************************
C** INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION **
C**             (CALLS AFTER THE FIRST)             **
C*****************************************************
C
C        THIS CODE IS ORGANIZED SO THAT SUBSEQUENT CALLS TO CONTINUE THE
C        INTEGRATION INVOLVE LITTLE (IF ANY) ADDITIONAL EFFORT ON YOUR
C        PART. YOU MUST MONITOR THE IDID PARAMETER IN ORDER TO DETERMINE
C        WHAT TO DO NEXT.
C
C        RECALLING THAT THE PRINCIPAL TASK OF THE CODE IS TO INTEGRATE
C        FROM T TO TOUT (THE INTERVAL MODE), USUALLY ALL YOU WILL NEED
C        TO DO IS SPECIFY A NEW TOUT UPON REACHING THE CURRENT TOUT.
C
C        DO NOT ALTER ANY QUANTITY NOT SPECIFICALLY PERMITTED BELOW,
C        IN PARTICULAR DO NOT ALTER NEQ, T, Y(*), RWORK(*), IWORK(*) OR
C        THE DIFFERENTIAL EQUATION IN SUBROUTINE F. ANY SUCH ALTERATION
C        CONSTITUTES A NEW PROBLEM AND MUST BE TREATED AS SUCH, I.E.
C        YOU MUST START AFRESH.
C
C        YOU CANNOT CHANGE FROM VECTOR TO SCALAR ERROR CONTROL OR VICE
C        VERSA (INFO(2)) BUT YOU CAN CHANGE THE SIZE OF THE ENTRIES OF
C        RTOL, ATOL. INCREASING A TOLERANCE MAKES THE EQUATION EASIER
C        TO INTEGRATE. DECREASING A TOLERANCE WILL MAKE THE EQUATION
C        HARDER TO INTEGRATE AND SHOULD GENERALLY BE AVOIDED.
C
C        YOU CAN SWITCH FROM THE INTERMEDIATE-OUTPUT MODE TO THE
C        INTERVAL MODE (INFO(3)) OR VICE VERSA AT ANY TIME.
C
C        IF IT HAS BEEN NECESSARY TO PREVENT THE INTEGRATION FROM GOING
C        PAST A POINT TSTOP (INFO(4), RWORK(1)), KEEP IN MIND THAT THE
C        CODE WILL NOT INTEGRATE TO ANY TOUT BEYOND THE CURRENTLY
C        SPECIFIED TSTOP. ONCE TSTOP HAS BEEN REACHED YOU MUST CHANGE
C        THE VALUE OF TSTOP OR SET INFO(4)=0. YOU MAY CHANGE INFO(4)
C        OR TSTOP AT ANY TIME BUT YOU MUST SUPPLY THE VALUE OF TSTOP IN
C        RWORK(1) WHENEVER YOU SET INFO(4)=1.
C
C        DO NOT CHANGE INFO(5), INFO(6), IWORK(1), OR IWORK(2)
C        UNLESS YOU ARE GOING TO RESTART THE CODE.
C
C        THE PARAMETER INFO(1) IS USED BY THE CODE TO INDICATE THE
C        BEGINNING OF A NEW PROBLEM AND TO INDICATE WHETHER INTEGRATION
C        IS TO BE CONTINUED. YOU MUST INPUT THE VALUE  INFO(1) = 0
C        WHEN STARTING A NEW PROBLEM. YOU MUST INPUT THE VALUE
C        INFO(1) = 1  IF YOU WISH TO CONTINUE AFTER AN INTERRUPTED TASK
C        FOR WHICH IDID = -3, -6, OR -7. DO NOT SET INFO(1) = 0 ON A
C        CONTINUATION CALL UNLESS YOU WANT THE CODE TO RESTART AT THE
C        CURRENT T.
C
C                         *** FOLLOWING A COMPLETED TASK ***
C         IF
C             IDID = 1, CALL THE CODE AGAIN TO CONTINUE THE INTEGRATION
C                     ANOTHER STEP IN THE DIRECTION OF TOUT.
C
C             IDID = 2 OR 3, DEFINE A NEW TOUT AND CALL THE CODE AGAIN.
C                     TOUT MUST BE DIFFERENT FROM T. YOU CANNOT CHANGE
C                     THE DIRECTION OF INTEGRATION WITHOUT RESTARTING.
C
C                         *** FOLLOWING AN INTERRUPTED TASK ***
C         IF
C             IDID = -1, THE CODE HAS PERFORMED 500 STEPS.
C                     IF YOU WANT TO CONTINUE, CALL THE CODE AGAIN.
C
C             IDID = -2, THE ERROR TOLERANCES RTOL AND ATOL HAVE BEEN
C                     INCREASED TO VALUES THE CODE ESTIMATES APPROPRIATE
C                     FOR CONTINUING. YOU MAY WANT TO CHANGE THEM
C                     YOURSELF. IF YOU WANT TO CONTINUE, CALL THE CODE
C                     AGAIN.
C
C             IDID = -3, THE L-TH SOLUTION COMPONENT IS 0 AND THE
C                     CORRESPONDING ABSOLUTE ERROR TOLERANCE IS 0
C                     FOR L = -INFO(1). TO CONTINUE, RESET THE
C                     ABSOLUTE TOLERANCE TO A POSITIVE VALUE, SET
C                     INFO(1) = 1, AND CALL THE CODE AGAIN.
C
C             IDID = -4,-5  --- CANNOT OCCUR WITH THIS CODE.
C
C             IDID = -6, REPEATED CONVERGENCE TEST FAILURES OCCURRED
C                     ON THE LAST ATTEMPTED STEP. AN INACCURATE
C                     JACOBIAN MAY BE THE PROBLEM. IF YOU ARE ABSOLUTELY
C                     CERTAIN YOU WANT TO CONTINUE, RESTART THE
C                     INTEGRATION AT THE CURRENT T BY SETTING  INFO(1)=0
C                     AND CALL THE CODE AGAIN.
C
C             IDID = -7, REPEATED ERROR TEST FAILURES OCCURRED ON THE
C                     LAST ATTEMPTED STEP. A SINGULARITY IN THE
C                     SOLUTION MAY BE PRESENT. YOU SHOULD RE-EXAMINE THE
C                     PROBLEM BEING SOLVED. IF YOU ARE ABSOLUTELY
C                     CERTAIN YOU WANT TO CONTINUE, RESTART THE
C                     INTEGRATION AT THE CURRENT T BY SETTING  INFO(1)=0
C                     AND CALL THE CODE AGAIN.
C
C             IDID = -8,..,-32  --- CANNOT OCCUR WITH THIS CODE.
C
C                         *** FOLLOWING A TERMINATED TASK ***
C         IF
C             IDID .LE. -33, AN INPUT ERROR HAS BEEN DETECTED. AFTER THE
C                     ERROR IS CORRECTED, RESTART BY SETTING INFO(1) = 0
C                     AND CALL THE CODE AGAIN.
C
C***********************************************************************
C
C         ***** WARNING *****
C
C     IF STFODE IS TO BE USED IN AN OVERLAY SITUATION, YOU MUST SAVE AND
C     RESTORE CERTAIN ITEMS USED INTERNALLY BY STFODE  (VALUES IN THE
C     COMMON BLOCK DEBDF1). THIS CAN BE ACCOMPLISHED AS FOLLOWS.
C
C     TO SAVE THE NECESSARY VALUES UPON RETURN FROM STFODE, SIMPLY CALL
C        SVCO(RWORK(22+NEQ),IWORK(21+NEQ)).
C
C     TO RESTORE THE NECESSARY VALUES BEFORE THE NEXT CALL TO STFODE,
C     SIMPLY CALL    RSCO(RWORK(22+NEQ),IWORK(21+NEQ)).
C
C***********************************************************************
C
C***REFERENCES
C   SHAMPINE L.F., WATTS H.A., *DEPAC - DESIGN OF A USER ORIENTED
C   PACKAGE OF ODE SOLVERS*, SAND79-2374, SANDIA LABORATORIES, 1979.
C
C
      LOGICAL INTOUT
C
      DIMENSION Y(NEQ),INFO( *),RTOL(*),ATOL(*),RWORK(LRW),IWORK(LIW),
     1          RPAR(*),IPAR(*)
C
      COMMON /DEBDF1/ TOLD, ROWNS(210),
     1   EL0, H, HMIN, HMXI, HU, TN, UROUND,
     2   IQUIT, INIT, IYH, IEWT, IACOR, ISAVF, IWM, KSTEPS,
     3   IBEGIN, ITOL, IINTEG, ITSTOP, IJAC, IBAND, IOWNS(6),
     4   IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE,
     5   NJE, NQU
C
      EXTERNAL F , JAC
C
C.......................................................................
C
      IDID = 0
C
      IF (INFO(1) .EQ. 0) GO TO 20
      IF (INFO(1) .NE. 1) GO TO 10
      IF (IQUIT .EQ. 0) GO TO 20
   10 IDID = -44
      RETURN
C
   20 IF (INFO(2) .NE. 0) INFO(2) = 1
      IF (INFO(3) .NE. 0) INFO(3) = 1
      IF (INFO(4) .NE. 0) INFO(4) = 1
      IF (INFO(5) .NE. 0) INFO(5) = 1
      IF (INFO(6) .NE. 0) INFO(6) = 1
C
      ILRW = NEQ
      IF (INFO(6) .EQ. 0) GO TO 80
C
C     CHECK BANDWIDTH PARAMETERS
C
      ML = IWORK(1)
      MU = IWORK(2)
      ILRW = 2*ML + MU + 1
      IF (ML .GE. 0  .AND.  ML .LT. NEQ      .AND.
     1    MU .GE. 0  .AND.  MU .LT. NEQ)    GO TO 80
      IDID = -40
      RETURN
C
C     CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION
C
   80 IF (LRW .GE. 250+(10+ILRW)*NEQ) GO TO 100
C
      IF (INFO(6) .EQ. 1) GO TO 90
      IDID = -41
      RETURN
C
   90 IDID = -42
      RETURN
C
  100 IF (LIW .GE. 55+NEQ) GO TO 200
      IDID = -43
      RETURN
C
C     COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY
C     AND RESTORE COMMON BLOCK DATA
C
  200 ICOMI = 21 + NEQ
      IINOUT = ICOMI + 33
C
      IYPOUT = 21
      ITSTAR = 21 + NEQ
      ICOMR = 22 + NEQ
C
      IF (INFO(1) .EQ. 0) GO TO 250
      INTOUT = IWORK(IINOUT) .NE. (-1)
C     CALL RSCO(RWORK(ICOMR),IWORK(ICOMI))
C
  250 IYH = ICOMR + 218
      IEWT = IYH + 6*NEQ
      ISAVF = IEWT + NEQ
      IACOR = ISAVF + NEQ
      IWM = IACOR + NEQ
      IDELSN = IWM + 2+ILRW*NEQ
C
      IBEGIN = INFO(1)
      ITOL = INFO(2)
      IINTEG = INFO(3)
      ITSTOP = INFO(4)
      IJAC = INFO(5)
      IBAND = INFO(6)
      RWORK(ITSTAR) = T
C
      CALL LSOD1(F,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,RWORK(IYPOUT),
     1          RWORK(IYH),RWORK(IYH),RWORK(IEWT),RWORK(ISAVF),
     2          RWORK(IACOR),RWORK(IWM),IWORK(1),JAC,INTOUT,
     3          RWORK(1),RWORK(12),RWORK(IDELSN),RPAR,IPAR)
C
      IWORK(IINOUT) = -1
      IF (INTOUT) IWORK(IINOUT) = 1
C
C     CALL SVCO(RWORK(ICOMR),IWORK(ICOMI))
      RWORK(11) = H
      RWORK(13) = TN
      INFO(1) = IBEGIN
C
      RETURN
      END
      SUBROUTINE RSCO (RSAV, ISAV)
C-----------------------------------------------------------------------
C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON
C BLOCK DEBDF1, WHICH IS USED INTERNALLY IN THE SFODE PACKAGE.
C-----------------------------------------------------------------------
      INTEGER ISAV, I, ILS, LENILS, LENRLS
      REAL RSAV, RLS
      DIMENSION RSAV(*), ISAV(*)
      COMMON /DEBDF1/ RLS(218), ILS(33)
      DATA LENRLS/218/, LENILS/33/
C
      DO 10 I = 1,LENRLS
 10     RLS(I) = RSAV(I)
      DO 20 I = 1,LENILS
 20     ILS(I) = ISAV(I)
      RETURN
C----------------------- END OF SUBROUTINE RSCO -----------------------
      END
      SUBROUTINE SVCO (RSAV, ISAV)
C-----------------------------------------------------------------------
C THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCK
C DEBDF1, WHICH IS USED INTERNALLY IN THE SFODE PACKAGE.
C
C RSAV = REAL ARRAY OF LENGTH 218 OR MORE.
C ISAV = INTEGER ARRAY OF LENGTH 33 OR MORE.
C-----------------------------------------------------------------------
      INTEGER ISAV, I, ILS, LENILS, LENRLS
      REAL RSAV, RLS
      DIMENSION RSAV(*), ISAV(*)
      COMMON /DEBDF1/ RLS(218), ILS(33)
      DATA LENRLS/218/, LENILS/33/
C
      DO 10 I = 1,LENRLS
 10     RSAV(I) = RLS(I)
      DO 20 I = 1,LENILS
 20     ISAV(I) = ILS(I)
      RETURN
C----------------------- END OF SUBROUTINE SVCO -----------------------
      END
      SUBROUTINE LSOD1 (F,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,YPOUT,
     1                YH,YH1,EWT,SAVF,ACOR,WM,IWM,JAC,INTOUT,
     2                TSTOP,TOLFAC,DELSGN,RPAR,IPAR)
C
C   STFODE  MERELY ALLOCATES STORAGE FOR LSOD1 TO RELIEVE THE USER OF
C   THE INCONVENIENCE OF A LONG CALL LIST.  CONSEQUENTLY LSOD1 IS USED
C   AS DESCRIBED IN THE COMMENTS FOR  STFODE.
C
C***ROUTINES CALLED  STOD,INTYD,VNWRMS,HSTART,SPMPAR
C
      LOGICAL INTOUT
C
      DIMENSION Y(NEQ),YPOUT(NEQ),YH(NEQ,*),YH1(*),EWT(NEQ),SAVF(NEQ),
     1          ACOR(NEQ),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*)
C
      COMMON /DEBDF1/ TOLD, ROWNS(210),
     1   EL0, H, HMIN, HMXI, HU, X, U,
     2   IQUIT, INIT, LYH, LEWT, LACOR, LSAVF, LWM, KSTEPS,
     3   IBEGIN, ITOL, IINTEG, ITSTOP, IJAC, IBAND, IOWNS(6),
     4   IER, JSTART, KFLAG, LDUM, METH, MITER, MAXORD, N, NQ, NST,
     5   NFE, NJE, NQU
C
      EXTERNAL F , JAC
C
C.......................................................................
C
C  THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE
C  NUMBER OF  STEPS ATTEMPTED. WHEN THIS EXCEEDS  MAXNUM, THE COUNTER
C  IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE
C  WORK.
C
      DATA MAXNUM/500/
C
C.......................................................................
C
      IF (IBEGIN .NE. 0) GO TO 10
C
C ON THE FIRST CALL , PERFORM INITIALIZATION --
C        DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY  U  BY CALLING THE
C        FUNCTION ROUTINE  SPMPAR. THE USER MUST MAKE SURE THAT THE
C        VALUES SET IN SPMPAR ARE RELEVANT TO THE COMPUTER BEING USED.
C
      U=SPMPAR(1)
C                       -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER
      WM(1)=SQRT(U)
C                       -- SET TERMINATION FLAG
      IQUIT=0
C                       -- SET INITIALIZATION INDICATOR
      INIT=0
C                       -- SET COUNTER FOR ATTEMPTED STEPS
      KSTEPS=0
C                       -- SET INDICATOR FOR INTERMEDIATE-OUTPUT
      INTOUT= .FALSE.
C                       -- SET START INDICATOR FOR STOD CODE
      JSTART= 0
C                       -- SET BDF METHOD INDICATOR
      METH = 2
C                       -- SET MAXIMUM ORDER FOR BDF METHOD
      MAXORD = 5
C                       -- SET ITERATION MATRIX INDICATOR
C
      IF (IJAC .EQ. 0  .AND.  IBAND .EQ. 0) MITER = 2
      IF (IJAC .EQ. 1  .AND.  IBAND .EQ. 0) MITER = 1
      IF (IJAC .EQ. 0  .AND.  IBAND .EQ. 1) MITER = 5
      IF (IJAC .EQ. 1  .AND.  IBAND .EQ. 1) MITER = 4
C
C                       -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK
      N = NEQ
      NST = 0
      NJE = 0
      HMXI = 0.
      NQ = 1
      H = 1.
C                       -- RESET IBEGIN FOR SUBSEQUENT CALLS
      IBEGIN = 1
C
C.......................................................................
C
C      CHECK VALIDITY OF INPUT PARAMATERS ON EACH ENTRY
C
   10 IF (NEQ .GE. 1) GO TO 20
      IDID = -33
      GO TO 110
C
   20 MAX = 1
      IF (ITOL .NE. 0) MAX = NEQ
      DO 60 K = 1,MAX
        IF (RTOL(K) .GE. 0.) GO TO 30
           IDID = -34
           GO TO 110
   30   IF (ATOL(K) .GE. 0.) GO TO 60
           IDID = -35
           GO TO 110
   60   CONTINUE
C
      IF (ITSTOP .NE. 1) GO TO 80
      IF ((TOUT - T)*(TSTOP - T) .GE. 0.0
     1  .AND. ABS(TOUT-T) .LE. ABS(TSTOP-T)) GO TO 80
      IDID = -36
      GO TO 110
C
   80 IF (INIT .EQ. 0) GO TO 150
C                       CHECK SOME CONTINUATION POSSIBILITIES
      IF (T .NE. TOUT) GO TO 90
      IDID = -37
      GO TO 110
C
   90 IF (T .EQ. TOLD) GO TO 100
      IDID = -38
      GO TO 110
C
  100 IF (INIT .EQ. 1) GO TO 150
      IF (DELSGN*(TOUT-T) .GE. 0.) GO TO 150
      IDID = -39
C
C                       INVALID INPUT DETECTED
  110 IQUIT = -33
      IBEGIN = -1
      RETURN
C
C.......................................................................
C
C     RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS
C     ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE,
C     THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE
C     100*U WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE
C
  150 DO 170 K = 1,MAX
        IF (RTOL(K) + ATOL(K) .GT. 0.) GO TO 170
        RTOL(K) = 100.*U
        IDID = -2
  170   CONTINUE
      IF (IDID .EQ. -2) RETURN
C
C     BRANCH ON STATUS OF INITIALIZATION INDICATOR
C            INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE
C                   AND DIRECTION NOT YET SET
C            INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET
C            INIT=2 MEANS NO FUTHER INITIALIZATION REQUIRED
C
      IF (INIT .EQ. 0) GO TO 200
      IF (INIT .EQ. 1) GO TO 220
      GO TO 240
C
C.......................................................................
C
C     MORE INITIALIZATION --
C                         -- EVALUATE INITIAL DERIVATIVES
C
  200 INIT = 1
      CALL F(T,Y,YH(1,2),RPAR,IPAR)
      NFE = 1
      IF (T .NE. TOUT) GO TO 220
      IDID = 2
      DO 210 L = 1,NEQ
  210    YPOUT(L) = YH(L,2)
      TOLD = T
      RETURN
C
C                         -- COMPUTE INITIAL STEP SIZE
C                         -- SAVE SIGN OF INTEGRATION DIRECTION
C                         -- SET INDEPENDENT AND DEPENDENT VARIABLES
C                                              X AND YH(*) FOR STOD
C
  220 LTOL = 1
      DO 225 L = 1,NEQ
        IF (ITOL .EQ. 1) LTOL = L
        TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL)
        IF (TOL .EQ. 0.) GO TO 380
  225   EWT(L) = TOL
C
      BIG = SQRT(SPMPAR(3))
      CALL HSTART (F,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG,
     1             YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR,IPAR,H)
C
      DELSGN = SIGN(1.0,TOUT-T)
      X = T
      DO 230 L = 1,NEQ
        YH(L,1) = Y(L)
  230   YH(L,2) = H*YH(L,2)
      INIT = 2
C
C.......................................................................
C
C   ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL
C   OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT
C
  240 DEL = TOUT - T
      ABSDEL = ABS(DEL)
C
C.......................................................................
C
C   IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN
C
  250 IF (ABS(X-T) .LT. ABSDEL) GO TO 270
      CALL INTYD(TOUT,0,YH,NEQ,Y,INTFLG)
      CALL INTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG)
      IDID = 3
      IF (X .NE. TOUT) GO TO 260
      IDID = 2
      INTOUT = .FALSE.
  260 T = TOUT
      TOLD = T
      RETURN
C
C   IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE,
C   EXTRAPOLATE AND RETURN
C
  270 IF (ITSTOP .NE. 1) GO TO 290
      IF (ABS(TSTOP-X) .GE. 100.*U*ABS(X)) GO TO 290
      DT = TOUT - X
      DO 280 L = 1,NEQ
  280   Y(L) = YH(L,1) + (DT/H)*YH(L,2)
      CALL F(TOUT,Y,YPOUT,RPAR,IPAR)
      NFE = NFE + 1
      IDID = 3
      T = TOUT
      TOLD = T
      RETURN
C
  290 IF (IINTEG .EQ. 0  .OR.  .NOT.INTOUT) GO TO 300
C
C   INTERMEDIATE-OUTPUT MODE
C
      IDID = 1
      GO TO 500
C
C.......................................................................
C
C     MONITOR NUMBER OF STEPS ATTEMPTED
C
  300 IF (KSTEPS .LE. MAXNUM) GO TO 330
C
C                       A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED
      IDID = -1
      KSTEPS = 0
      GO TO 500
C
C.......................................................................
C
C   LIMIT STEP SIZE AND SET WEIGHT VECTOR
C
  330 HMIN = 100.*U*ABS(X)
      HA = AMAX1(ABS(H),HMIN)
      IF (ITSTOP .NE. 1) GO TO 340
      HA = AMIN1(HA,ABS(TSTOP-X))
  340 H = SIGN(HA,H)
      LTOL = 1
      DO 350 L = 1,NEQ
        IF (ITOL .EQ. 1) LTOL = L
        EWT(L) = RTOL(LTOL)*ABS(YH(L,1)) + ATOL(LTOL)
        IF (EWT(L) .LE. 0.0) GO TO 380
  350   CONTINUE
      TOLFAC = U*VNWRMS(NEQ,YH,EWT)
      IF (TOLFAC .LE. 1.) GO TO 400
C
C                       TOLERANCES TOO SMALL
      IDID = -2
      TOLFAC = 2.*TOLFAC
      DO 360 L = 1,MAX
        RTOL(L) = TOLFAC*RTOL(L)
  360   ATOL(L) = TOLFAC*ATOL(L)
      GO TO 500
C
C                       RELATIVE ERROR CRITERION INAPPROPRIATE
  380 IDID = -3
      IBEGIN = -L
      GO TO 500
C
C.......................................................................
C
C     TAKE A STEP
C
  400 CALL STOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM,F,JAC,RPAR,IPAR)
C
      JSTART = -2
      INTOUT = .TRUE.
      IF (KFLAG .EQ. 0) GO TO 250
C
C.......................................................................
C
      IF (KFLAG .EQ. -1) GO TO 450
C
C                       REPEATED CORRECTOR CONVERGENCE FAILURES
      IDID = -6
      IQUIT = -6
      IBEGIN = -1
      GO TO 500
C
C                       REPEATED ERROR TEST FAILURES
  450 IDID = -7
      IQUIT = -7
      IBEGIN = -1
C
C.......................................................................
C
C                       STORE VALUES BEFORE RETURNING TO STFODE
  500 DO 555 L = 1,NEQ
        Y(L) = YH(L,1)
  555   YPOUT(L) = YH(L,2)/H
      T = X
      TOLD = T
      INTOUT = .FALSE.
      RETURN
      END
      SUBROUTINE HSTART(F,NEQ,A,B,Y,YPRIME,ETOL,MORDER,SMALL,BIG,
     1                                    SPY,PV,YP,SF,RPAR,IPAR,H)
C
C   HSTART COMPUTES A STARTING STEP SIZE TO BE USED IN SOLVING INITIAL
C   VALUE PROBLEMS IN ORDINARY DIFFERENTIAL EQUATIONS.
C
C
C***********************************************************************
C  ABSTRACT
C
C     SUBROUTINE HSTART COMPUTES A STARTING STEP SIZE TO BE USED BY AN
C     INITIAL VALUE METHOD IN SOLVING ORDINARY DIFFERENTIAL EQUATIONS.
C     IT IS BASED ON AN ESTIMATE OF THE LOCAL LIPSCHITZ CONSTANT FOR THE
C     DIFFERENTIAL EQUATION   (LOWER BOUND ON A NORM OF THE JACOBIAN) ,
C     A BOUND ON THE DIFFERENTIAL EQUATION  (FIRST DERIVATIVE) , AND
C     A BOUND ON THE PARTIAL DERIVATIVE OF THE EQUATION WITH RESPECT TO
C     THE INDEPENDENT VARIABLE.
C     (ALL APPROXIMATED NEAR THE INITIAL POINT A)
C
C     SUBROUTINE HSTART USES A FUNCTION SUBPROGRAM VNORM FOR COMPUTING
C     A VECTOR NORM. THE MAXIMUM NORM IS PRESENTLY UTILIZED THOUGH IT
C     CAN EASILY BE REPLACED BY ANY OTHER VECTOR NORM. IT IS PRESUMED
C     THAT ANY REPLACEMENT NORM ROUTINE WOULD BE CAREFULLY CODED TO
C     PREVENT UNNECESSARY UNDERFLOWS OR OVERFLOWS FROM OCCURRING, AND
C     ALSO, WOULD NOT ALTER THE VECTOR OR NUMBER OF COMPONENTS.
C
C***********************************************************************
C  ON INPUT YOU MUST PROVIDE THE FOLLOWING
C
C      F -- THIS IS A SUBROUTINE OF THE FORM
C                               F(X,U,UPRIME,RPAR,IPAR)
C             WHICH DEFINES THE SYSTEM OF FIRST ORDER DIFFERENTIAL
C             EQUATIONS TO BE SOLVED. FOR THE GIVEN VALUES OF X AND THE
C             VECTOR  U(*)=(U(1),U(2),...,U(NEQ)) , THE SUBROUTINE MUST
C             EVALUATE THE NEQ COMPONENTS OF THE SYSTEM OF DIFFERENTIAL
C             EQUATIONS  DU/DX=F(X,U)  AND STORE THE DERIVATIVES IN THE
C             ARRAY UPRIME(*), THAT IS,  UPRIME(I) = * DU(I)/DX *  FOR
C             EQUATIONS I=1,...,NEQ.
C
C             SUBROUTINE F MUST NOT ALTER X OR U(*). YOU MUST DECLARE
C             THE NAME F IN AN EXTERNAL STATEMENT IN YOUR PROGRAM THAT
C             CALLS HSTART. YOU MUST DIMENSION U AND UPRIME IN F.
C
C             RPAR AND IPAR ARE REAL AND INTEGER PARAMETER ARRAYS WHICH
C             YOU CAN USE FOR COMMUNICATION BETWEEN YOUR PROGRAM AND
C             SUBROUTINE F. THEY ARE NOT USED OR ALTERED BY HSTART. IF
C             YOU DO NOT NEED RPAR OR IPAR, IGNORE THESE PARAMETERS BY
C             TREATING THEM AS DUMMY ARGUMENTS. IF YOU DO CHOOSE TO USE
C             THEM, DIMENSION THEM IN YOUR PROGRAM AND IN F AS ARRAYS
C             OF APPROPRIATE LENGTH.
C
C      NEQ -- THIS IS THE NUMBER OF (FIRST ORDER) DIFFERENTIAL EQUATIONS
C             TO BE INTEGRATED.
C
C      A -- THIS IS THE INITIAL POINT OF INTEGRATION.
C
C      B -- THIS IS A VALUE OF THE INDEPENDENT VARIABLE USED TO DEFINE
C             THE DIRECTION OF INTEGRATION. A REASONABLE CHOICE IS TO
C             SET  B  TO THE FIRST POINT AT WHICH A SOLUTION IS DESIRED.
C             YOU CAN ALSO USE  B, IF NECESSARY, TO RESTRICT THE LENGTH
C             OF THE FIRST INTEGRATION STEP BECAUSE THE ALGORITHM WILL
C             NOT COMPUTE A STARTING STEP LENGTH WHICH IS BIGGER THAN
C             ABS(B-A), UNLESS  B  HAS BEEN CHOSEN TOO CLOSE TO  A.
C             (IT IS PRESUMED THAT HSTART HAS BEEN CALLED WITH  B
C             DIFFERENT FROM  A  ON THE MACHINE BEING USED. ALSO SEE THE
C             DISCUSSION ABOUT THE PARAMETER  SMALL.)
C
C      Y(*) -- THIS IS THE VECTOR OF INITIAL VALUES OF THE NEQ SOLUTION
C             COMPONENTS AT THE INITIAL POINT  A.
C
C      YPRIME(*) -- THIS IS THE VECTOR OF DERIVATIVES OF THE NEQ
C             SOLUTION COMPONENTS AT THE INITIAL POINT  A.
C             (DEFINED BY THE DIFFERENTIAL EQUATIONS IN SUBROUTINE F)
C
C      ETOL -- THIS IS THE VECTOR OF ERROR TOLERANCES CORRESPONDING TO
C             THE NEQ SOLUTION COMPONENTS. IT IS ASSUMED THAT ALL
C             ELEMENTS ARE POSITIVE. FOLLOWING THE FIRST INTEGRATION
C             STEP, THE TOLERANCES ARE EXPECTED TO BE USED BY THE
C             INTEGRATOR IN AN ERROR TEST WHICH ROUGHLY REQUIRES THAT
C                        ABS(LOCAL ERROR)  .LE.  ETOL
C             FOR EACH VECTOR COMPONENT.
C
C      MORDER -- THIS IS THE ORDER OF THE FORMULA WHICH WILL BE USED BY
C             THE INITIAL VALUE METHOD FOR TAKING THE FIRST INTEGRATION
C             STEP.
C
C      SMALL -- THIS IS A SMALL POSITIVE MACHINE DEPENDENT CONSTANT
C             WHICH IS USED FOR PROTECTING AGAINST COMPUTATIONS WITH
C             NUMBERS WHICH ARE TOO SMALL RELATIVE TO THE PRECISION OF
C             FLOATING POINT ARITHMETIC.  SMALL  SHOULD BE SET TO
C             (APPROXIMATELY) THE SMALLEST POSITIVE REAL NUMBER SUCH
C             THAT  (1.+SMALL) .GT. 1.  ON THE MACHINE BEING USED. THE
C             QUANTITY  SMALL**(3/8)  IS USED IN COMPUTING INCREMENTS OF
C             VARIABLES FOR APPROXIMATING DERIVATIVES BY DIFFERENCES.
C             ALSO THE ALGORITHM WILL NOT COMPUTE A STARTING STEP LENGTH
C             WHICH IS SMALLER THAN  100*SMALL*ABS(A).
C
C      BIG -- THIS IS A LARGE POSITIVE MACHINE DEPENDENT CONSTANT WHICH
C             IS USED FOR PREVENTING MACHINE OVERFLOWS. A REASONABLE
C             CHOICE IS TO SET BIG TO (APPROXIMATELY) THE SQUARE ROOT OF
C             THE LARGEST REAL NUMBER WHICH CAN BE HELD IN THE MACHINE.
C
C      SPY(*),PV(*),YP(*),SF(*) -- THESE ARE REAL WORK ARRAYS OF LENGTH
C             NEQ WHICH PROVIDE THE ROUTINE WITH NEEDED STORAGE SPACE.
C
C      RPAR,IPAR -- THESE ARE PARAMETER ARRAYS, OF REAL AND INTEGER
C             TYPE, RESPECTIVELY, WHICH CAN BE USED FOR COMMUNICATION
C             BETWEEN YOUR PROGRAM AND THE F SUBROUTINE. THEY ARE NOT
C             USED OR ALTERED BY HSTART.
C
C***********************************************************************
C  ON OUTPUT  (AFTER THE RETURN FROM HSTART),
C
C      H -- IS AN APPROPRIATE STARTING STEP SIZE TO BE ATTEMPTED BY THE
C             DIFFERENTIAL EQUATION METHOD.
C
C           ALL PARAMETERS IN THE CALL LIST REMAIN UNCHANGED EXCEPT FOR
C           THE WORKING ARRAYS SPY(*),PV(*),YP(*), AND SF(*).
C
C***********************************************************************
C
C***ROUTINES CALLED  VNORM
C
      DIMENSION Y(NEQ),YPRIME(NEQ),ETOL(NEQ),
     1          SPY(NEQ),PV(NEQ),YP(NEQ),SF(NEQ),RPAR(*),IPAR(*)
      EXTERNAL F
C
C.......................................................................
C
      DX=B-A
      ABSDX=ABS(DX)
      RELPER=SMALL**0.375
C
C.......................................................................
C
C     COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL
C     DERIVATIVE OF THE EQUATION WITH RESPECT TO THE
C     INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW.
C     ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE LOCALLY.
C
      DA=SIGN(AMAX1(AMIN1(RELPER*ABS(A),ABSDX),100.*SMALL*ABS(A)),DX)
      IF (DA .EQ. 0.) DA=RELPER*DX
      CALL F(A+DA,Y,SF,RPAR,IPAR)
      DO 10 J=1,NEQ
   10   YP(J)=SF(J)-YPRIME(J)
      DELF=VNORM(YP,NEQ)
      DFDXB=BIG
      IF (DELF .LT. BIG*ABS(DA)) DFDXB=DELF/ABS(DA)
      FBND=VNORM(SF,NEQ)
C
C.......................................................................
C
C     COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ CONSTANT FOR
C     THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS ALSO REPRESENTS AN
C     ESTIMATE OF THE NORM OF THE JACOBIAN LOCALLY.
C     THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO ESTIMATE THE
C     LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. THE FIRST
C     PERTURBATION VECTOR IS BASED ON THE INITIAL DERIVATIVES AND
C     DIRECTION OF INTEGRATION. THE SECOND PERTURBATION VECTOR IS
C     FORMED USING ANOTHER EVALUATION OF THE DIFFERENTIAL EQUATION.
C     THE THIRD PERTURBATION VECTOR IS FORMED USING PERTURBATIONS BASED
C     ONLY ON THE INITIAL VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS
C     CHANGED TO NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN
C     INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT COMPONENTS
C     OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE CONSISTENT WITH
C     THE SLOPES OF LOCAL SOLUTION CURVES.
C     ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST DERIVATIVE.
C
C                       PERTURBATION VECTOR SIZE IS HELD CONSTANT FOR
C                       ALL ITERATIONS. COMPUTE THIS CHANGE FROM THE
C                               SIZE OF THE VECTOR OF INITIAL VALUES.
      DELY=RELPER*VNORM(Y,NEQ)
      IF (DELY .EQ. 0.) DELY=RELPER
      DELY=SIGN(DELY,DX)
      DELF=VNORM(YPRIME,NEQ)
      FBND=AMAX1(FBND,DELF)
      IF (DELF .EQ. 0.) GO TO 30
C                       USE INITIAL DERIVATIVES FOR FIRST PERTURBATION
      DO 20 J=1,NEQ
        SPY(J)=YPRIME(J)
   20   YP(J)=YPRIME(J)
      GO TO 50
C                       CANNOT HAVE A NULL PERTURBATION VECTOR
   30 DO 40 J=1,NEQ
        SPY(J)=0.
   40   YP(J)=1.
      DELF=VNORM(YP,NEQ)
C
   50 DFDUB=0.
      LK=MIN0(NEQ+1,3)
      DO 140 K=1,LK
C                       DEFINE PERTURBED VECTOR OF INITIAL VALUES
        DO 60 J=1,NEQ
   60     PV(J)=Y(J)+DELY*(YP(J)/DELF)
        IF (K .EQ. 2) GO TO 80
C                       EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED
C                       VECTOR  AND  COMPUTE CORRESPONDING DIFFERENCES
        CALL F(A,PV,YP,RPAR,IPAR)
        DO 70 J=1,NEQ
   70     PV(J)=YP(J)-YPRIME(J)
        GO TO 100
C                       USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE
C                                             IN COMPUTING ONE ESTIMATE
   80   CALL F(A+DA,PV,YP,RPAR,IPAR)
        DO 90 J=1,NEQ
   90     PV(J)=YP(J)-SF(J)
C                       CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE
C                                      AND A LOCAL LIPSCHITZ CONSTANT
  100   FBND=AMAX1(FBND,VNORM(YP,NEQ))
        DELF=VNORM(PV,NEQ)
        IF (DELF .GE. BIG*ABS(DELY)) GO TO 150
        DFDUB=AMAX1(DFDUB,DELF/ABS(DELY))
        IF (K .EQ. LK) GO TO 160
C                       CHOOSE NEXT PERTURBATION VECTOR
        IF (DELF .EQ. 0.) DELF=1.
        DO 130 J=1,NEQ
          IF (K .EQ. 2) GO TO 110
          DY=ABS(PV(J))
          IF (DY .EQ. 0.) DY=DELF
          GO TO 120
  110     DY=Y(J)
          IF (DY .EQ. 0.) DY=DELY/RELPER
  120     IF (SPY(J) .EQ. 0.) SPY(J)=YP(J)
          IF (SPY(J) .NE. 0.) DY=SIGN(DY,SPY(J))
  130     YP(J)=DY
  140   DELF=VNORM(YP,NEQ)
C
C                       PROTECT AGAINST AN OVERFLOW
  150 DFDUB=BIG
C
C.......................................................................
C
C     COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE
C
  160 YDPB=DFDXB+DFDUB*FBND
C
C.......................................................................
C
C     DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP SIZE
C     IS TO BE BASED.  A VALUE IN THE MIDDLE OF THE ERROR TOLERANCE
C     RANGE IS SELECTED.
C
      TOLMIN=BIG
      TOLSUM=0.
      DO 170 K=1,NEQ
        TOLEXP=ALOG10(ETOL(K))
        TOLMIN=AMIN1(TOLMIN,TOLEXP)
 170    TOLSUM=TOLSUM+TOLEXP
      TOLP=10.**(0.5*(TOLSUM/FLOAT(NEQ)+TOLMIN)/FLOAT(MORDER+1))
C
C.......................................................................
C
C     COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND SECOND
C     DERIVATIVE INFORMATION
C
C                       RESTRICT THE STEP LENGTH TO BE NOT BIGGER THAN
C                       ABS(B-A).   (UNLESS  B  IS TOO CLOSE TO  A)
      H=ABSDX
C
      IF (YDPB .NE. 0.  .OR.  FBND .NE. 0.) GO TO 180
C
C                       BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND
C                                    DERIVATIVE TERM (YDPB) ARE ZERO
      IF (TOLP .LT. 1.) H=ABSDX*TOLP
      GO TO 200
C
  180 IF (YDPB .NE. 0.) GO TO 190
C
C                       ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO
      IF (TOLP .LT. FBND*ABSDX) H=TOLP/FBND
      GO TO 200
C
C                       SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO
  190 SRYDPB=SQRT(0.5*YDPB)
      IF (TOLP .LT. SRYDPB*ABSDX) H=TOLP/SRYDPB
C
C                       FURTHER RESTRICT THE STEP LENGTH TO BE NOT
C                                                 BIGGER THAN  1/DFDUB
  200 IF (H*DFDUB .GT. 1.) H=1./DFDUB
C
C                       FINALLY, RESTRICT THE STEP LENGTH TO BE NOT
C                       SMALLER THAN  100*SMALL*ABS(A).  HOWEVER, IF
C                       A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO,
C                       THE ALGORITHM RETURNS  SMALL*ABS(B)  FOR THE
C                                                       STEP LENGTH.
      H=AMAX1(H,100.*SMALL*ABS(A))
      IF (H .EQ. 0.) H=SMALL*ABS(B)
C
C                       NOW SET DIRECTION OF INTEGRATION
      H=SIGN(H,DX)
C
      RETURN
      END
      SUBROUTINE INTYD (T, K, YH, NYH, DKY, IFLAG)
C
C   INTYD APPROXIMATES THE SOLUTION AND DERIVATIVES AT T BY POLYNOMIAL
C   INTERPOLATION. MUST BE USED IN CONJUNCTION WITH THE INTEGRATOR
C   PACKAGE SFODE.
C-----------------------------------------------------------------------
C INTYD COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE
C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY.
C THIS ROUTINE IS CALLED BY STFODE WITH K = 0,1 AND T = TOUT, BUT MAY
C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER.
C (SEE DETAILED INSTRUCTIONS IN LSODE USAGE DOCUMENTATION.)
C-----------------------------------------------------------------------
C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE
C NORDSIECK HISTORY ARRAY YH.  THIS ARRAY CORRESPONDS UNIQUELY TO A
C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET
C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T.
C THE FORMULA FOR DKY IS..
C              Q
C  DKY(I)  =  SUM  C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1)
C             J=K
C WHERE  C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR.
C THE QUANTITIES  NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE
C COMMUNICATED BY COMMON.  THE ABOVE SUM IS DONE IN REVERSE ORDER.
C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS.
C-----------------------------------------------------------------------
      INTEGER K, NYH, IFLAG, I, IC, IER, IOWND, IOWNS, J, JB, JB2,
     1   JJ, JJ1, JP1, JSTART, KFLAG, L, MAXORD, METH, MITER, N, NFE,
     2   NJE, NQ, NQU, NST
      REAL T, YH, DKY,
     1   ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND,
     2   C, R, S, TP
      DIMENSION YH(NYH,*), DKY(*)
      COMMON /DEBDF1/ ROWND, ROWNS(210),
     1   EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6),
     4   IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE,
     5   NJE, NQU
C
      IFLAG = 0
      IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80
      TP = TN - HU*(1.0E0 + 100.0E0*UROUND)
      IF ((T-TP)*(T-TN) .GT. 0.0E0) GO TO 90
C
      S = (T - TN)/H
      IC = 1
      IF (K .EQ. 0) GO TO 15
      JJ1 = L - K
      DO 10 JJ = JJ1,NQ
 10     IC = IC*JJ
 15   C = FLOAT(IC)
      DO 20 I = 1,N
 20     DKY(I) = C*YH(I,L)
      IF (K .EQ. NQ) GO TO 55
      JB2 = NQ - K
      DO 50 JB = 1,JB2
        J = NQ - JB
        JP1 = J + 1
        IC = 1
        IF (K .EQ. 0) GO TO 35
        JJ1 = JP1 - K
        DO 30 JJ = JJ1,J
 30       IC = IC*JJ
 35     C = FLOAT(IC)
        DO 40 I = 1,N
 40       DKY(I) = C*YH(I,JP1) + S*DKY(I)
 50     CONTINUE
      IF (K .EQ. 0) RETURN
 55   R = H**(-K)
      DO 60 I = 1,N
 60     DKY(I) = R*DKY(I)
      RETURN
C
 80   IFLAG = -1
      RETURN
 90   IFLAG = -2
      RETURN
C----------------------- END OF SUBROUTINE INTYD -----------------------
      END
      SUBROUTINE STOD  (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR,
     1   WM, IWM, F, JAC, RPAR, IPAR)
C-----------------------------------------------------------------------
C STOD  PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE
C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS.
C NOTE.. STOD  IS INDEPENDENT OF THE VALUE OF THE ITERATION METHOD
C INDICATOR MITER, WHEN THIS IS .NE. 0, AND HENCE IS INDEPENDENT
C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE.
C COMMUNICATION WITH STOD  IS DONE WITH THE FOLLOWING VARIABLES..
C
C Y      = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN
C          ALL CALLS TO F AND JAC.
C NEQ    = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND
C          PASSED AS THE NEQ ARGUMENT IN ALL CALLS TO F AND JAC.
C YH     = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES
C          AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE
C          LMAX = MAXORD + 1.  YH(I,J+1) CONTAINS THE APPROXIMATE
C          J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J)
C          (J = 0,1,...,NQ).  ON ENTRY FOR THE FIRST STEP, THE FIRST
C          TWO COLUMNS OF YH MUST BE SET FROM THE INITIAL VALUES.
C NYH    = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH.
C YH1    = A ONE-DIMENSIONAL ARRAY OCCUPYING THE SAME SPACE AS YH.
C EWT    = AN ARRAY OF N ELEMENTS WITH WHICH THE ESTIMATED LOCAL
C          ERRORS IN YH ARE COMPARED.
C SAVF   = AN ARRAY OF WORKING STORAGE, OF LENGTH N.
C ACOR   = A WORK ARRAY OF LENGTH N, USED FOR THE ACCUMULATED
C          CORRECTIONS.  ON A SUCCESSFUL RETURN, ACOR(I) CONTAINS
C          THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I).
C WM,IWM = REAL AND INTEGER WORK ARRAYS ASSOCIATED WITH MATRIX
C          OPERATIONS IN CHORD ITERATION (MITER .NE. 0).
C PJAC   = NAME OF ROUTINE TO EVALUATE AND PREPROCESS JACOBIAN MATRIX
C          IF A CHORD METHOD IS BEING USED.
C SLVS   = NAME OF ROUTINE TO SOLVE LINEAR SYSTEM IN CHORD ITERATION.
C H      = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP.
C          H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE
C          PROBLEM.  H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS
C          SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM.
C HMIN   = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED.
C HMXI   = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED.
C          HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX.
C          HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT
C          TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED.
C TN     = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN.
C JSTART = AN INTEGER USED FOR INPUT ONLY, WITH THE FOLLOWING
C          VALUES AND MEANINGS..
C               0  PERFORM THE FIRST STEP.
C           .GT.0  TAKE A NEW STEP CONTINUING FROM THE LAST.
C              -1  TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD,
C                    N, METH, MITER, AND/OR MATRIX PARAMETERS.
C              -2  TAKE THE NEXT STEP WITH A NEW VALUE OF H,
C                    BUT WITH OTHER INPUTS UNCHANGED.
C          ON RETURN, JSTART IS SET TO 1 TO FACILITATE CONTINUATION.
C KFLAG  = A COMPLETION CODE WITH THE FOLLOWING MEANINGS..
C               0  THE STEP WAS SUCCESFUL.
C              -1  THE REQUESTED ERROR COULD NOT BE ACHIEVED.
C              -2  CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED.
C          A RETURN WITH KFLAG = -1 OR -2 MEANS EITHER
C          ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED.
C          ON A RETURN WITH KFLAG NEGATIVE, THE VALUES OF TN AND
C          THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST
C          STEP, AND H IS THE LAST STEP SIZE ATTEMPTED.
C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED.
C METH/MITER = THE METHOD FLAGS.  SEE DESCRIPTION IN DRIVER.
C N      = THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS.
C-----------------------------------------------------------------------
C***ROUTINES CALLED  CFOD,SLVS,PJAC,VNWRMS
C
      EXTERNAL F, JAC
C
      INTEGER NEQ, NYH, IWM, I, I1, IALTH, IER, IOWND, IREDO, IRET,
     1   IPUP, J, JB, JSTART, KFLAG, L, LMAX, M, MAXORD, MEO, METH,
     2   MITER, N, NCF, NEWQ, NFE, NJE, NQ, NQNYH, NQU, NST, NSTEPJ
      REAL Y, YH, YH1, EWT, SAVF, ACOR, WM,
     1   ROWND, CONIT, CRATE, EL, ELCO, HOLD, RC, RMAX, TESCO,
     2   EL0, H, HMIN, HMXI, HU, TN, UROUND,
     3   DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP,
     4   R, RH, RHDN, RHSM, RHUP, TOLD, VNWRMS
      DIMENSION         Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*),
     1   ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*)
      COMMON /DEBDF1/ ROWND, CONIT, CRATE, EL(13), ELCO(13,12),
     1   HOLD, RC, RMAX, TESCO(3,12),
     2   EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(7), KSTEPS, IOD(6),
     3   IALTH, IPUP, LMAX, MEO, NQNYH, NSTEPJ,
     4   IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE,
     5   NJE, NQU
C
C
      KFLAG = 0
      TOLD = TN
      NCF = 0
      IF (JSTART .GT. 0) GO TO 200
      IF (JSTART .EQ. -1) GO TO 100
      IF (JSTART .EQ. -2) GO TO 160
C-----------------------------------------------------------------------
C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE
C INITIALIZED.  RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED
C IN A SINGLE STEP.  IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL
C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10.  IF A FAILURE
C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2
C FOR THE NEXT INCREASE.
C-----------------------------------------------------------------------
      LMAX = MAXORD + 1
      NQ = 1
      L = 2
      IALTH = 2
      RMAX = 10000.0E0
      RC = 0.0E0
      EL0 = 1.0E0
      CRATE = 0.7E0
      DELP = 0.0E0
      HOLD = H
      MEO = METH
      NSTEPJ = 0
      IRET = 3
      GO TO 140
C-----------------------------------------------------------------------
C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1.
C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE.
C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1),
C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP.
C IF THE CALLER HAS CHANGED METH, CFOD  IS CALLED TO RESET
C THE COEFFICIENTS OF THE METHOD.
C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT
C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY.
C IF H IS TO BE CHANGED, YH MUST BE RESCALED.
C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1
C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS.
C-----------------------------------------------------------------------
 100  IPUP = MITER
      LMAX = MAXORD + 1
      IF (IALTH .EQ. 1) IALTH = 2
      IF (METH .EQ. MEO) GO TO 110
      CALL CFOD  (METH, ELCO, TESCO)
      MEO = METH
      IF (NQ .GT. MAXORD) GO TO 120
      IALTH = L
      IRET = 1
      GO TO 150
 110  IF (NQ .LE. MAXORD) GO TO 160
 120  NQ = MAXORD
      L = LMAX
      DO 125 I = 1,L
 125    EL(I) = ELCO(I,NQ)
      NQNYH = NQ*NYH
      RC = RC*EL(1)/EL0
      EL0 = EL(1)
      CONIT = 0.5E0/FLOAT(NQ+2)
      DDN = VNWRMS (N, SAVF, EWT)/TESCO(1,L)
      EXDN = 1.0E0/FLOAT(L)
      RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0)
      RH = AMIN1(RHDN,1.0E0)
      IREDO = 3
      IF (H .EQ. HOLD) GO TO 170
      RH = AMIN1(RH,ABS(H/HOLD))
      H = HOLD
      GO TO 175
C-----------------------------------------------------------------------
C CFOD  IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE
C CURRENT METH.  THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET
C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM.
C-----------------------------------------------------------------------
 140  CALL CFOD  (METH, ELCO, TESCO)
 150  DO 155 I = 1,L
 155    EL(I) = ELCO(I,NQ)
      NQNYH = NQ*NYH
      RC = RC*EL(1)/EL0
      EL0 = EL(1)
      CONIT = 0.5E0/FLOAT(NQ+2)
      GO TO (160, 170, 200), IRET
C-----------------------------------------------------------------------
C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST
C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED.  IALTH IS SET TO
C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS
C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE.
C-----------------------------------------------------------------------
 160  IF (H .EQ. HOLD) GO TO 200
      RH = H/HOLD
      H = HOLD
      IREDO = 3
      GO TO 175
 170  RH = AMAX1(RH,HMIN/ABS(H))
 175  RH = AMIN1(RH,RMAX)
      RH = RH/AMAX1(1.0E0,ABS(H)*HMXI*RH)
      R = 1.0E0
      DO 180 J = 2,L
        R = R*RH
        DO 180 I = 1,N
 180      YH(I,J) = YH(I,J)*R
      H = H*RH
      RC = RC*RH
      IALTH = L
      IF (IREDO .EQ. 0) GO TO 680
C-----------------------------------------------------------------------
C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY
C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX.
C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT  H*EL(1).
C WHEN RC DIFFERS FROM 1 BY MORE THAN 30 PERCENT, IPUP IS SET TO MITER
C TO FORCE PJAC TO BE CALLED, IF A JACOBIAN IS INVOLVED.
C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY 20-TH STEP.
C-----------------------------------------------------------------------
 200  IF (ABS(RC-1.0E0) .GT. 0.3E0) IPUP = MITER
      IF (NST .GE. NSTEPJ+20) IPUP = MITER
      TN = TN + H
      I1 = NQNYH + 1
      DO 215 JB = 1,NQ
        I1 = I1 - NYH
        DO 210 I = I1,NQNYH
          IPNYH = I + NYH
 210      YH1(I) = YH1(I) + YH1(IPNYH)
 215    CONTINUE
      KSTEPS = KSTEPS + 1
C-----------------------------------------------------------------------
C UP TO 3 CORRECTOR ITERATIONS ARE TAKEN.  A CONVERGENCE TEST IS
C MADE ON THE R.M.S. NORM OF EACH CORRECTION, WEIGHTED BY THE ERROR
C WEIGHT VECTOR EWT.  THE SUM OF THE CORRECTIONS IS ACCUMULATED IN THE
C VECTOR ACOR(I).  THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP.
C-----------------------------------------------------------------------
 220  M = 0
      DO 230 I = 1,N
 230    Y(I) = YH(I,1)
      CALL F (TN, Y, SAVF, RPAR, IPAR)
      NFE = NFE + 1
      IF (IPUP .LE. 0) GO TO 250
C-----------------------------------------------------------------------
C IF INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND
C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION.  IPUP IS SET
C TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE.
C-----------------------------------------------------------------------
      IPUP = 0
      RC = 1.0E0
      NSTEPJ = NST
      CRATE = 0.7E0
      CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC,
     1          RPAR, IPAR)
      IF (IER .NE. 0) GO TO 430
 250  DO 260 I = 1,N
 260    ACOR(I) = 0.0E0
 270  IF (MITER .NE. 0) GO TO 350
C-----------------------------------------------------------------------
C IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM
C THE RESULT OF THE LAST FUNCTION EVALUATION.
C-----------------------------------------------------------------------
      DO 290 I = 1,N
        SAVF(I) = H*SAVF(I) - YH(I,2)
 290    Y(I) = SAVF(I) - ACOR(I)
      DEL = VNWRMS (N, Y, EWT)
      DO 300 I = 1,N
        Y(I) = YH(I,1) + EL(1)*SAVF(I)
 300    ACOR(I) = SAVF(I)
      GO TO 400
C-----------------------------------------------------------------------
C IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR,
C AND SOLVE THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND
C P AS COEFFICIENT MATRIX.
C-----------------------------------------------------------------------
 350  DO 360 I = 1,N
 360    Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I))
      CALL SLVS (WM, IWM, Y, SAVF)
      IF (IER .NE. 0) GO TO 410
      DEL = VNWRMS (N, Y, EWT)
      DO 380 I = 1,N
        ACOR(I) = ACOR(I) + Y(I)
 380    Y(I) = YH(I,1) + EL(1)*ACOR(I)
C-----------------------------------------------------------------------
C TEST FOR CONVERGENCE.  IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE
C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST.
C-----------------------------------------------------------------------
 400  IF (M .NE. 0) CRATE = AMAX1(0.2E0*CRATE,DEL/DELP)
      DCON = DEL*AMIN1(1.0E0,1.5E0*CRATE)/(TESCO(2,NQ)*CONIT)
      IF (DCON .LE. 1.0E0) GO TO 450
      M = M + 1
      IF (M .EQ. 3) GO TO 410
      IF (M .GE. 2 .AND. DEL .GT. 2.0E0*DELP) GO TO 410
      DELP = DEL
      CALL F (TN, Y, SAVF, RPAR, IPAR)
      NFE = NFE + 1
      GO TO 270
C-----------------------------------------------------------------------
C THE CORRECTOR ITERATION FAILED TO CONVERGE IN 3 TRIES.
C IF MITER .NE. 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR
C THE NEXT TRY.  OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES
C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE.  IF H CANNOT BE
C REDUCED OR 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2.
C-----------------------------------------------------------------------
 410  IF (IPUP .EQ. 0) GO TO 430
      IPUP = MITER
      GO TO 220
 430  TN = TOLD
      NCF = NCF + 1
      RMAX = 2.0E0
      I1 = NQNYH + 1
      DO 445 JB = 1,NQ
        I1 = I1 - NYH
        DO 440 I = I1,NQNYH
          IPNYH = I + NYH
 440      YH1(I) = YH1(I) - YH1(IPNYH)
 445    CONTINUE
      IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 670
      IF (NCF .EQ. 10) GO TO 670
      RH = 0.25E0
      IPUP = MITER
      IREDO = 1
      GO TO 170
C-----------------------------------------------------------------------
C THE CORRECTOR HAS CONVERGED.  IPUP IS SET TO -1 IF MITER .NE. 0,
C TO SIGNAL THAT THE JACOBIAN INVOLVED MAY NEED UPDATING LATER.
C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500
C IF IT FAILS.
C-----------------------------------------------------------------------
 450  IF (MITER .NE. 0) IPUP = -1
      IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ)
      IF (M .GT. 0) DSM = VNWRMS (N, ACOR, EWT)/TESCO(2,NQ)
      IF (DSM .GT. 1.0E0) GO TO 500
C-----------------------------------------------------------------------
C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY.
C CONSIDER CHANGING H IF IALTH = 1.  OTHERWISE DECREASE IALTH BY 1.
C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR
C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP.
C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER
C BY ONE IS CONSIDERED ALSO.  A CHANGE IN H IS MADE ONLY IF IT IS BY A
C FACTOR OF AT LEAST 1.1.  IF NOT, IALTH IS SET TO 3 TO PREVENT
C TESTING FOR THAT MANY STEPS.
C-----------------------------------------------------------------------
      KFLAG = 0
      IREDO = 0
      NST = NST + 1
      HU = H
      NQU = NQ
      DO 470 J = 1,L
        DO 470 I = 1,N
 470      YH(I,J) = YH(I,J) + EL(J)*ACOR(I)
      IALTH = IALTH - 1
      IF (IALTH .EQ. 0) GO TO 520
      IF (IALTH .GT. 1) GO TO 690
      IF (L .EQ. LMAX) GO TO 690
      DO 490 I = 1,N
 490    YH(I,LMAX) = ACOR(I)
      GO TO 690
C-----------------------------------------------------------------------
C THE ERROR TEST FAILED.  KFLAG KEEPS TRACK OF MULTIPLE FAILURES.
C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE
C TO TRY THE STEP AGAIN.  COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR
C ONE LOWER ORDER.  AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE
C BY A FACTOR OF 0.2 OR LESS.
C-----------------------------------------------------------------------
 500  KFLAG = KFLAG - 1
      TN = TOLD
      I1 = NQNYH + 1
      DO 515 JB = 1,NQ
        I1 = I1 - NYH
        DO 510 I = I1,NQNYH
          IPNYH = I + NYH
 510      YH1(I) = YH1(I) - YH1(IPNYH)
 515    CONTINUE
      RMAX = 2.0E0
      IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 660
      IF (KFLAG .LE. -3) GO TO 640
      IREDO = 2
      RHUP = 0.0E0
      GO TO 540
C-----------------------------------------------------------------------
C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS
C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED
C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY.
C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE.
C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN
C ACCORDINGLY.  IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE
C ADDITIONAL SCALED DERIVATIVE.
C-----------------------------------------------------------------------
 520  RHUP = 0.0E0
      IF (L .EQ. LMAX) GO TO 540
      DO 530 I = 1,N
 530    SAVF(I) = ACOR(I) - YH(I,LMAX)
      DUP = VNWRMS (N, SAVF, EWT)/TESCO(3,NQ)
      EXUP = 1.0E0/FLOAT(L+1)
      RHUP = 1.0E0/(1.4E0*DUP**EXUP + 0.0000014E0)
 540  EXSM = 1.0E0/FLOAT(L)
      RHSM = 1.0E0/(1.2E0*DSM**EXSM + 0.0000012E0)
      RHDN = 0.0E0
      IF (NQ .EQ. 1) GO TO 560
      DDN = VNWRMS (N, YH(1,L), EWT)/TESCO(1,NQ)
      EXDN = 1.0E0/FLOAT(NQ)
      RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0)
 560  IF (RHSM .GE. RHUP) GO TO 570
      IF (RHUP .GT. RHDN) GO TO 590
      GO TO 580
 570  IF (RHSM .LT. RHDN) GO TO 580
      NEWQ = NQ
      RH = RHSM
      GO TO 620
 580  NEWQ = NQ - 1
      RH = RHDN
      IF (KFLAG .LT. 0 .AND. RH .GT. 1.0E0) RH = 1.0E0
      GO TO 620
 590  NEWQ = L
      RH = RHUP
      IF (RH .LT. 1.1E0) GO TO 610
      R = EL(L)/FLOAT(L)
      DO 600 I = 1,N
 600    YH(I,NEWQ+1) = ACOR(I)*R
      GO TO 630
 610  IALTH = 3
      GO TO 690
 620  IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1E0)) GO TO 610
      IF (KFLAG .LE. -2) RH = AMIN1(RH,0.2E0)
C-----------------------------------------------------------------------
C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS.
C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED.
C THEN EXIT FROM 680 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE.
C-----------------------------------------------------------------------
      IF (NEWQ .EQ. NQ) GO TO 170
 630  NQ = NEWQ
      L = NQ + 1
      IRET = 2
      GO TO 150
C-----------------------------------------------------------------------
C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURED.
C IF 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1.
C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE
C YH ARRAY HAVE ERRORS OF THE WRONG ORDER.  HENCE THE FIRST
C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1.  THEN
C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED,
C UNTIL IT SUCCEEDS OR H REACHES HMIN.
C-----------------------------------------------------------------------
 640  IF (KFLAG .EQ. -10) GO TO 660
      RH = 0.1E0
      RH = AMAX1(HMIN/ABS(H),RH)
      H = H*RH
      DO 645 I = 1,N
 645    Y(I) = YH(I,1)
      CALL F (TN, Y, SAVF, RPAR, IPAR)
      NFE = NFE + 1
      DO 650 I = 1,N
 650    YH(I,2) = H*SAVF(I)
      IPUP = MITER
      IALTH = 5
      IF (NQ .EQ. 1) GO TO 200
      NQ = 1
      L = 2
      IRET = 3
      GO TO 150
C-----------------------------------------------------------------------
C ALL RETURNS ARE MADE THROUGH THIS SECTION.  H IS SAVED IN HOLD
C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP.
C-----------------------------------------------------------------------
 660  KFLAG = -1
      GO TO 700
 670  KFLAG = -2
      GO TO 700
 680  RMAX = 10.0E0
 690  R = 1.0E0/TESCO(2,NQU)
      DO 695 I = 1,N
 695    ACOR(I) = ACOR(I)*R
 700  HOLD = H
      JSTART = 1
      RETURN
C----------------------- END OF SUBROUTINE STOD  -----------------------
      END
      SUBROUTINE CFOD  (METH, ELCO, TESCO)
C
C   CFOD DEFINES COEFFICIENTS NEEDED IN THE INTEGRATOR PACKAGE SFODE
C
      INTEGER METH, I, IB, NQ, NQM1, NQP1
      REAL ELCO, TESCO, AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ,
     1   RQFAC, RQ1FAC, TSIGN, XPIN
      DIMENSION ELCO(13, *), TESCO(3, *)
C-----------------------------------------------------------------------
C CFOD  IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS
C NEEDED THERE.  THE COEFFICIENTS FOR THE CURRENT METHOD, AS
C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED.
C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2.
C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.)
C CFOD  IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM,
C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED.
C
C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS.
C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF
C ORDER NQ ARE STORED IN ELCO(I,NQ).  THEY ARE GIVEN BY A GENETRATING
C POLYNOMIAL, I.E.,
C     L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ.
C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY
C     DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1),    L(-1) = 0.
C FOR THE BDF METHODS, L(X) IS GIVEN BY
C     L(X) = (X+1)*(X+2)* ... *(X+NQ)/K,
C WHERE         K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ).
C
C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE
C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER.
C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP
C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER
C NQ + 1 IF K = 3.
C-----------------------------------------------------------------------
      DIMENSION PC(12)
C
      GO TO (100, 200), METH
C
 100  ELCO(1,1) = 1.0E0
      ELCO(2,1) = 1.0E0
      TESCO(1,1) = 0.0E0
      TESCO(2,1) = 2.0E0
      TESCO(1,2) = 1.0E0
      TESCO(3,12) = 0.0E0
      PC(1) = 1.0E0
      RQFAC = 1.0E0
      DO 140 NQ = 2,12
C-----------------------------------------------------------------------
C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL
C     P(X) = (X+1)*(X+2)*...*(X+NQ-1).
C INITIALLY, P(X) = 1.
C-----------------------------------------------------------------------
        RQ1FAC = RQFAC
        RQFAC = RQFAC/FLOAT(NQ)
        NQM1 = NQ - 1
        FNQM1 = FLOAT(NQM1)
        NQP1 = NQ + 1
C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ----------------------------------
        PC(NQ) = 0.0E0
        DO 110 IB = 1,NQM1
          I = NQP1 - IB
 110      PC(I) = PC(I-1) + FNQM1*PC(I)
        PC(1) = FNQM1*PC(1)
C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). -----------------------
        PINT = PC(1)
        XPIN = PC(1)/2.0E0
        TSIGN = 1.0E0
        DO 120 I = 2,NQ
          TSIGN = -TSIGN
          PINT = PINT + TSIGN*PC(I)/FLOAT(I)
 120      XPIN = XPIN + TSIGN*PC(I)/FLOAT(I+1)
C STORE COEFFICIENTS IN ELCO AND TESCO. --------------------------------
        ELCO(1,NQ) = PINT*RQ1FAC
        ELCO(2,NQ) = 1.0E0
        DO 130 I = 2,NQ
 130      ELCO(I+1,NQ) = RQ1FAC*PC(I)/FLOAT(I)
        AGAMQ = RQFAC*XPIN
        RAGQ = 1.0E0/AGAMQ
        TESCO(2,NQ) = RAGQ
      IF(NQ.LT.12)TESCO(1,NQP1)=RAGQ*RQFAC/FLOAT(NQP1)
        TESCO(3,NQM1) = RAGQ
 140    CONTINUE
      RETURN
C
 200  PC(1) = 1.0E0
      RQ1FAC = 1.0E0
      DO 230 NQ = 1,5
C-----------------------------------------------------------------------
C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL
C     P(X) = (X+1)*(X+2)*...*(X+NQ).
C INITIALLY, P(X) = 1.
C-----------------------------------------------------------------------
        FNQ = FLOAT(NQ)
        NQP1 = NQ + 1
C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------
        PC(NQP1) = 0.0E0
        DO 210 IB = 1,NQ
          I = NQ + 2 - IB
 210      PC(I) = PC(I-1) + FNQ*PC(I)
        PC(1) = FNQ*PC(1)
C STORE COEFFICIENTS IN ELCO AND TESCO. --------------------------------
        DO 220 I = 1,NQP1
 220      ELCO(I,NQ) = PC(I)/PC(2)
        ELCO(2,NQ) = 1.0E0
        TESCO(1,NQ) = RQ1FAC
        TESCO(2,NQ) = FLOAT(NQP1)/ELCO(1,NQ)
        TESCO(3,NQ) = FLOAT(NQ+2)/ELCO(1,NQ)
        RQ1FAC = RQ1FAC/FNQ
 230    CONTINUE
      RETURN
C----------------------- END OF SUBROUTINE CFOD  -----------------------
      END
      SUBROUTINE PJAC (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM,
     1   F, JAC, RPAR, IPAR)
C
C   PJAC SETS UP THE ITERATION MATRIX (INVOLVING THE JACOBIAN) FOR THE
C   INTEGRATION PACKAGE SFODE.
C
C***ROUTINES CALLED  VNWRMS,SGEFA,SGBFA
C
      INTEGER NEQ, NYH, IWM, I, I1, I2, IER, II, IOWND, IOWNS, J, J1,
     1   JJ, JSTART, KFLAG, L, LENP, MAXORD, MBA, MBAND, MEB1, MEBAND,
     2   METH, MITER, ML, ML3, MU, N, NFE, NJE, NQ, NQU, NST
      EXTERNAL F, JAC
      REAL Y, YH, EWT, FTEM, SAVF, WM,
     1   ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND,
     2   CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, VNWRMS
      DIMENSION         Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*),
     1   WM(*), IWM( *), RPAR(*), IPAR(*)
      COMMON /DEBDF1/ ROWND, ROWNS(210),
     1   EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6),
     4   IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE,
     5   NJE, NQU
C-----------------------------------------------------------------------
C PJAC IS CALLED BY STOD  TO COMPUTE AND PROCESS THE MATRIX
C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN.
C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF
C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5.
C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED.
C J IS STORED IN WM AND REPLACED BY P.  IF MITER .NE. 3, P IS THEN
C SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION
C OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE
C BY SGEFA IF MITER = 1 OR 2, AND BY SGBFA IF MITER = 4 OR 5.
C
C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION
C WITH PJAC USES THE FOLLOWING..
C Y    = ARRAY CONTAINING PREDICTED VALUES ON ENTRY.
C FTEM = WORK ARRAY OF LENGTH N (ACOR IN STOD ).
C SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y.
C WM   = REAL WORK SPACE FOR MATRICES.  ON OUTPUT IT CONTAINS THE
C        INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU DECOMPOSITION
C        OF P IF MITER IS 1, 2 , 4, OR 5.
C        STORAGE OF MATRIX ELEMENTS STARTS AT WM(3).
C        WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA..
C        WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS.
C        WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = 3.
C IWM  = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT
C        IWM(21), IF MITER IS 1, 2, 4, OR 5.  IWM ALSO CONTAINS THE
C        BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5.
C EL0  = EL(1) (INPUT).
C IER  = OUTPUT ERROR FLAG,  = 0 IF NO TROUBLE, .NE. 0 IF
C        P MATRIX FOUND TO BE SINGULAR.
C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND,
C MITER, N, NFE, AND NJE.
C-----------------------------------------------------------------------
      NJE = NJE + 1
      HL0 = H*EL0
      GO TO (100, 200, 300, 400, 500), MITER
C IF MITER = 1, CALL JAC AND MULTIPLY BY SCALAR. -----------------------
 100  LENP = N*N
      DO 110 I = 1,LENP
 110    WM(I+2) = 0.0E0
      CALL JAC (TN, Y, WM(3), N, RPAR, IPAR)
      CON = -HL0
      DO 120 I = 1,LENP
 120    WM(I+2) = WM(I+2)*CON
      GO TO 240
C IF MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. --------------------
 200  FAC = VNWRMS (N, SAVF, EWT)
      R0 = 1000.0E0*ABS(H)*UROUND*FLOAT(N)*FAC
      IF (R0 .EQ. 0.0E0) R0 = 1.0E0
      SRUR = WM(1)
      J1 = 2
      DO 230 J = 1,N
        YJ = Y(J)
        R = AMAX1(SRUR*ABS(YJ),R0*EWT(J))
        Y(J) = Y(J) + R
        FAC = -HL0/R
        CALL F (TN, Y, FTEM, RPAR, IPAR)
        DO 220 I = 1,N
 220      WM(I+J1) = (FTEM(I) - SAVF(I))*FAC
        Y(J) = YJ
        J1 = J1 + N
 230    CONTINUE
      NFE = NFE + N
C ADD IDENTITY MATRIX. -------------------------------------------------
 240  J = 3
      DO 250 I = 1,N
        WM(J) = WM(J) + 1.0E0
 250    J = J + (N + 1)
C DO LU DECOMPOSITION ON P. --------------------------------------------
      CALL SGEFA (WM(3), N, N, IWM(21), IER)
      RETURN
C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND P. ---------
 300  WM(2) = HL0
      IER = 0
      R = EL0*0.1E0
      DO 310 I = 1,N
 310    Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2))
      CALL F (TN, Y, WM(3), RPAR, IPAR)
      NFE = NFE + 1
      DO 320 I = 1,N
        R0 = H*SAVF(I) - YH(I,2)
        DI = 0.1E0*R0 - H*(WM(I+2) - SAVF(I))
        WM(I+2) = 1.0E0
        IF (ABS(R0) .LT. UROUND*EWT(I)) GO TO 320
        IF (ABS(DI) .EQ. 0.0E0) GO TO 330
        WM(I+2) = 0.1E0*R0/DI
 320    CONTINUE
      RETURN
 330  IER = -1
      RETURN
C IF MITER = 4, CALL JAC AND MULTIPLY BY SCALAR. -----------------------
 400  ML = IWM(1)
      MU = IWM(2)
      ML3 =  3
      MBAND = ML + MU + 1
      MEBAND = MBAND + ML
      LENP = MEBAND*N
      DO 410 I = 1,LENP
 410    WM(I+2) = 0.0E0
      CALL JAC (TN, Y, WM(ML3), MEBAND, RPAR, IPAR)
      CON = -HL0
      DO 420 I = 1,LENP
 420    WM(I+2) = WM(I+2)*CON
      GO TO 570
C IF MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ----------------
 500  ML = IWM(1)
      MU = IWM(2)
      MBAND = ML + MU + 1
      MBA = MIN0(MBAND,N)
      MEBAND = MBAND + ML
      MEB1 = MEBAND - 1
      SRUR = WM(1)
      FAC = VNWRMS (N, SAVF, EWT)
      R0 = 1000.0E0*ABS(H)*UROUND*FLOAT(N)*FAC
      IF (R0 .EQ. 0.0E0) R0 = 1.0E0
      DO 560 J = 1,MBA
        DO 530 I = J,N,MBAND
          YI = Y(I)
          R = AMAX1(SRUR*ABS(YI),R0*EWT(I))
 530      Y(I) = Y(I) + R
        CALL F (TN, Y, FTEM, RPAR, IPAR)
        DO 550 JJ = J,N,MBAND
          Y(JJ) = YH(JJ,1)
          YJJ = Y(JJ)
          R = AMAX1(SRUR*ABS(YJJ),R0*EWT(JJ))
          FAC = -HL0/R
          I1 = MAX0(JJ-MU,1)
          I2 = MIN0(JJ+ML,N)
          II = JJ*MEB1 - ML + 2
          DO 540 I = I1,I2
 540        WM(II+I) = (FTEM(I) - SAVF(I))*FAC
 550      CONTINUE
 560    CONTINUE
      NFE = NFE + MBA
C ADD IDENTITY MATRIX. -------------------------------------------------
 570  II = MBAND + 2
      DO 580 I = 1,N
        WM(II) = WM(II) + 1.0E0
 580    II = II + MEBAND
C DO LU DECOMPOSITION OF P. --------------------------------------------
      CALL SGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER)
      RETURN
C----------------------- END OF SUBROUTINE PJAC -----------------------
      END
      SUBROUTINE SLVS (WM, IWM, X, TEM)
C
C   SLVS SOLVES THE LINEAR SYSTEM IN THE ITERATION SCHEME FOR THE
C   INTEGRATOR PACKAGE SFODE.
C
C***ROUTINES CALLED  SGESL,SGBSL
C
      INTEGER IWM, I, IER, IOWND, IOWNS, JSTART, KFLAG, L, MAXORD,
     1   MEBAND, METH, MITER, ML, MU, N, NFE, NJE, NQ, NQU, NST
      REAL WM, X, TEM,
     1   ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND,
     2   DI, HL0, PHL0, R
      DIMENSION WM(*), IWM( *), X(*), TEM(*)
      COMMON /DEBDF1/ ROWND, ROWNS(210),
     1   EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6),
     4   IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE,
     5   NJE, NQU
C-----------------------------------------------------------------------
C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM
C A CHORD ITERATION.  IT IS CALLED BY STOD  IF MITER .NE. 0.
C IF MITER IS 1 OR 2, IT CALLS SGESL TO ACCOMPLISH THIS.
C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL
C MATRIX, AND THEN COMPUTES THE SOLUTION.
C IF MITER IS 4 OR 5, IT CALLS SGBSL.
C COMMUNICATION WITH SLVS USES THE FOLLOWING VARIABLES..
C WM  = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX IF MITER
C       IS 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE.
C       STORAGE OF MATRIX ELEMENTS STARTS AT WM(3).
C       WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA..
C       WM(1) = SQRT(UROUND) (NOT USED HERE),
C       WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3.
C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT
C       IWM(21), IF MITER IS 1, 2, 4, OR 5.  IWM ALSO CONTAINS THE
C       BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5.
C X   = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR
C       ON OUTPUT, OF LENGTH N.
C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION.
C IER = OUTPUT FLAG (IN COMMON).  IER = 0 IF NO TROUBLE OCCURRED.
C       IER = -1 IF A SINGULAR MATRIX AROSE WITH MITER = 3.
C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N.
C-----------------------------------------------------------------------
      IER = 0
      GO TO (100, 100, 300, 400, 400), MITER
 100  CALL SGESL (WM(3), N, N, IWM(21), X, 0)
      RETURN
C
 300  PHL0 = WM(2)
      HL0 = H*EL0
      WM(2) = HL0
      IF (HL0 .EQ. PHL0) GO TO 330
      R = HL0/PHL0
      DO 320 I = 1,N
        DI = 1.0E0 - R*(1.0E0 - 1.0E0/WM(I+2))
        IF (ABS(DI) .EQ. 0.0E0) GO TO 390
 320    WM(I+2) = 1.0E0/DI
 330  DO 340 I = 1,N
 340    X(I) = WM(I+2)*X(I)
      RETURN
 390  IER = -1
      RETURN
C
 400  ML = IWM(1)
      MU = IWM(2)
      MEBAND = 2*ML + MU + 1
      CALL SGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0)
      RETURN
C----------------------- END OF SUBROUTINE SLVS -----------------------
      END
      SUBROUTINE SGBFA(ABD,LDA,N,ML,MU,IPVT,INFO)
      INTEGER LDA,N,ML,MU,IPVT(*),INFO
      REAL ABD(LDA,*)
C
C     SGBFA FACTORS A REAL BAND MATRIX BY ELIMINATION.
C
C     SGBFA IS USUALLY CALLED BY SGBCO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C
C     ON ENTRY
C
C        ABD     REAL(LDA, N)
C                CONTAINS THE MATRIX IN BAND STORAGE.  THE COLUMNS
C                OF THE MATRIX ARE STORED IN THE COLUMNS OF  ABD  AND
C                THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
C                ML+1 THROUGH 2*ML+MU+1 OF  ABD .
C                SEE THE COMMENTS BELOW FOR DETAILS.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  ABD .
C                LDA MUST BE .GE. 2*ML + MU + 1 .
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C                0 .LE. MU .LT. N .
C                MORE EFFICIENT IF  ML .LE. MU .
C     ON RETURN
C
C        ABD     AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
C                THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT SGBSL WILL DIVIDE BY ZERO IF
C                     CALLED.  USE  RCOND  IN SGBCO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     BAND STORAGE
C
C           IF  A  IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT
C           WILL SET UP THE INPUT.
C
C                   ML = (BAND WIDTH BELOW THE DIAGONAL)
C                   MU = (BAND WIDTH ABOVE THE DIAGONAL)
C                   M = ML + MU + 1
C                   DO 20 J = 1, N
C                      I1 = MAX0(1, J-MU)
C                      I2 = MIN0(N, J+ML)
C                      DO 10 I = I1, I2
C                         K = I - J + M
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           THIS USES ROWS  ML+1  THROUGH  2*ML+MU+1  OF  ABD .
C           IN ADDITION, THE FIRST  ML  ROWS IN  ABD  ARE USED FOR
C           ELEMENTS GENERATED DURING THE TRIANGULARIZATION.
C           THE TOTAL NUMBER OF ROWS NEEDED IN  ABD  IS  2*ML+MU+1 .
C           THE  ML+MU BY ML+MU  UPPER LEFT TRIANGLE AND THE
C           ML BY ML  LOWER RIGHT TRIANGLE ARE NOT REFERENCED.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SSCAL,ISAMAX
C     FORTRAN MAX0,MIN0
C
      REAL T
      INTEGER I,ISAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1
C
      M = ML + MU + 1
      INFO = 0
C
C     ZERO INITIAL FILL-IN COLUMNS
C
      J0 = MU + 2
      J1 = MIN0(N,M) - 1
      IF (J1 .LT. J0) GO TO 30
      DO 20 JZ = J0, J1
         I0 = M + 1 - JZ
         DO 10 I = I0, ML
            ABD(I,JZ) = 0.0E0
   10    CONTINUE
   20 CONTINUE
   30 CONTINUE
      JZ = J1
      JU = 0
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 130
      DO 120 K = 1, NM1
         KP1 = K + 1
C
C        ZERO NEXT FILL-IN COLUMN
C
         JZ = JZ + 1
         IF (JZ .GT. N) GO TO 50
         IF (ML .LT. 1) GO TO 50
            DO 40 I = 1, ML
               ABD(I,JZ) = 0.0E0
   40       CONTINUE
   50    CONTINUE
C
C        FIND L = PIVOT INDEX
C
         LM = MIN0(ML,N-K)
         L = ISAMAX(LM+1,ABD(M,K),1) + M - 1
         IPVT(K) = L + K - M
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (ABD(L,K) .EQ. 0.0E0) GO TO 100
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. M) GO TO 60
               T = ABD(L,K)
               ABD(L,K) = ABD(M,K)
               ABD(M,K) = T
   60       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0E0/ABD(M,K)
            CALL SSCAL(LM,T,ABD(M+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            JU = MIN0(MAX0(JU,MU+IPVT(K)),N)
            MM = M
            IF (JU .LT. KP1) GO TO 90
            DO 80 J = KP1, JU
               L = L - 1
               MM = MM - 1
               T = ABD(L,J)
               IF (L .EQ. MM) GO TO 70
                  ABD(L,J) = ABD(MM,J)
                  ABD(MM,J) = T
   70          CONTINUE
               CALL SAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1)
   80       CONTINUE
   90       CONTINUE
         GO TO 110
  100    CONTINUE
            INFO = K
  110    CONTINUE
  120 CONTINUE
  130 CONTINUE
      IPVT(N) = N
      IF (ABD(M,N) .EQ. 0.0E0) INFO = N
      RETURN
      END
      SUBROUTINE SGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB)
      INTEGER LDA,N,ML,MU,IPVT(*),JOB
      REAL ABD(LDA,*),B(*)
C
C     SGBSL SOLVES THE REAL BAND SYSTEM
C     A * X = B  OR  TRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY SGBCO OR SGBFA.
C
C     ON ENTRY
C
C        ABD     REAL(LDA, N)
C                THE OUTPUT FROM SGBCO OR SGBFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  ABD .
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SGBCO OR SGBFA.
C
C        B       REAL(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF SGBCO HAS SET RCOND .GT. 0.0
C        OR SGBFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL SGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL SGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SDOT
C     FORTRAN MIN0
C
      REAL SDOT,T
      INTEGER K,KB,L,LA,LB,LM,M,NM1
C
      M = MU + ML + 1
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE L*Y = B
C
         IF (ML .EQ. 0) GO TO 30
         IF (NM1 .LT. 1) GO TO 30
            DO 20 K = 1, NM1
               LM = MIN0(ML,N-K)
               L = IPVT(K)
               T = B(L)
               IF (L .EQ. K) GO TO 10
                  B(L) = B(K)
                  B(K) = T
   10          CONTINUE
               CALL SAXPY(LM,T,ABD(M+1,K),1,B(K+1),1)
   20       CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/ABD(M,K)
            LM = MIN0(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = -B(K)
            CALL SAXPY(LM,T,ABD(LA,K),1,B(LB),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            LM = MIN0(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = SDOT(LM,ABD(LA,K),1,B(LB),1)
            B(K) = (B(K) - T)/ABD(M,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (ML .EQ. 0) GO TO 90
         IF (NM1 .LT. 1) GO TO 90
            DO 80 KB = 1, NM1
               K = N - KB
               LM = MIN0(ML,N-K)
               B(K) = B(K) + SDOT(LM,ABD(M+1,K),1,B(K+1),1)
               L = IPVT(K)
               IF (L .EQ. K) GO TO 70
                  T = B(L)
                  B(L) = B(K)
                  B(K) = T
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      FUNCTION VNORM(V,NCOMP)
C
C     COMPUTE THE MAXIMUM NORM OF THE VECTOR V(*) OF LENGTH NCOMP AND
C     RETURN THE RESULT AS VNORM
C
      DIMENSION V(NCOMP)
C
      VNORM=0.
      DO 10 K=1,NCOMP
   10   VNORM=AMAX1(VNORM,ABS(V(K)))
      RETURN
      END
      REAL FUNCTION VNWRMS (N, V, W)
C-----------------------------------------------------------------------
C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM
C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS
C CONTAINED IN THE ARRAY W OF LENGTH N..
C   VNWRMS = SQRT( (1/N) * SUM( V(I)/W(I) )**2 )
C-----------------------------------------------------------------------
      INTEGER N, I
      REAL V, W, SUM
      DIMENSION V(N), W(N)
C
      SUM = 0.0E0
      DO 10 I = 1,N
 10     SUM = SUM + (V(I)/W(I))**2
      VNWRMS = SQRT(SUM/FLOAT(N))
      RETURN
C----------------------- END OF FUNCTION VNWRMS ------------------------
      END
      SUBROUTINE RK(N,T,H,A,F)
C     ******************************************************************
C     FOURTH ORDER RUNGE-KUTTA PROCEDURE FOR SOLVING DY=F(T,Y)
C     ******************************************************************
      DIMENSION A(*)
      EXTERNAL F
      NP1=N+1
      IF (H.EQ.0.0) GO TO 50
C
      HA=.5*H
      TA=T+HA
      M=N+N
      M1=M+1
C
      DO 10 K=1,N
      NK=N+K
      MK=M+K
      A(NK)=HA*A(NK)
   10 A(MK)=A(K)+A(NK)
      CALL F(TA,A(M1))
C
      DO 20 K=1,N
      NK=N+K
      MK=M+K
      A(NK)=A(NK)+H*A(MK)
   20 A(MK)=A(K)+HA*A(MK)
      CALL F(TA,A(M1))
C
      T=T+H
      DO 30 K=1,N
      NK=N+K
      MK=M+K
      A(MK)=H*A(MK)
      A(NK)=A(NK)+A(MK)
   30 A(MK)=A(K)+A(MK)
      CALL F(T,A(M1))
C
      DO 40 K=1,N
      NK=N+K
      MK=M+K
      A(K)=A(K)+(A(NK)+HA*A(MK))/3.0
   40 A(NK)=A(K)
      CALL F(T,A(NP1))
      RETURN
C
   50 DO 51 K=1,N
      NK=N+K
   51 A(NK)=A(K)
      CALL F(T,A(NP1))
      RETURN
      END
      SUBROUTINE RK8(N,T,H,Y,DY,W,F)
C     ******************************************************************
C     EIGHTH ORDER RUNGE-KUTTA PROCEDURE FOR SOLVING DY=F(T,Y)
C     ******************************************************************
      REAL Y(N),DY(N),W(*)
      REAL A(7),B(8,7),C(7),D(9)
      EXTERNAL F
C     -------------------
      DATA A(1)/.3333333333333333/,  A(2)/.5/,  A(3)/.6666666666666666/,
     1     A(4)/.1666666666666666/,  A(5)/1./,  A(6)/.8333333333333333/,
     2     A(7)/1./
      DATA B(1,1)/1./,  B(2,1)/3./
      DATA B(1,2)/1./,  B(2,2)/0./,  B(3,2)/3./
      DATA B(1,3)/13./,  B(2,3)/-27./,  B(3,3)/42./,  B(4,3)/8./
      DATA B(1,4)/389./,  B(2,4)/-54./,  B(3,4)/966./,  B(4,4)/-824./,
     1     B(5,4)/243./
      DATA B(1,5)/-231./,  B(2,5)/81./,  B(3,5)/-1164./,  B(4,5)/656./,
     1     B(5,5)/-122./,  B(6,5)/800./
      DATA B(1,6)/-127./,  B(2,6)/18./,  B(3,6)/-678./,  B(4,6)/456./,
     1     B(5,6)/-9./,  B(6,6)/576./,  B(7,6)/4./
      DATA B(1,7)/1481./,  B(2,7)/-81./,  B(3,7)/7104./,
     1     B(4,7)/-3376./,  B(5,7)/72./,  B(6,7)/-5040./,
     2     B(7,7)/-60./,  B(8,7)/720./
      DATA C(1)/12./,  C(2)/8./,  C(3)/54./,  C(4)/4320./,  C(5)/20./,
     1     C(6)/288./,  C(7)/820./
      DATA D(1)/41./,  D(2)/0./,  D(3)/27./,  D(4)/272./,  D(5)/27./,
     1     D(6)/216./,  D(7)/0./,  D(8)/216./,  D(9)/41./
C     -------------------
      IF (H.EQ.0.) GO TO 40
      HA=H*4./27.
      DO 10 K=1,N
   10 W(K)=Y(K)+HA*DY(K)
      CALL F(T+HA,W(1))
      DO 11 K=1,N
   11 W(K)=Y(K)+H*(DY(K)/18.+W(K)/6.)
      CALL F(T+H*2./9.,W(1))
C
      I=1
      DO 22 M=2,8
      I=I+N
      M1=M-1
      DO 21 K=1,N
      SUM=B(1,M1)*DY(K)
      L=K
      DO 20 J=2,M
      SUM=SUM+B(J,M1)*W(L)
   20 L=L+N
   21 W(L)=Y(K)+SUM*H/C(M1)
   22 CALL F(T+A(M1)*H,W(I))
C
      DO 31 K=1,N
      SUM=D(1)*DY(K)
      L=K
      DO 30 M=2,9
      SUM=SUM+D(M)*W(L)
   30 L=L+N
      Y(K)=Y(K)+H*SUM/840.
   31 DY(K)=Y(K)
      T=T+H
      CALL F(T,DY)
      RETURN
C
   40 DO 41 K=1,N
   41 DY(K)=Y(K)
      CALL F(T,DY)
      RETURN
      END
      SUBROUTINE SEPDE (COFX, COFY, G, EDGE, BVAL, IORD, A, B, MP1,
     *                         C, D, NP1, U, KU, W, NW, IERR)
C ----------------------------------------------------------------------
C     SOLUTION OF SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS
C                     ON RECTANGULAR DOMAINS
C ----------------------------------------------------------------------
      REAL U(KU,NP1), W(NW), DUM(1)
      INTEGER EDGE(4)
      EXTERNAL COFX, COFY
C     --------------
      DATA ALPHA/0.0/, BETA/0.0/, GAM/0.0/, DEL/0.0/
C     --------------
      CALL PDEDGE (EDGE, INDX, INDY, IERR)
      IF (IERR .NE. 0) RETURN
C
      IF (A .GE. B .OR. C .GE. D) GO TO 300
      IF (MP1 .LT. 7) GO TO 320
      IF (NP1 .LT. 6) GO TO 330
      M = MP1 - 1
      N = NP1 - 1
      HX = (B - A)/FLOAT(M)
      HY = (D - C)/FLOAT(N)
C
C     DEFINE THE MAXIMUM AND MINIMUM ROW AND COLUMN
C     THAT IS NEEDED FOR THE RIGHT-HAND SIDE MATRIX
C
      XMIN = A
      YMIN = C
      IMIN = 1
      IMAX = MP1
      JMIN = 1
      JMAX = NP1
      JCOL = 0
      IF (EDGE(1) .NE. 0) GO TO 10
      JMIN = 2
      YMIN = C + HY
      JCOL = MP1
   10 IF (EDGE(2) .NE. 0) GO TO 20
      IMIN = 2
      XMIN = A + HX
   20 IF (EDGE(3) .EQ. 0) JMAX = N
      IF (EDGE(4) .EQ. 0) IMAX = M
C
C     DEFINE THE RIGHT-HAND SIDE MATRIX FOR IORD = 2
C
      IF (KU .LT. MP1) GO TO 310
      IF (IORD .NE. 2) GO TO 40
      MN = 0
C
      YJ = YMIN
      DO 31 J = JMIN,JMAX
      XI = XMIN
         DO 30 I = IMIN,IMAX
         U(I,J) = G(XI, YJ)
   30    XI = XI + HX
   31 YJ = YJ + HY
      GO TO 60
C
C     DEFINE THE RIGHT-HAND SIDE MATRIX FOR IORD = 4
C
   40 IF (IORD .NE. 4) GO TO 340
      MN = MP1*NP1
      IF (MN .GE. NW) GO TO 100
C
      YJ = YMIN
      DO 51 J = JMIN,JMAX
      XI = XMIN
         DO 50 I = IMIN,IMAX
         IJ = I + JCOL
         W(IJ) = G(XI, YJ)
   50    XI = XI + HX
      YJ = YJ + HY
   51 JCOL = JCOL + MP1
C
C     STORE THE BOUNDARY VALUES OF U
C
   60 IF (EDGE(1) .NE. 0) GO TO 70
      XI = A
      DO 61 I = 1,MP1
         U(I,1) = BVAL(1,XI,C)
   61 XI = XI + HX
C
   70 IF (EDGE(2) .NE. 0) GO TO 80
      YJ = C
      DO 71 J = 1,NP1
         U(1,J) = BVAL(2,A,YJ)
   71 YJ = YJ + HY
C
   80 IF (EDGE(3) .NE. 0) GO TO 90
      XI = A
      DO 81 I = 1,MP1
         U(I,NP1) = BVAL(3,XI,D)
   81 XI = XI + HX
C
   90 IF (EDGE(4) .NE. 0) GO TO 100
      YJ = C
      DO 91 J = 1,NP1
         U(MP1,J) = BVAL(4,B,YJ)
   91 YJ = YJ + HY
C
C     STORE THE MIXED BOUNDARY CONDITIONS
C
  100 IC = MN + 1
      IF (EDGE(1) .NE. 1) GO TO 120
      MN = MN + MP1
      IF (MN .GE. NW) GO TO 120
C
      XI = A
      L = IC
      DO 110 I = 1,MP1
         W(L) = BVAL(1,XI,C)
         XI = XI + HX
         L = L + 1
  110 CONTINUE
C
  120 IA = MN + 1
      IF (EDGE(2) .NE. 1) GO TO 140
      MN = MN + NP1
      IF (MN .GE. NW) GO TO 140
C
      YJ = C
      L = IA
      DO 130 J = 1,NP1
         W(L) = BVAL(2,A,YJ)
         YJ = YJ + HY
         L = L + 1
  130 CONTINUE
C
  140 ID = MN + 1
      IF (EDGE(3) .NE. 1) GO TO 160
      MN = MN + MP1
      IF (MN .GE. NW) GO TO 160
C
      XI = A
      L = ID
      DO 150 I = 1,MP1
         W(L) = BVAL(3,XI,D)
         XI = XI + HX
         L = L + 1
  150 CONTINUE
C
  160 IB = MN + 1
      IF (EDGE(4) .NE. 1) GO TO 200
      MN = MN + NP1
      IF (MN .GE. NW) GO TO 200
C
      YJ = C
      L = IB
      DO 170 J = 1,NP1
         W(L) = BVAL(4,B,YJ)
         YJ = YJ + HY
         L = L + 1
  170 CONTINUE
C
C     CALL THE DIFFERENTIAL EQUATION SOLVER
C
  200 IF (MN .GE. NW) GO TO 350
      IW = MN + 1
      W(IW) = NW - MN
      IF (IORD .EQ. 4) GO TO 210
C
      CALL SEPELL (0, IORD, A, B, M, INDX, W(IA), ALPHA, W(IB), BETA,
     *             C, D, N, INDY, W(IC), GAM, W(ID), DEL, COFX, COFY,
     *             U, KU, U, KU, W(IW), P, IERR)
      GO TO 220
C
  210 CALL SEPELL (0, IORD, A, B, M, INDX, W(IA), ALPHA, W(IB), BETA,
     *             C, D, N, INDY, W(IC), GAM, W(ID), DEL, COFX, COFY,
     *             W(1),MP1, U, KU, W(IW), P, IERR)
C
  220 NW = W(IW) + MN
      IF (IERR .NE. 0) RETURN
      IF (P .EQ. 0.0) RETURN
      IERR = -1
      W(1) = P
      RETURN
C
C     ERROR RETURN
C
  300 IERR = 1
      RETURN
C
  310 IERR = 5
      RETURN
C
  320 IERR = 6
      RETURN
C
  330 IERR = 7
      RETURN
C
  340 IERR = 8
      RETURN
C
  350 DUM(1) = 1.0
      CALL SEPELL (0, IORD, A, B, M, INDX, DUM, ALPHA, DUM, BETA,
     *             C, D, N, INDY, DUM, GAM, DUM, DEL, COFX, COFY,
     *             U, KU, U, KU, DUM, P, IERR)
      NW = DUM(1) + MN
      RETURN
      END
      SUBROUTINE PDEDGE (EDGE, INDX, INDY, IERR)
      INTEGER EDGE(4)
C
      IF (IABS(EDGE(1)) .GT. 1) GO TO 200
      IF (IABS(EDGE(2)) .GT. 1) GO TO 200
      IF (IABS(EDGE(3)) .GT. 1) GO TO 200
      IF (IABS(EDGE(4)) .GT. 1) GO TO 200
      IERR = 0
C
C               PROCESS EDGES 1 AND 3
C
      IF (EDGE(1)) 10,20,30
C
   10 IF (EDGE(3) .NE. -1) GO TO 210
      INDY = 0
      GO TO 100
C
   20 IF (EDGE(3) .EQ. -1) GO TO 210
      INDY = 1 + EDGE(3)
      GO TO 100
C
   30 IF (EDGE(3) .EQ. -1) GO TO 210
      INDY = 4 - EDGE(3)
C
C               PROCESS EDGES 2 AND 4
C
  100 IF (EDGE(2)) 110,120,130
C
  110 IF (EDGE(4) .NE. -1) GO TO 220
      INDX = 0
      RETURN
C
  120 IF (EDGE(4) .EQ. -1) GO TO 220
      INDX = 1 + EDGE(4)
      RETURN
C
  130 IF (EDGE(4) .EQ. -1) GO TO 220
      INDX = 4 - EDGE(4)
      RETURN
C
C                   ERROR RETURN
C
  200 IERR = 2
      RETURN
  210 IERR = 12
      RETURN
  220 IERR = 13
      RETURN
      END
      SUBROUTINE SEPELL (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,
     1                   D,N,NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,GRHS,MN,
     2                   USOL,IDMN,W,PERTRB,IERROR)
C
C
C DIMENSION OF           BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1),
C ARGUMENTS              USOL(IDMN,N+1), GRHS(MN,N+1),
C                        W (SEE ARGUMENT LIST)
C
C LATEST REVISION        JANUARY 1978 (BY THE AUTHORS)
C                        MODIFIED 1986 BY A.H. MORRIS (NSWC)
C
C PURPOSE                SEPELL SOLVES FOR EITHER THE SECOND-ORDER
C                        FINITE DIFFERENCE APPROXIMATION OR A
C                        FOURTH-ORDER APPROXIMATION TO A SEPARABLE
C                        ELLIPTIC EQUATION
C
C                                    2    2
C                             AF(X)*D U/DX + BF(X)*DU/DX  + CF(X)*U +
C                                    2    2
C                             DF(Y)*D U/DY  + EF(Y)*DU/DY + FF(Y)*U
C
C                             = G(X,Y)
C
C                        ON A RECTANGLE (X GREATER THAN OR EQUAL TO A
C                        AND LESS THAN OR EQUAL TO B, Y GREATER THAN
C                        OR EQUAL TO C AND LESS THAN OR EQUAL TO D).
C                        ANY COMBINATION OF PERIODIC OR MIXED BOUNDARY
C                        CONDITIONS IS ALLOWED.
C
C PURPOSE                THE POSSIBLE BOUNDARY CONDITIONS ARE ...
C                        IN THE X-DIRECTION..
C                         (0) PERIODIC, U(X+B-A,Y)=U(X,Y) FOR ALL Y,X
C                         (1) U(A,Y), U(B,Y) ARE SPECIFIED FOR ALL Y
C                         (2) U(A,Y), DU(B,Y)/DX+BETA*U(B,Y) ARE
C                             SPECIFIED FOR ALL Y
C                         (3) DU(A,Y)/DX+ALPHA*U(A,Y),DU(B,Y)/DX+
C                             BETA*U(B,Y) ARE SPECIFIED FOR ALL Y
C                         (4) DU(A,Y)/DX+ALPHA*U(A,Y),U(B,Y) ARE
C                             SPECIFIED FOR ALL Y
C
C                        IN THE Y-DIRECTION..
C                         (0) PERIODIC, U(X,Y+D-C)=U(X,Y) FOR ALL X,Y
C                         (1) U(X,C),U(X,D) ARE SPECIFIED FOR ALL X
C                         (2) U(X,C),DU(X,D)/DY+XNU*U(X,D) ARE SPECIFIED
C                             FOR ALL X
C                         (3) DU(X,C)/DY+GAMA*U(X,C),DU(X,D)/DY+
C                             XNU*U(X,D) ARE SPECIFIED FOR ALL X
C                         (4) DU(X,C)/DY+GAMA*U(X,C),U(X,D) ARE
C                             SPECIFIED FOR ALL X
C
C ARGUMENTS
C
C ON INPUT               INTL
C                          = 0 ON INITIAL ENTRY TO SEPELL OR IF ANY OF
C                              THE ARGUMENTS C, D, N, NBDCND, COFY ARE
C                              CHANGED FROM A PREVIOUS CALL
C                          = 1 IF C, D, N, NBDCND, COFY ARE UNCHANGED
C                              FROM THE PREVIOUS CALL.
C
C                        IORDER
C                          = 2 IF A SECOND-ORDER APPROXIMATION IS SOUGHT
C                          = 4 IF A FOURTH-ORDER APPROXIMATION IS SOUGHT
C
C                        A,B
C                          THE RANGE OF THE X-INDEPENDENT VARIABLE,
C                          I.E., X IS GREATER THAN OR EQUAL TO A AND
C                          LESS THAN OR EQUAL TO B. A MUST BE LESS THAN
C                          B.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE INTERVAL
C                          (A,B) IS SUBDIVIDED.  HENCE, THERE WILL BE
C                          M+1 GRID POINTS IN THE X-DIRECTION GIVEN BY
C                          XI=A+(I-1)*DLX FOR I=1,2,...,M+1 WHERE
C                          DLX=(B-A)/M IS THE PANEL WIDTH.  M MUST BE
C                          LESS THAN IDMN AND GREATER THAN 5.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION AT
C                          X=A AND X=B
C                          = 0 IF THE SOLUTION IS PERIODIC IN X, I.E.,
C                              U(X+B-A,Y)=U(X,Y) FOR ALL Y,X
C                          = 1 IF THE SOLUTION IS SPECIFIED AT X=A AND
C                              X=B, I.E., U(A,Y) AND U(B,Y) ARE
C                              SPECIFIED FOR ALL Y
C                          = 2 IF THE SOLUTION IS SPECIFIED AT X=A AND
C                              THE BOUNDARY CONDITION IS MIXED AT X=B,
C                              I.E., U(A,Y) AND DU(B,Y)/DX+BETA*U(B,Y)
C                              ARE SPECIFIED FOR ALL Y
C                          = 3 IF THE BOUNDARY CONDITIONS AT X=A AND X=B
C                              ARE MIXED, I.E., DU(A,Y)/DX+ALPHA*U(A,Y)
C                              AND DU(B,Y)/DX+BETA*U(B,Y) ARE SPECIFIED
C                              FOR ALL Y
C                          = 4 IF THE BOUNDARY CONDITION AT X=A IS MIXED
C                              AND THE SOLUTION IS SPECIFIED AT X=B,
C                              I.E., DU(A,Y)/DX+ALPHA*U(A,Y) AND U(B,Y)
C                              ARE SPECIFIED FOR ALL Y
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF DU(A,Y)/DX+
C                          ALPHA*U(A,Y) AT X=A. WHEN MBDCND=3 OR 4
C                               BDA(J) = DU(A,YJ)/DX+ALPHA*U(A,YJ),
C                               J=1,2,...,N+1.
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDA IS A
C                          DUMMY PARAMETER.
C
C ON INPUT               ALPHA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN CASE
C                          OF A MIXED BOUNDARY CONDITION AT X=A (SEE
C                          ARGUMENT BDA). IF MBDCND.NE.3,4 THEN ALPHA
C                          IS A DUMMY PARAMETER.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF DU(B,Y)/DX+
C                          BETA*U(B,Y) AT X=B.  WHEN MBDCND=2 OR 3
C                               BDB(J) = DU(B,YJ)/DX+BETA*U(B,YJ),
C                               J=1,2,...,N+1.
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDB IS A
C                          DUMMY PARAMETER.
C
C                        BETA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN CASE
C                          OF A MIXED BOUNDARY CONDITION AT X=B (SEE
C                          ARGUMENT BDB). IF MBDCND.NE.2,3 THEN BETA IS
C                          A DUMMY PARAMETER.
C
C                        C,D
C                          THE RANGE OF THE Y-INDEPENDENT VARIABLE,
C                          I.E., Y IS GREATER THAN OR EQUAL TO C AND
C                          LESS THAN OR EQUAL TO D.  C MUST BE LESS
C                          THAN D.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE INTERVAL
C                          (C,D) IS SUBDIVIDED.  HENCE, THERE WILL BE
C                          N+1 GRID POINTS IN THE Y-DIRECTION GIVEN BY
C                          YJ=C+(J-1)*DLY FOR J=1,2,...,N+1 WHERE
C                          DLY=(D-C)/N IS THE PANEL WIDTH. IN ADDITION,
C                          N MUST BE GREATER THAN 4.
C
C                        NBDCND
C                          INDICATES THE TYPES OF BOUNDARY CONDITIONS
C                          AT Y=C AND Y=D
C                          = 0 IF THE SOLUTION IS PERIODIC IN Y, I.E.,
C                              U(X,Y+D-C)=U(X,Y) FOR ALL X,Y
C                          = 1 IF THE SOLUTION IS SPECIFIED AT Y=C AND
C                              Y = D, I.E., U(X,C) AND U(X,D) ARE
C                              SPECIFIED FOR ALL X
C                          = 2 IF THE SOLUTION IS SPECIFIED AT Y=C AND
C                              THE BOUNDARY CONDITION IS MIXED AT Y=D,
C                              I.E., U(X,C) AND DU(X,D)/DY+XNU*U(X,D)
C                              ARE SPECIFIED FOR ALL X
C                          = 3 IF THE BOUNDARY CONDITIONS ARE MIXED AT
C                              Y=C AND Y=D, I.E., DU(X,D)/DY+GAMA*U(X,C)
C                              AND DU(X,D)/DY+XNU*U(X,D) ARE SPECIFIED
C                              FOR ALL X
C                          = 4 IF THE BOUNDARY CONDITION IS MIXED AT Y=C
C                              AND THE SOLUTION IS SPECIFIED AT Y=D,
C                              I.E. DU(X,C)/DY+GAMA*U(X,C) AND U(X,D)
C                              ARE SPECIFIED FOR ALL X
C
C                        BDC
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUE OF DU(X,C)/DY+GAMA*U(X,C)
C                          AT Y=C.  WHEN NBDCND=3 OR 4
C                             BDC(I) = DU(XI,C)/DY + GAMA*U(XI,C),
C                             I=1,2,...,M+1.
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDC IS A
C                          DUMMY PARAMETER.
C
C                        GAMA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN CASE
C                          OF A MIXED BOUNDARY CONDITION AT Y=C (SEE
C                          ARGUMENT BDC). IF NBDCND.NE.3,4 THEN GAMA IS
C                          A DUMMY PARAMETER.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUE OF DU(X,D)/DY +
C                          XNU*U(X,D) AT Y=C.  WHEN NBDCND=2 OR 3
C                            BDD(I) = DU(XI,D)/DY + XNU*U(XI,D),
C                            I=1,2,...,M+1.
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDD IS A
C                          DUMMY PARAMETER.
C
C                        XNU
C                          THE SCALAR MULTIPLYING THE SOLUTION IN CASE
C                          OF A MIXED BOUNDARY CONDITION AT Y=D (SEE
C                          ARGUMENT BDD). IF NBDCND.NE.2 OR 3 THEN XNU
C                          IS A DUMMY PARAMETER.
C
C                        COFX
C                          A USER-SUPPLIED SUBPROGRAM WITH
C                          PARAMETERS X, AFUN, BFUN, CFUN WHICH
C                          RETURNS THE VALUES OF THE X-DEPENDENT
C                          COEFFICIENTS AF(X), BF(X), CF(X) IN
C                          THE ELLIPTIC EQUATION AT X.
C
C                        COFY
C                          A USER-SUPPLIED SUBPROGRAM WITH
C                          PARAMETERS Y, DFUN, EFUN, FFUN WHICH
C                          RETURNS THE VALUES OF THE Y-DEPENDENT
C                          COEFFICIENTS DF(Y), EF(Y), FF(Y) IN
C                          THE ELLIPTIC EQUATION AT Y.
C
C                        NOTE.  COFX AND COFY MUST BE DECLARED EXTERNAL
C                        IN THE CALLING ROUTINE. THE VALUES RETURNED IN
C                        AFUN AND DFUN MUST SATISFY AFUN*DFUN GREATER
C                        THAN 0 FOR A LESS THAN X LESS THAN B,
C                        C LESS THAN Y LESS THAN D (SEE IERROR=10).
C                        THE COEFFICIENTS PROVIDED MAY LEAD TO A MATRIX
C                        EQUATION WHICH IS NOT DIAGONALLY DOMINANT IN
C                        WHICH CASE SOLUTION MAY FAIL (SEE IERROR=4).
C
C                        GRHS
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE RIGHT-HAND SIDE OF THE ELLIPTIC
C                          EQUATION, I.E., GRHS(I,J)=G(XI,YI), FOR
C                          I=2,...,M, J=2,...,N.  AT THE BOUNDARIES,
C                          GRHS IS DEFINED BY
C
C                          MBDCND   GRHS(1,J)   GRHS(M+1,J)
C                          ------   ---------   -----------
C                            0      G(A,YJ)     G(B,YJ)
C                            1         *           *
C                            2         *        G(B,YJ)  J=1,2,...,N+1
C                            3      G(A,YJ)     G(B,YJ)
C                            4      G(A,YJ)        *
C
C                          NBDCND   GRHS(I,1)   GRHS(I,N+1)
C                          ------   ---------   -----------
C                            0      G(XI,C)     G(XI,D)
C                            1         *           *
C                            2         *        G(XI,D)  I=1,2,...,M+1
C                            3      G(XI,C)     G(XI,D)
C                            4      G(XI,C)        *
C
C                          WHERE * MEANS THESE QUANTITES ARE NOT USED.
C                          GRHS SHOULD BE DIMENSIONED MN BY AT LEAST
C                          N+1 IN THE CALLING ROUTINE.
C
C                        MN
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          GRHS AS IT APPEARS IN THE PROGRAM CALLING
C                          SEPELL. MN MUST BE AT LEAST 7 AND GREATER
C                          THAN OR EQUAL TO M+1.
C
C                        USOL
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE SOLUTION ALONG THE BOUNDARIES.
C                          AT THE BOUNDARIES, USOL IS DEFINED BY
C
C                          MBDCND   USOL(1,J)   USOL(M+1,J)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(A,YJ)     U(B,YJ)
C                            2      U(A,YJ)        *     J=1,2,...,N+1
C                            3         *           *
C                            4         *        U(B,YJ)
C
C                          NBDCND   USOL(I,1)   USOL(I,N+1)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(XI,C)     U(XI,D)
C                            2      U(XI,C)        *     I=1,2,...,M+1
C                            3         *           *
C                            4         *        U(XI,D)
C
C                          WHERE * MEANS THE QUANTITES ARE NOT USED IN
C                          THE SOLUTION.
C
C                          IF IORDER=2 AND IDMN=MN, THEN THE USER MAY
C                          EQUIVALENCE GRHS AND USOL. NOTE THAT IN THIS
C                          CASE THE TABLES SPECIFYING THE BOUNDARIES OF
C                          THE GRHS AND USOL ARRAYS DETERMINE THE
C                          BOUNDARIES UNIQUELY EXCEPT AT THE CORNERS.
C                          IF THE TABLES CALL FOR BOTH G(X,Y) AND
C                          U(X,Y) AT A CORNER THEN THE SOLUTION MUST BE
C                          CHOSEN.  FOR EXAMPLE, IF MBDCND=2 AND
C                          NBDCND=4, THEN U(A,C), U(A,D), U(B,D) MUST BE
C                          CHOSEN AT THE CORNERS IN ADDITION TO G(B,C).
C
C                          IF IORDER=4, THEN THE TWO ARRAYS, USOL AND
C                          GRHS, MUST BE DISTINCT.
C
C                          USOL SHOULD BE DIMENSIONED IDMN BY AT LEAST
C                          N+1 IN THE CALLING ROUTINE.
C
C                        IDMN
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          USOL AS IT APPEARS IN THE PROGRAM CALLING
C                          SEPELL. IDMN MUST BE AT LEAST 7 AND GREATER
C                          THAN OR EQUAL TO M+1.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED
C                          BY THE USER FOR WORK SPACE.  LET
C                          K=INT(LOG2(N+1))+1 AND SET  L=2**(K+1).
C                          THEN (K-2)*L+K+10*N+12*M+27 WILL SUFFICE
C                          AS A LENGTH OF W.  THE ACTUAL LENGTH OF W IN
C                          THE CALLING ROUTINE MUST BE SET IN W(1) (SEE
C                          IERROR=11).
C
C ON OUTPUT              USOL
C                          CONTAINS THE APPROXIMATE SOLUTION TO THE
C                          ELLIPTIC EQUATION.  USOL(I,J) IS THE
C                          APPROXIMATION TO U(XI,YJ) FOR I=1,2...,M+1
C                          AND J=1,2,...,N+1.  THE APPROXIMATION HAS
C                          ERROR O(DLX**2+DLY**2) IF CALLED WITH
C                          IORDER=2 AND O(DLX**4+DLY**4) IF CALLED WITH
C                          IORDER=4.
C
C                        W
C                          CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE
C                          DESTROYED IF SEPELL IS CALLED AGAIN WITH
C                          INTL=1.  IN ADDITION W(1) CONTAINS THE EXACT
C                          MINIMAL LENGTH (IN FLOATING POINT) REQUIRED
C                          FOR THE WORK SPACE (SEE IERROR=11).
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC OR DERIVATIVE
C                          BOUNDARY CONDITIONS (I.E., ALPHA=BETA=0 IF
C                          MBDCND=3, GAMA=XNU=0 IF NBDCND=3) IS
C                          SPECIFIED AND IF THE COEFFICIENTS OF U(X,Y)
C                          IN THE SEPARABLE ELLIPTIC EQUATION ARE ZERO
C                          (I.E., CF(X)=0 FOR X GREATER THAN OR EQUAL TO
C                          A AND LESS THAN OR EQUAL TO B, FF(Y)=0 FOR
C                          Y GREATER THAN OR EQUAL TO C AND LESS THAN
C                          OR EQUAL TO D) THEN A SOLUTION MAY NOT EXIST.
C                          PERTRB IS A CONSTANT CALCULATED AND
C                          SUBTRACTED FROM THE RIGHT-HAND SIDE OF THE
C                          MATRIX EQUATIONS GENERATED BY SEPELL WHICH
C                          INSURES THAT A SOLUTION EXISTS.  SEPELL THEN
C                          COMPUTES THIS SOLUTION WHICH IS A WEIGHTED
C                          MINIMAL LEAST SQUARES SOLUTION TO THE
C                          ORIGINAL PROBLEM.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS OR FAILURE TO FIND A SOLUTION
C                          = 0 NO ERROR
C                          = 1 IF A GREATER THAN B OR C GREATER THAN D
C                          = 2 IF MBDCND LESS THAN 0 OR MBDCND GREATER
C                              THAN 4
C                          = 3 IF NBDCND LESS THAN 0 OR NBDCND GREATER
C                              THAN 4
C                          = 4 IF ATTEMPT TO FIND A SOLUTION FAILS.
C                              (THE LINEAR SYSTEM GENERATED IS NOT
C                              DIAGONALLY DOMINANT.)
C                          = 5 IF IDMN OR MN IS TOO SMALL.
C                          = 6 IF M IS TOO SMALL OR TOO LARGE (SEE
C                              DISCUSSION OF M)
C                          = 7 IF N IS TOO SMALL (SEE DISCUSSION OF N)
C                          = 8 IF IORDER IS NOT 2 OR 4
C                          = 9 IF INTL IS NOT 0 OR 1
C                          = 10 IF AFUN*DFUN LESS THAN OR EQUAL TO 0 FOR
C                               SOME INTERIOR MESH POINT (XI,YJ)
C                          = 11 IF THE WORK SPACE LENGTH INPUT IN W(1)
C                               IS LESS THAN THE EXACT MINIMAL WORK
C                               SPACE LENGTH REQUIRED OUTPUT IN W(1).
C
C                          NOTE (CONCERNING IERROR=4).  FOR THE
C                          COEFFICIENTS INPUT THROUGH COFX, COFY, THE
C                          DISCRETIZATION MAY LEAD TO A BLOCK
C                          TRIDIAGONAL LINEAR SYSTEM WHICH IS NOT
C                          DIAGONALLY DOMINANT (FOR EXAMPLE, THIS
C                          HAPPENS IF CFUN=0 AND BFUN/(2.*DLX) GREATER
C                          THAN AFUN/DLX**2).  IN THIS CASE SOLUTION MAY
C                          FAIL.  THIS CANNOT HAPPEN IN THE LIMIT AS
C                          DLX, DLY APPROACH ZERO.  HENCE, THE CONDITION
C                          MAY BE REMEDIED BY TAKING LARGER VALUES FOR M
C                          OR N.
C
C ENTRY POINTS           SEPELL, SEPEL1, CHKPRM, CHKSNG, ORTHG, MINSOL,
C                        TRISP, DEFER, DXFN, DYFN, BLKTRI, BLKTR1,INDXB,
C                        INDXA, INDXC, PROD0, PRODP, CPROD0, CPRODP,
C                        PPADD, PSGF, BSRH, PPSGF, PPSPF, COMPB,
C                        TQLRT0, SPMPAR
C
C SPECIAL CONDITIONS     NONE
C
C COMMON BLOCKS          SPLP, CBLKT
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C SPECIALIST             JOHN C. ADAMS, NCAR, BOULDER, COLORADO  80307
C
C HISTORY                DEVELOPED AT NCAR DURING 1975-76.
C
C ALGORITHM              SEPELL AUTOMATICALLY DISCRETIZES THE SEPARABLE
C                        ELLIPTIC EQUATION WHICH IS THEN SOLVED BY A
C                        GENERALIZED CYCLIC REDUCTION ALGORITHM IN THE
C                        SUBROUTINE, BLKTRI.  THE FOURTH-ORDER SOLUTION
C                        IS OBTAINED USING DEFERRED CORRECTIONS, WHICH
C                        IS DESCRIBED AND REFERENCED IN SECTIONS,
C                        REFERENCES AND METHOD.
C
C ACCURACY AND TIMING    THE FOLLOWING COMPUTATIONAL RESULTS WERE
C                        OBTAINED BY SOLVING THE SAMPLE PROBLEM AT THE
C                        END OF THIS WRITE-UP ON THE CONTROL DATA 7600.
C                        THE OP COUNT IS PROPORTIONAL TO M*N*LOG2(N).
C                        IN CONTRAST TO THE OTHER ROUTINES IN THIS
C                        CHAPTER, ACCURACY IS TESTED BY COMPUTING AND
C                        TABULATING SECOND- AND FOURTH-ORDER
C                        DISCRETIZATION ERRORS.  BELOW IS A TABLE
C                        CONTAINING COMPUTATIONAL RESULTS.  THE TIMES
C                        GIVEN DO NOT INCLUDE INITIALIZATION (I.E.,
C                        TIMES ARE FOR INTL=1).  NOTE THAT THE
C                        FOURTH-ORDER ACCURACY IS NOT REALIZED UNTIL THE
C                        MESH IS SUFFICIENTLY REFINED.
C
C              SECOND-ORDER    FOURTH-ORDER   SECOND-ORDER  FOURTH-ORDER
C    M    N   EXECUTION TIME  EXECUTION TIME    ERROR         ERROR
C               (M SEC)         (M SEC)
C     6    6         6              14          6.8E-1        1.2E0
C    14   14        23              58          1.4E-1        1.8E-1
C    30   30       100             247          3.2E-2        9.7E-3
C    62   62       445           1,091          7.5E-3        3.0E-4
C   126  126     2,002           4,772          1.8E-3        3.5E-6
C
C PORTABILITY            THE VALUE GIVEN BY SPMPAR(1) IS THE ONLY
C                        MACHINE DEPENDENT CONSTANT THAT IS USED.
C
C REFERENCES             KELLER, H.B., NUMERICAL METHODS FOR TWO-POINT
C                          BOUNDARY-VALUE PROBLEMS, BLAISDEL (1968),
C                          WALTHAM, MASS.
C
C                        SWARZTRAUBER, P., AND R. SWEET (1975),
C                          EFFICIENT FORTRAN SUBPROGRAMS FOR THE
C                          SOLUTION OF ELLIPTIC PARTIAL DIFFERENTIAL
C                          EQUATIONS.  NCAR TECHNICAL NOTE
C                          NCAR-TN/IA-109, PP. 135-137.
C
C
C
      REAL GRHS(MN,*), USOL(IDMN,*)
      REAL BDA(*), BDB(*), BDC(*), BDD(*), W(*)
      EXTERNAL COFX, COFY
C
C
C     CHECK INPUT PARAMETERS
C
      CALL CHKPRM (INTL,IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,COFY,
     1             IDMN,MN,IERROR)
      IF (IERROR .NE. 0) RETURN
C
C     COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT
C
      L = N+1
      IF (NBDCND .EQ. 0) L = N
      LOGB2N = INT(ALOG(FLOAT(L)+0.5)/ALOG(2.0))+1
      LL = 2**(LOGB2N+1)
      K = M+1
      L = N+1
      LENGTH = (LOGB2N-2)*LL+LOGB2N+MAX0(2*L,6*K)+5
      IF (NBDCND .EQ. 0) LENGTH = LENGTH+2*L
      IERROR = 11
      LINPUT = INT(W(1)+0.5)
      LOUTPT = LENGTH+6*(K+L)+1
      W(1) = FLOAT(LOUTPT)
      IF (LOUTPT .GT. LINPUT) RETURN
      IERROR = 0
C
C     SET WORK SPACE INDICES
C
      I1 = LENGTH+2
      I2 = I1+L
      I3 = I2+L
      I4 = I3+L
      I5 = I4+L
      I6 = I5+L
      I7 = I6+L
      I8 = I7+K
      I9 = I8+K
      I10 = I9+K
      I11 = I10+K
      I12 = I11+K
      I13 = 2
      CALL SEPEL1 (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1             NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,W(I1),W(I2),W(I3),
     2             W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11),
     3             W(I12),GRHS,MN,USOL,IDMN,W(I13),PERTRB,IERROR)
      RETURN
      END
      SUBROUTINE SEPEL1 (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,
     1                   D,N,NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,AN,BN,
     2                   CN,DN,UN,ZN,AM,BM,CM,DM,UM,ZM,GRHS,MN,USOL,
     3                   IDMN,W,PERTRB,IERROR)
C
C     SEPEL1 SETS UP VECTORS AND ARRAYS FOR INPUT TO BLKTRI
C     AND COMPUTES A SECOND ORDER SOLUTION IN USOL.  A RETURN JUMP TO
C     SEPELL OCCURRS IF IORDER=2.  IF IORDER=4 A FOURTH ORDER
C     SOLUTION IS GENERATED IN USOL.
C
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
      DIMENSION       GRHS(MN,*)             ,USOL(IDMN,*)
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,DN(*)      ,
     1                UN(*)      ,ZN(*)
      DIMENSION       AM(*)      ,BM(*)      ,CM(*)      ,DM(*)      ,
     1                UM(*)      ,ZM(*)
      LOGICAL         SINGLR
      EXTERNAL        COFX, COFY
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
C
C
C     SET PARAMETERS INTERNALLY
C
      KSWX = MBDCND+1
      KSWY = NBDCND+1
      K = M+1
      L = N+1
      AIT = A
      BIT = B
      CIT = C
      DIT = D
C
C     SET RIGHT HAND SIDE VALUES FROM GRHS IN USOL ON THE INTERIOR
C     AND NON-SPECIFIED BOUNDARIES.
C
      DO  20 I=2,M
         DO  10 J=2,N
            USOL(I,J) = GRHS(I,J)
   10    CONTINUE
   20 CONTINUE
      IF (KSWX.EQ.2 .OR. KSWX.EQ.3) GO TO  40
      DO  30 J=2,N
         USOL(1,J) = GRHS(1,J)
   30 CONTINUE
   40 CONTINUE
      IF (KSWX.EQ.2 .OR. KSWX.EQ.5) GO TO  60
      DO  50 J=2,N
         USOL(K,J) = GRHS(K,J)
   50 CONTINUE
   60 CONTINUE
      IF (KSWY.EQ.2 .OR. KSWY.EQ.3) GO TO  80
      DO  70 I=2,M
         USOL(I,1) = GRHS(I,1)
   70 CONTINUE
   80 CONTINUE
      IF (KSWY.EQ.2 .OR. KSWY.EQ.5) GO TO 100
      DO  90 I=2,M
         USOL(I,L) = GRHS(I,L)
   90 CONTINUE
  100 CONTINUE
      IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.3)
     1    USOL(1,1) = GRHS(1,1)
      IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.3)
     1    USOL(K,1) = GRHS(K,1)
      IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.5)
     1    USOL(1,L) = GRHS(1,L)
      IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.5)
     1    USOL(K,L) = GRHS(K,L)
      I1 = 1
C
C     SET SWITCHES FOR PERIODIC OR NON-PERIODIC BOUNDARIES
C
      MP = 1
      NP = 1
      IF (KSWX .EQ. 1) MP = 0
      IF (KSWY .EQ. 1) NP = 0
C
C     SET DLX,DLY AND SIZE OF BLOCK TRI-DIAGONAL SYSTEM GENERATED
C     IN NINT,MINT
C
      DLX = (BIT-AIT)/FLOAT(M)
      MIT = K-1
      IF (KSWX .EQ. 2) MIT = K-2
      IF (KSWX .EQ. 4) MIT = K
      DLY = (DIT-CIT)/FLOAT(N)
      NIT = L-1
      IF (KSWY .EQ. 2) NIT = L-2
      IF (KSWY .EQ. 4) NIT = L
      TDLX3 = 2.0*DLX**3
      DLX4 = DLX**4
      TDLY3 = 2.0*DLY**3
      DLY4 = DLY**4
C
C     SET SUBSCRIPT LIMITS FOR PORTION OF ARRAY TO INPUT TO BLKTRI
C
      IS = 1
      JS = 1
      IF (KSWX.EQ.2 .OR. KSWX.EQ.3) IS = 2
      IF (KSWY.EQ.2 .OR. KSWY.EQ.3) JS = 2
      NS = NIT+JS-1
      MS = MIT+IS-1
C
C     SET X - DIRECTION
C
      DO 110 I=1,MIT
         XI = AIT+FLOAT(IS+I-2)*DLX
         CALL COFX (XI,AI,BI,CI)
         AXI = (AI/DLX-0.5*BI)/DLX
         BXI = -2.*AI/DLX**2+CI
         CXI = (AI/DLX+0.5*BI)/DLX
         AM(I) = AXI
         BM(I) = BXI
         CM(I) = CXI
  110 CONTINUE
C
C     SET Y DIRECTION
C
      DO 120 J=1,NIT
         YJ = CIT+FLOAT(JS+J-2)*DLY
         CALL COFY (YJ,DJ,EJ,FJ)
         DYJ = (DJ/DLY-0.5*EJ)/DLY
         EYJ = (-2.*DJ/DLY**2+FJ)
         FYJ = (DJ/DLY+0.5*EJ)/DLY
         AN(J) = DYJ
         BN(J) = EYJ
         CN(J) = FYJ
  120 CONTINUE
C
C     ADJUST EDGES IN X DIRECTION UNLESS PERIODIC
C
      AX1 = AM(1)
      CXM = CM(MIT)
      GO TO (170,130,150,160,140),KSWX
C
C     DIRICHLET-DIRICHLET IN X DIRECTION
C
  130 AM(1) = 0.0
      CM(MIT) = 0.0
      GO TO 170
C
C     MIXED-DIRICHLET IN X DIRECTION
C
  140 AM(1) = 0.0
      BM(1) = BM(1)+2.*ALPHA*DLX*AX1
      CM(1) = CM(1)+AX1
      CM(MIT) = 0.0
      GO TO 170
C
C     DIRICHLET-MIXED IN X DIRECTION
C
  150 AM(1) = 0.0
      AM(MIT) = AM(MIT)+CXM
      BM(MIT) = BM(MIT)-2.*BETA*DLX*CXM
      CM(MIT) = 0.0
      GO TO 170
C
C     MIXED - MIXED IN X DIRECTION
C
  160 CONTINUE
      AM(1) = 0.0
      BM(1) = BM(1)+2.*DLX*ALPHA*AX1
      CM(1) = CM(1)+AX1
      AM(MIT) = AM(MIT)+CXM
      BM(MIT) = BM(MIT)-2.*DLX*BETA*CXM
      CM(MIT) = 0.0
  170 CONTINUE
C
C     ADJUST IN Y DIRECTION UNLESS PERIODIC
C
      DY1 = AN(1)
      FYN = CN(NIT)
      GO TO (220,180,200,210,190),KSWY
C
C     DIRICHLET-DIRICHLET IN Y DIRECTION
C
  180 CONTINUE
      AN(1) = 0.0
      CN(NIT) = 0.0
      GO TO 220
C
C     MIXED-DIRICHLET IN Y DIRECTION
C
  190 CONTINUE
      AN(1) = 0.0
      BN(1) = BN(1)+2.*DLY*GAMA*DY1
      CN(1) = CN(1)+DY1
      CN(NIT) = 0.0
      GO TO 220
C
C     DIRICHLET-MIXED IN Y DIRECTION
C
  200 AN(1) = 0.0
      AN(NIT) = AN(NIT)+FYN
      BN(NIT) = BN(NIT)-2.*DLY*XNU*FYN
      CN(NIT) = 0.0
      GO TO 220
C
C     MIXED - MIXED DIRECTION IN Y DIRECTION
C
  210 CONTINUE
      AN(1) = 0.0
      BN(1) = BN(1)+2.*DLY*GAMA*DY1
      CN(1) = CN(1)+DY1
      AN(NIT) = AN(NIT)+FYN
      BN(NIT) = BN(NIT)-2.0*DLY*XNU*FYN
      CN(NIT) = 0.0
  220 IF (KSWX .EQ. 1) GO TO 270
C
C     ADJUST USOL ALONG X EDGE
C
      DO 260 J=JS,NS
         IF (KSWX.NE.2 .AND. KSWX.NE.3) GO TO 230
         USOL(IS,J) = USOL(IS,J)-AX1*USOL(1,J)
         GO TO 240
  230    USOL(IS,J) = USOL(IS,J)+2.0*DLX*AX1*BDA(J)
  240    IF (KSWX.NE.2 .AND. KSWX.NE.5) GO TO 250
         USOL(MS,J) = USOL(MS,J)-CXM*USOL(K,J)
         GO TO 260
  250    USOL(MS,J) = USOL(MS,J)-2.0*DLX*CXM*BDB(J)
  260 CONTINUE
  270 IF (KSWY .EQ. 1) GO TO 320
C
C     ADJUST USOL ALONG Y EDGE
C
      DO 310 I=IS,MS
         IF (KSWY.NE.2 .AND. KSWY.NE.3) GO TO 280
         USOL(I,JS) = USOL(I,JS)-DY1*USOL(I,1)
         GO TO 290
  280    USOL(I,JS) = USOL(I,JS)+2.0*DLY*DY1*BDC(I)
  290    IF (KSWY.NE.2 .AND. KSWY.NE.5) GO TO 300
         USOL(I,NS) = USOL(I,NS)-FYN*USOL(I,L)
         GO TO 310
  300    USOL(I,NS) = USOL(I,NS)-2.0*DLY*FYN*BDD(I)
  310 CONTINUE
  320 CONTINUE
C
C     SAVE ADJUSTED EDGES IN GRHS IF IORDER=4
C
      IF (IORDER .NE. 4) GO TO 350
      DO 330 J=JS,NS
         GRHS(IS,J) = USOL(IS,J)
         GRHS(MS,J) = USOL(MS,J)
  330 CONTINUE
      DO 340 I=IS,MS
         GRHS(I,JS) = USOL(I,JS)
         GRHS(I,NS) = USOL(I,NS)
  340 CONTINUE
  350 CONTINUE
      IORD = IORDER
      PERTRB = 0.0
C
C     CHECK IF OPERATOR IS SINGULAR
C
      CALL CHKSNG (MBDCND,NBDCND,ALPHA,BETA,GAMA,XNU,COFX,COFY,SINGLR)
C
C     COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE
C     IF SINGULAR
C
      IF (SINGLR) CALL TRISP (MIT,AM,BM,CM,DM,UM,ZM)
      IF (SINGLR) CALL TRISP (NIT,AN,BN,CN,DN,UN,ZN)
C
C     MAKE INITIALIZATION CALL TO BLKTRI
C
      IF (INTL .EQ. 0)
     1    CALL BLKTRI (INTL,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN,
     2                 USOL(IS,JS),IERROR,W)
      IF (IERROR .NE. 0) RETURN
C
C     ADJUST RIGHT HAND SIDE IF NECESSARY
C
  360 CONTINUE
      IF (SINGLR) CALL ORTHG (USOL,IDMN,ZN,ZM,PERTRB)
C
C     COMPUTE SOLUTION
C
      CALL BLKTRI (I1,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN,USOL(IS,JS),
     1             IERROR,W)
      IF (IERROR .NE. 0) RETURN
C
C     SET PERIODIC BOUNDARIES IF NECESSARY
C
      IF (KSWX .NE. 1) GO TO 380
      DO 370 J=1,L
         USOL(K,J) = USOL(1,J)
  370 CONTINUE
  380 IF (KSWY .NE. 1) GO TO 400
      DO 390 I=1,K
         USOL(I,L) = USOL(I,1)
  390 CONTINUE
  400 CONTINUE
C
C     MINIMIZE SOLUTION WITH RESPECT TO WEIGHTED LEAST SQUARES
C     NORM IF OPERATOR IS SINGULAR
C
      IF (SINGLR) CALL MINSOL (USOL,IDMN,ZN,ZM,PRTRB)
C
C     RETURN IF DEFERRED CORRECTIONS AND A FOURTH ORDER SOLUTION ARE
C     NOT FLAGGED
C
      IF (IORD .EQ. 2) RETURN
      IORD = 2
C
C     COMPUTE NEW RIGHT HAND SIDE FOR FOURTH ORDER SOLUTION
C
      CALL DEFER (COFX,COFY,USOL,IDMN,GRHS,MN)
      GO TO 360
      END
      SUBROUTINE CHKPRM (INTL,IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,
     1                   COFY,IDMN,MN,IERROR)
C
C     THIS PROGRAM CHECKS THE INPUT PARAMETERS FOR ERRORS
C
C
C     CHECK DEFINITION OF SOLUTION REGION
C
      IERROR = 1
      IF (A.GE.B .OR. C.GE.D) RETURN
C
C     CHECK BOUNDARY SWITCHES
C
      IERROR = 2
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) RETURN
      IERROR = 3
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) RETURN
C
C     CHECK FIRST DIMENSION IN CALLING ROUTINE
C
      IERROR = 5
      IF (MN .LT. 7 .OR. IDMN .LT. 7) RETURN
C
C     CHECK M
C
      IERROR = 6
      IF (M .GT. (IDMN-1) .OR. M.LT.6) RETURN
      IF (M .GT. MN - 1) RETURN
C
C     CHECK N
C
      IERROR = 7
      IF (N .LT. 5) RETURN
C
C     CHECK IORDER
C
      IERROR = 8
      IF (IORDER.NE.2 .AND. IORDER.NE.4) RETURN
C
C     CHECK INTL
C
      IERROR = 9
      IF (INTL.NE.0 .AND. INTL.NE.1) RETURN
C
C     CHECK THAT EQUATION IS ELLIPTIC
C
      DLX = (B-A)/FLOAT(M)
      DLY = (D-C)/FLOAT(N)
      DO  30 I=2,M
         XI = A+FLOAT(I-1)*DLX
         CALL COFX (XI,AI,BI,CI)
         DO  20 J=2,N
            YJ = C+FLOAT(J-1)*DLY
            CALL COFY (YJ,DJ,EJ,FJ)
            IF (AI*DJ .GT. 0.0) GO TO  10
            IERROR = 10
            RETURN
   10       CONTINUE
   20    CONTINUE
   30 CONTINUE
C
C     NO ERROR FOUND
C
      IERROR = 0
      RETURN
      END
      SUBROUTINE CHKSNG (MBDCND,NBDCND,ALPHA,BETA,GAMA,XNU,COFX,COFY,
     1                   SINGLR)
C
C     THIS SUBROUTINE CHECKS IF THE PDE   SEPELL
C     MUST SOLVE IS A SINGULAR OPERATOR
C
      LOGICAL         SINGLR
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
C
C
      SINGLR = .FALSE.
C
C     CHECK IF THE BOUNDARY CONDITIONS ARE
C     ENTIRELY PERIODIC AND/OR MIXED
C
      IF ((MBDCND.NE.0 .AND. MBDCND.NE.3) .OR.
     1    (NBDCND.NE.0 .AND. NBDCND.NE.3)) RETURN
C
C     CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN
C
      IF (MBDCND .NE. 3) GO TO  10
      IF (ALPHA.NE.0.0 .OR. BETA.NE.0.0) RETURN
   10 IF (NBDCND .NE. 3) GO TO  20
      IF (GAMA.NE.0.0 .OR. XNU.NE.0.0) RETURN
   20 CONTINUE
C
C     CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS
C     ARE ZERO
C
      DO  30 I=IS,MS
         XI = AIT+FLOAT(I-1)*DLX
         CALL COFX (XI,AI,BI,CI)
         IF (CI .NE. 0.0) RETURN
   30 CONTINUE
      DO  40 J=JS,NS
         YJ = CIT+FLOAT(J-1)*DLY
         CALL COFY (YJ,DJ,EJ,FJ)
         IF (FJ .NE. 0.0) RETURN
   40 CONTINUE
C
C     THE OPERATOR MUST BE SINGULAR IF THIS POINT IS REACHED
C
      SINGLR = .TRUE.
      RETURN
      END
      SUBROUTINE ORTHG (USOL,IDMN,ZN,ZM,PERTRB)
C
C     THIS SUBROUTINE ORTHOGONALIZES THE ARRAY USOL WITH RESPECT TO
C     THE CONSTANT ARRAY IN A WEIGHTED LEAST SQUARES NORM
C
      DIMENSION       USOL(IDMN,*)           ,ZN(*)      ,ZM(*)
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
C
      ISTR = IS
      IFNL = MS
      JSTR = JS
      JFNL = NS
C
C     COMPUTE WEIGHTED INNER PRODUCTS
C
      UTE = 0.0
      ETE = 0.0
      DO  20 I=IS,MS
         II = I-IS+1
         DO  10 J=JS,NS
            JJ = J-JS+1
            ETE = ETE+ZM(II)*ZN(JJ)
            UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ)
   10    CONTINUE
   20 CONTINUE
C
C     SET PERTURBATION PARAMETER
C
      PERTRB = UTE/ETE
C
C     SUBTRACT OFF CONSTANT PERTRB
C
      DO  40 I=ISTR,IFNL
         DO  30 J=JSTR,JFNL
            USOL(I,J) = USOL(I,J)-PERTRB
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE MINSOL (USOL,IDMN,ZN,ZM,PERTB)
C
C     THIS SUBROUTINE ORTHOGONALIZES THE ARRAY USOL WITH RESPECT TO
C     THE CONSTANT ARRAY IN A WEIGHTED LEAST SQUARES NORM
C
      DIMENSION       USOL(IDMN,*)           ,ZN(*)      ,ZM(*)
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
C
C     ENTRY AT MINSOL OCCURRS WHEN THE FINAL SOLUTION IS
C     TO BE MINIMIZED WITH RESPECT TO THE WEIGHTED
C     LEAST SQUARES NORM
C
      ISTR = 1
      IFNL = K
      JSTR = 1
      JFNL = L
C
C     COMPUTE WEIGHTED INNER PRODUCTS
C
      UTE = 0.0
      ETE = 0.0
      DO  20 I=IS,MS
         II = I-IS+1
         DO  10 J=JS,NS
            JJ = J-JS+1
            ETE = ETE+ZM(II)*ZN(JJ)
            UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ)
   10    CONTINUE
   20 CONTINUE
C
C     SET PERTURBATION PARAMETER
C
      PERTRB = UTE/ETE
C
C     SUBTRACT OFF CONSTANT PERTRB
C
      DO  40 I=ISTR,IFNL
         DO  30 J=JSTR,JFNL
            USOL(I,J) = USOL(I,J)-PERTRB
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE TRISP (N,A,B,C,D,U,Z)
C
C     THIS SUBROUTINE SOLVES FOR A NON-ZERO EIGENVECTOR CORRESPONDING
C     TO THE ZERO EIGENVALUE OF THE TRANSPOSE OF THE RANK
C     DEFICIENT ONE MATRIX WITH SUBDIAGONAL A, DIAGONAL B, AND
C     SUPERDIAGONAL C , WITH A(1) IN THE (1,N) POSITION, WITH
C     C(N) IN THE (N,1) POSITION, AND ALL OTHER ELEMENTS ZERO.
C
      DIMENSION       A(N)       ,B(N)       ,C(N)       ,D(N)       ,
     1                U(N)       ,Z(N)
C
      BN = B(N)
      D(1) = A(2)/B(1)
      V = A(1)
      U(1) = C(N)/B(1)
      NM2 = N-2
      DO  10 J=2,NM2
         DEN = B(J)-C(J-1)*D(J-1)
         D(J) = A(J+1)/DEN
         U(J) = -C(J-1)*U(J-1)/DEN
         BN = BN-V*U(J-1)
         V = -V*D(J-1)
   10 CONTINUE
      DEN = B(N-1)-C(N-2)*D(N-2)
      D(N-1) = (A(N)-C(N-2)*U(N-2))/DEN
      AN = C(N-1)-V*D(N-2)
      BN = BN-V*U(N-2)
      DEN = BN-AN*D(N-1)
C
C     SET LAST COMPONENT EQUAL TO ONE
C
      Z(N) = 1.0
      Z(N-1) = -D(N-1)
      NM1 = N-1
      DO  20 J=2,NM1
         K = N-J
         Z(K) = -D(K)*Z(K+1)-U(K)*Z(N)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE DEFER (COFX,COFY,USOL,IDMN,GRHS,MN)
C
C     THIS SUBROUTINE FIRST APPROXIMATES THE TRUNCATION ERROR GIVEN
C     BY  TRUN1(X,Y)=DLX**2*TX+DLY**2*TY WHERE
C     TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 ON THE INTERIOR AND
C     AT THE BOUNDARIES IF PERIODIC (HERE UXXX,UXXXX ARE THE THIRD
C     AND FOURTH PARTIAL DERIVATIVES OF U WITH RESPECT TO X).
C     TX IS OF THE FORM AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX)
C     AT X=A OR X=B IF THE BOUNDARY CONDITION THERE IS MIXED.
C     TX=0.0 ALONG SPECIFIED BOUNDARIES.  TY HAS SYMMETRIC FORM
C     IN Y WITH X,AFUN(X),BFUN(X) REPLACED BY Y,DFUN(Y),EFUN(Y).
C     THE SECOND ORDER SOLUTION IN USOL IS USED TO APPROXIMATE
C     (VIA SECOND ORDER FINITE DIFFERENCING) THE TRUN1ATION ERROR
C     AND THE RESULT IS ADDED TO THE RIGHT HAND SIDE IN GRHS
C     AND THEN TRANSFERRED TO USOL TO BE USED AS A NEW RIGHT
C     HAND SIDE WHEN CALLING BLKTRI FOR A FOURTH ORDER SOLUTION.
C
      DIMENSION       GRHS(MN,*)             ,USOL(IDMN,*)
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
C
C
C     COMPUTE TRUNCATION ERROR APPROXIMATION OVER THE ENTIRE MESH
C
      DO  40 J=JS,NS
         YJ = CIT+FLOAT(J-1)*DLY
         CALL COFY (YJ,DJ,EJ,FJ)
         DO  30 I=IS,MS
            XI = AIT+FLOAT(I-1)*DLX
            CALL COFX (XI,AI,BI,CI)
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ)
C
            CALL DXFN (USOL,IDMN,I,J,UXXX,UXXXX)
            CALL DYFN (USOL,IDMN,I,J,UYYY,UYYYY)
            TX = AI*UXXXX/12.0+BI*UXXX/6.0
            TY = DJ*UYYYY/12.0+EJ*UYYY/6.0
C
C     RESET FORM OF TRUNCATION IF AT BOUNDARY WHICH IS NON-PERIODIC
C
            IF (KSWX.EQ.1 .OR. (I.GT.1 .AND. I.LT.K)) GO TO  10
            TX = AI/3.0*(UXXXX/4.0+UXXX/DLX)
   10       IF (KSWY.EQ.1 .OR. (J.GT.1 .AND. J.LT.L)) GO TO  20
            TY = DJ/3.0*(UYYYY/4.0+UYYY/DLY)
   20       GRHS(I,J) = GRHS(I,J)+DLX**2*TX+DLY**2*TY
   30    CONTINUE
   40 CONTINUE
C
C     RESET THE RIGHT HAND SIDE IN USOL
C
      DO  60 I=IS,MS
         DO  50 J=JS,NS
            USOL(I,J) = GRHS(I,J)
   50    CONTINUE
   60 CONTINUE
      RETURN
      END
      SUBROUTINE DXFN (U,IDMN,I,J,UXXX,UXXXX)
C
C     THIS PROGRAM COMPUTES SECOND ORDER FINITE DIFFERENCE
C     APPROXIMATIONS TO THE THIRD AND FOURTH X
C     PARTIAL DERIVATIVES OF U AT THE (I,J) MESH POINT
C
      DIMENSION       U(IDMN,*)
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
C
      IF (I.GT.2 .AND. I.LT.(K-1)) GO TO  50
      IF (I .EQ. 1) GO TO  10
      IF (I .EQ. 2) GO TO  30
      IF (I .EQ. K-1) GO TO  60
      IF (I .EQ. K) GO TO  80
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A
C
   10 IF (KSWX .EQ. 1) GO TO  20
      UXXX = (-5.0*U(1,J)+18.0*U(2,J)-24.0*U(3,J)+14.0*U(4,J)-
     1                                               3.0*U(5,J))/(TDLX3)
      UXXXX = (3.0*U(1,J)-14.0*U(2,J)+26.0*U(3,J)-24.0*U(4,J)+
     1                                      11.0*U(5,J)-2.0*U(6,J))/DLX4
      RETURN
C
C     PERIODIC AT X=A
C
   20 UXXX = (-U(K-2,J)+2.0*U(K-1,J)-2.0*U(2,J)+U(3,J))/(TDLX3)
      UXXXX = (U(K-2,J)-4.0*U(K-1,J)+6.0*U(1,J)-4.0*U(2,J)+U(3,J))/DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A+DLX
C
   30 IF (KSWX .EQ. 1) GO TO  40
      UXXX = (-3.0*U(1,J)+10.0*U(2,J)-12.0*U(3,J)+6.0*U(4,J)-U(5,J))/
     1       TDLX3
      UXXXX = (2.0*U(1,J)-9.0*U(2,J)+16.0*U(3,J)-14.0*U(4,J)+6.0*U(5,J)-
     1                                                      U(6,J))/DLX4
      RETURN
C
C     PERIODIC AT X=A+DLX
C
   40 UXXX = (-U(K-1,J)+2.0*U(1,J)-2.0*U(3,J)+U(4,J))/(TDLX3)
      UXXXX = (U(K-1,J)-4.0*U(1,J)+6.0*U(2,J)-4.0*U(3,J)+U(4,J))/DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR
C
   50 CONTINUE
      UXXX = (-U(I-2,J)+2.0*U(I-1,J)-2.0*U(I+1,J)+U(I+2,J))/TDLX3
      UXXXX = (U(I-2,J)-4.0*U(I-1,J)+6.0*U(I,J)-4.0*U(I+1,J)+U(I+2,J))/
     1        DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B-DLX
C
   60 IF (KSWX .EQ. 1) GO TO  70
      UXXX = (U(K-4,J)-6.0*U(K-3,J)+12.0*U(K-2,J)-10.0*U(K-1,J)+
     1                                                 3.0*U(K,J))/TDLX3
      UXXXX = (-U(K-5,J)+6.0*U(K-4,J)-14.0*U(K-3,J)+16.0*U(K-2,J)-
     1                                     9.0*U(K-1,J)+2.0*U(K,J))/DLX4
      RETURN
C
C     PERIODIC AT X=B-DLX
C
   70 UXXX = (-U(K-3,J)+2.0*U(K-2,J)-2.0*U(1,J)+U(2,J))/TDLX3
      UXXXX = (U(K-3,J)-4.0*U(K-2,J)+6.0*U(K-1,J)-4.0*U(1,J)+U(2,J))/
     1        DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B
C
   80 UXXX = -(3.0*U(K-4,J)-14.0*U(K-3,J)+24.0*U(K-2,J)-18.0*U(K-1,J)+
     1                                                 5.0*U(K,J))/TDLX3
      UXXXX = (-2.0*U(K-5,J)+11.0*U(K-4,J)-24.0*U(K-3,J)+26.0*U(K-2,J)-
     1                                    14.0*U(K-1,J)+3.0*U(K,J))/DLX4
      RETURN
      END
      SUBROUTINE DYFN (U,IDMN,I,J,UYYY,UYYYY)
C
C     THIS PROGRAM COMPUTES SECOND ORDER FINITE DIFFERENCE
C     APPROXIMATIONS TO THE THIRD AND FOURTH Y
C     PARTIAL DERIVATIVES OF U AT THE (I,J) MESH POINT
C
      DIMENSION       U(IDMN,*)
      COMMON /SPLP/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
C
      IF (J.GT.2 .AND. J.LT.(L-1)) GO TO  50
      IF (J .EQ. 1) GO TO  10
      IF (J .EQ. 2) GO TO  30
      IF (J .EQ. L-1) GO TO  60
      IF (J .EQ. L) GO TO  80
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C
C
   10 IF (KSWY .EQ. 1) GO TO  20
      UYYY = (-5.0*U(I,1)+18.0*U(I,2)-24.0*U(I,3)+14.0*U(I,4)-
     1                                                 3.0*U(I,5))/TDLY3
      UYYYY = (3.0*U(I,1)-14.0*U(I,2)+26.0*U(I,3)-24.0*U(I,4)+
     1                                      11.0*U(I,5)-2.0*U(I,6))/DLY4
      RETURN
C
C     PERIODIC AT X=A
C
   20 UYYY = (-U(I,L-2)+2.0*U(I,L-1)-2.0*U(I,2)+U(I,3))/TDLY3
      UYYYY = (U(I,L-2)-4.0*U(I,L-1)+6.0*U(I,1)-4.0*U(I,2)+U(I,3))/DLY4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C+DLY
C
   30 IF (KSWY .EQ. 1) GO TO  40
      UYYY = (-3.0*U(I,1)+10.0*U(I,2)-12.0*U(I,3)+6.0*U(I,4)-U(I,5))/
     1       TDLY3
      UYYYY = (2.0*U(I,1)-9.0*U(I,2)+16.0*U(I,3)-14.0*U(I,4)+6.0*U(I,5)-
     1                                                      U(I,6))/DLY4
      RETURN
C
C     PERIODIC AT Y=C+DLY
C
   40 UYYY = (-U(I,L-1)+2.0*U(I,1)-2.0*U(I,3)+U(I,4))/TDLY3
      UYYYY = (U(I,L-1)-4.0*U(I,1)+6.0*U(I,2)-4.0*U(I,3)+U(I,4))/DLY4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR
C
   50 CONTINUE
      UYYY = (-U(I,J-2)+2.0*U(I,J-1)-2.0*U(I,J+1)+U(I,J+2))/TDLY3
      UYYYY = (U(I,J-2)-4.0*U(I,J-1)+6.0*U(I,J)-4.0*U(I,J+1)+U(I,J+2))/
     1        DLY4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D-DLY
C
   60 IF (KSWY .EQ. 1) GO TO  70
      UYYY = (U(I,L-4)-6.0*U(I,L-3)+12.0*U(I,L-2)-10.0*U(I,L-1)+
     1                                                 3.0*U(I,L))/TDLY3
      UYYYY = (-U(I,L-5)+6.0*U(I,L-4)-14.0*U(I,L-3)+16.0*U(I,L-2)-
     1                                     9.0*U(I,L-1)+2.0*U(I,L))/DLY4
      RETURN
C
C     PERIODIC AT Y=D-DLY
C
   70 CONTINUE
      UYYY = (-U(I,L-3)+2.0*U(I,L-2)-2.0*U(I,1)+U(I,2))/TDLY3
      UYYYY = (U(I,L-3)-4.0*U(I,L-2)+6.0*U(I,L-1)-4.0*U(I,1)+U(I,2))/
     1        DLY4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D
C
   80 UYYY = -(3.0*U(I,L-4)-14.0*U(I,L-3)+24.0*U(I,L-2)-18.0*U(I,L-1)+
     1                                                 5.0*U(I,L))/TDLY3
      UYYYY = (-2.0*U(I,L-5)+11.0*U(I,L-4)-24.0*U(I,L-3)+26.0*U(I,L-2)-
     1                                    14.0*U(I,L-1)+3.0*U(I,L))/DLY4
      RETURN
      END
      SUBROUTINE BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y,
     1                   IERROR,W)
C
C
C***********************************************************************
C
C          VERSION  2  OCTOBER 1976  INCLUDING ERRATA  OCTOBER 1976
C
C         DOCUMENTATION FOR THIS PROGRAM IS GIVEN IN
C
C        EFFICIENT FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C            ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS
C
C                              BY
C
C          PAUL SWARZTRAUBER   AND  ROLAND SWEET
C
C             TECHNICAL NOTE TN/IA-109   JULY 1975
C
C       NATIONAL CENTER FOR ATMOSPHERIC RESEARCH  BOULDER,COLORADO 80307
C
C        WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION
C
C***********************************************************************
C
C
C
C     SUBROUTINE BLKTRI SOLVES A SYSTEM OF LINEAR EQUATIONS OF THE FORM
C
C          AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J)
C
C          + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J)
C
C               FOR I = 1,2,...,M  AND  J = 1,2,...,N.
C
C     I+1 AND I-1 ARE EVALUATED MODULO M AND J+1 AND J-1 MODULO N, I.E.,
C
C          X(I,0) = X(I,N),  X(I,N+1) = X(I,1),
C          X(0,J) = X(M,J),  X(M+1,J) = X(1,J).
C
C     THESE EQUATIONS USUALLY RESULT FROM THE DISCRETIZATION OF
C     SEPARABLE ELLIPTIC EQUATIONS.  BOUNDARY CONDITIONS MAY BE
C     DIRICHLET, NEUMANN, OR PERIODIC.
C
C
C     * * * * * * * * * *     ON INPUT     * * * * * * * * * *
C
C     IFLG
C       = 0  INITIALIZATION ONLY.  CERTAIN QUANTITIES THAT DEPEND ON NP,
C                                  N, AN, BN, AND CN ARE COMPUTED AND
C                                  STOR1D IN THE WORK ARRAY  W.
C       = 1  THE QUANTITIES THAT WERE COMPUTED IN THE INITIALIZATION ARE
C            USED TO OBTAIN THE SOLUTION X(I,J).
C
C       NOTE   A CALL WITH IFLG=0 TAKES APPROXIMATELY ONE HALF THE TIME
C              TIME AS A CALL WITH IFLG = 1  .  HOWEVER, THE
C              INITIALIZATION DOES NOT HAVE TO BE REPEATED UNLESS NP, N,
C              AN, BN, OR CN CHANGE.
C
C     NP
C       = 0  IF AN(1) AND CN(N) ARE NOT ZERO, WHICH CORRESPONDS TO
C            PERIODIC BOUNARY CONDITIONS.
C       = 1  IF AN(1) AND CN(N) ARE ZERO.
C
C     N
C       THE NUMBER OF UNKNOWNS IN THE J-DIRECTION. N MUST BE GREATER
C       THAN 2. THE OPERATION COUNT IS PROPORTIONAL TO MNLOG2(N), HENCE
C       N SHOULD BE SELECTED LESS THAN OR EQUAL TO M.
C
C     AN,BN,CN
C       ONE-DIMENSIONAL ARRAYS OF LENGTH N THAT SPECIFY THE COEFFICIENTS
C       IN THE LINEAR EQUATIONS GIVEN ABOVE.
C
C     MP
C       = 0  IF AM(1) AND CM(M) ARE NOT ZERO, WHICH CORRESPONDS TO
C            PERIODIC BOUNDARY CONDITIONS.
C       = 1  IF AM(1) = CM(M) = 0  .
C
C     M
C       THE NUMBER OF UNKNOWNS IN THE I-DIRECTION. M MUST BE GREATER
C       THAN 2.
C
C     AM,BM,CM
C       ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT SPECIFY THE COEFFICIENTS
C       IN THE LINEAR EQUATIONS GIVEN ABOVE.
C
C     IDIMY
C       THE ROW (OR FIRST) DIMENSION OF THE TWO-DIMENSIONAL ARRAY Y AS
C       IT APPEARS IN THE PROGRAM CALLING BLKTRI.  THIS PARAMETER IS
C       USED TO SPECIFY THE VARIABLE DIMENSION OF Y.  IDIMY MUST BE AT
C       LEAST M.
C
C     Y
C       A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT
C       SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN ABOVE.  Y MUST BE
C       DIMENSIONED AT LEAST M*N.
C
C     W
C       A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C       WORK SPACE.
C             IF NP=1 DEFINE K=INT(LOG2(N))+1 AND SET L=2**(K+1) THEN
C                     W MUST HAVE DIMENSION (K-2)*L+K+4+MAX(2N,6M)
C
C             IF NP=0 DEFINE K=INT(LOG2(N-1))+1 AND SET L=2**(K+1) THEN
C                     W MUST HAVE DIMENSION (K-2)*L+K+4+2N+MAX(2N,6M)
C
C       **IMPORTANT** FOR PURPOSES OF CHECKING, THE REQUIRED DIMENSION
C                     OF W IS COMPUTED BY BLKTRI AND STOR1D IN W(1)
C                     IN FLOATING POINT FORMAT.
C
C     * * * * * * * * * *     ON OUTPUT     * * * * * * * * * *
C
C     Y
C       CONTAINS THE SOLUTION X.
C
C     IERROR
C       AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.  EXCEPT
C       FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED.
C
C       = 0  NO ERROR.
C       = 1  M IS LESS THAN 5
C       = 2  N IS LESS THAN 3.
C       = 3  IDIMY IS LESS THAN M.
C       = 4  BLKTRI FAILED WHILE COMPUTING RESULTS THAT DEPEND ON THE
C            COEFFICIENT ARRAYS AN, BN, CN.  CHECK THESE ARRAYS.
C       = 5  AN(J)*CN(J-1) IS LESS THAN 0 FOR SOME J. POSSIBLE REASONS
C            FOR THIS CONDITION ARE
C            1. THE ARRAYS AN AND CN ARE NOT CORRECT
C            2. TOO LARGE A GRID SPACING WAS USED IN THE DISCRETIZATION
C               OF THE ELLIPTIC EQUATION
C            3. THE LINEAR EQUATIONS RESULTED FROM A PARTIAL
C               DIFFERENTIAL EQUATION WHICH WAS NOT ELLIPTIC
C
C     W
C       CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE DESTROYED IF
C       BLKTRI WILL BE CALLED AGAIN WITH IFLG = 1  .
C
C
C
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
     1                BM(*)      ,CM(*)      ,Y(IDIMY,*) ,W(*)
      EXTERNAL        PROD0      ,PRODP      ,CPROD0     ,CPRODP
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
C TEST M AND N FOR THE PROPER FORM
C
      NM = N
      IERROR = 0
      IF (M-5)  10, 20, 20
   10 IERROR = 1
      GO TO 190
   20 IF (NM-3)  30, 40, 40
   30 IERROR = 2
      GO TO 190
   40 IF (IDIMY-M)  50, 60, 60
   50 IERROR = 3
      GO TO 190
   60 NH = N
      NPP = NP
      IF (NPP)  70, 80, 70
   70 NH = NH+1
   80 IK = 2
      K = 1
   90 IK = IK+IK
      K = K+1
      IF (NH-IK) 100,100, 90
  100 NL = IK
      IK = IK+IK
      NL = NL-1
      IWAH = (K-2)*IK+K+6
      IF (NPP) 110,120,110
C
C     DIVIDE W INTO WORKING SUB ARRAYS
C
  110 IW1 = IWAH
      IWBH = IW1+NM
      W(1) = FLOAT(IW1-1+MAX0(2*NM,6*M))
      GO TO 130
  120 IWBH = IWAH+NM+NM
      IW1 = IWBH
      W(1) = FLOAT(IW1-1+MAX0(2*NM,6*M))
      NM = NM-1
C
C SUBROUTINE COMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS
C
  130 IF (IERROR) 190,140,190
  140 IW2 = IW1+M
      IW3 = IW2+M
      IWD = IW3+M
      IWW = IWD+M
      IWU = IWW+M
      IF (IFLG) 160,150,160
  150 CALL COMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH))
      GO TO 190
  160 IF (MP) 170,180,170
C
C SUBROUTINE BLKTR1 SOLVES THE LINEAR SYSTEM
C
  170 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PROD0,CPROD0)
      GO TO 190
  180 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PRODP,CPRODP)
  190 CONTINUE
      RETURN
      END
      SUBROUTINE BLKTR1 (N,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,B,W1,W2,W3,WD,
     1                   WW,WU,PRDCT,CPRDCT)
C
C BLKTR1 SOLVES THE LINEAR SYSTEM
C
C B  CONTAINS THE ROOTS OF ALL THE B POLYNOMIALS
C W1,W2,W3,WD,WW,WU  ARE ALL WORKING ARRAYS
C PRDCT IS EITHER PRODP OR PROD0 DEPENDING ON WHETHER THE BOUNDARY
C CONDITIONS IN THE M DIRECTION ARE PERIODIC OR NOT
C CPRDCT IS EITHER CPRODP OR CPROD0 WHICH ARE THE COMPLEX VERSIONS
C OF PRODP AND PROD0. THESE ARE CALLED IN THE EVENT THAT SOME
C OF THE ROOTS OF THE B SUB P POLYNOMIAL ARE COMPLEX
C
C
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
     1                BM(*)      ,CM(*)      ,B(*)       ,W1(*)      ,
     2                W2(*)      ,W3(*)      ,WD(*)      ,WW(*)      ,
     3                WU(*)      ,Y(IDIMY,*)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
C BEGIN REDUCTION PHASE
C
      KDO = K-1
      DO  90 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I3 = I2+I1
         I4 = I2+I2
         IRM1 = IR-1
         CALL INDXB (I2,IR,IM2,NM2)
         CALL INDXB (I1,IRM1,IM3,NM3)
         CALL INDXB (I3,IRM1,IM1,NM1)
         CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,Y(1,I2),W3,
     1               M,AM,BM,CM,WD,WW,WU)
         IF = 2**K
         DO  80 I=I4,IF,I4
            IF (I-NM)  10, 10, 80
   10       IPI1 = I+I1
            IPI2 = I+I2
            IPI3 = I+I3
            CALL INDXC (I,IR,IDXC,NC)
            IF (I-IF)  20, 80, 80
   20       CALL INDXA (I,IR,IDXA,NA)
            CALL INDXB (I-I1,IRM1,IM1,NM1)
            CALL INDXB (IPI2,IR,IP2,NP2)
            CALL INDXB (IPI1,IRM1,IP1,NP1)
            CALL INDXB (IPI3,IRM1,IP3,NP3)
            CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W3,W1,M,AM,
     1                  BM,CM,WD,WW,WU)
            IF (IPI2-NM)  50, 50, 30
   30       DO  40 J=1,M
               W3(J) = 0.
               W2(J) = 0.
   40       CONTINUE
            GO TO  60
   50       CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,
     1                  Y(1,IPI2),W3,M,AM,BM,CM,WD,WW,WU)
            CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W3,W2,M,AM,
     1                  BM,CM,WD,WW,WU)
   60       DO  70 J=1,M
               Y(J,I) = W1(J)+W2(J)+Y(J,I)
   70       CONTINUE
   80    CONTINUE
   90 CONTINUE
      IF (NPP) 320,100,320
C
C     THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD
C
  100 IF = 2**K
      I = IF/2
      I1 = I/2
      CALL INDXB (I-I1,K-2,IM1,NM1)
      CALL INDXB (I+I1,K-2,IP1,NP1)
      CALL INDXB (I,K-1,IZ,NZ)
      CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,Y(1,I),W1,M,AM,
     1            BM,CM,WD,WW,WU)
      IZR = I
      DO 110 J=1,M
         W2(J) = W1(J)
  110 CONTINUE
      DO 130 LL=2,K
         L = K-LL+1
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I = I2
         CALL INDXC (I,IR,IDXC,NC)
         CALL INDXB (I,IR,IZ,NZ)
         CALL INDXB (I-I1,IR-1,IM1,NM1)
         CALL INDXB (I+I1,IR-1,IP1,NP1)
         CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W1,W1,M,AM,BM,
     1               CM,WD,WW,WU)
         DO 120 J=1,M
            W1(J) = Y(J,I)+W1(J)
  120    CONTINUE
         CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM,
     1               BM,CM,WD,WW,WU)
  130 CONTINUE
      DO 180 LL=2,K
         L = K-LL+1
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I4 = I2+I2
         IFD = IF-I2
         DO 170 I=I2,IFD,I4
            IF (I-I2-IZR) 170,140,170
  140       IF (I-NM) 150,150,180
  150       CALL INDXA (I,IR,IDXA,NA)
            CALL INDXB (I,IR,IZ,NZ)
            CALL INDXB (I-I1,IR-1,IM1,NM1)
            CALL INDXB (I+I1,IR-1,IP1,NP1)
            CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W2,W2,M,AM,
     1                  BM,CM,WD,WW,WU)
            DO 160 J=1,M
               W2(J) = Y(J,I)+W2(J)
  160       CONTINUE
            CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M,
     1                  AM,BM,CM,WD,WW,WU)
            IZR = I
            IF (I-NM) 170,190,170
  170    CONTINUE
  180 CONTINUE
  190 DO 200 J=1,M
         Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J)
  200 CONTINUE
      CALL INDXB (IF/2,K-1,IM1,NM1)
      CALL INDXB (IF,K-1,IP,NP)
      IF (NCMPLX) 210,220,210
  210 CALL CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
     1             Y(1,NM+1),M,AM,BM,CM,W1,W3,WW)
      GO TO 230
  220 CALL PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
     1            Y(1,NM+1),M,AM,BM,CM,WD,WW,WU)
  230 DO 240 J=1,M
         W1(J) = AN(1)*Y(J,NM+1)
         W2(J) = CN(NM)*Y(J,NM+1)
         Y(J,1) = Y(J,1)-W1(J)
         Y(J,NM) = Y(J,NM)-W2(J)
  240 CONTINUE
      DO 260 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I4 = I2+I2
         I1 = I2/2
         I = I4
         CALL INDXA (I,IR,IDXA,NA)
         CALL INDXB (I-I2,IR,IM2,NM2)
         CALL INDXB (I-I2-I1,IR-1,IM3,NM3)
         CALL INDXB (I-I1,IR-1,IM1,NM1)
         CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,W1,W1,M,AM,
     1               BM,CM,WD,WW,WU)
         CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM,
     1               CM,WD,WW,WU)
         DO 250 J=1,M
            Y(J,I) = Y(J,I)-W1(J)
  250    CONTINUE
  260 CONTINUE
C
      IZR = NM
      DO 310 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I3 = I2+I1
         I4 = I2+I2
         IRM1 = IR-1
         DO 300 I=I4,IF,I4
            IPI1 = I+I1
            IPI2 = I+I2
            IPI3 = I+I3
            IF (IPI2-IZR) 270,280,270
  270       IF (I-IZR) 300,310,300
  280       CALL INDXC (I,IR,IDXC,NC)
            CALL INDXB (IPI2,IR,IP2,NP2)
            CALL INDXB (IPI1,IRM1,IP1,NP1)
            CALL INDXB (IPI3,IRM1,IP3,NP3)
            CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,W2,W2,M,
     1                  AM,BM,CM,WD,WW,WU)
            CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM,
     1                  BM,CM,WD,WW,WU)
            DO 290 J=1,M
               Y(J,I) = Y(J,I)-W2(J)
  290       CONTINUE
            IZR = I
            GO TO 310
  300    CONTINUE
  310 CONTINUE
C
C BEGIN BACK SUBSTITUTION PHASE
C
  320 DO 440 LL=1,K
         L = K-LL+1
         IR = L-1
         IRM1 = IR-1
         I2 = 2**IR
         I1 = I2/2
         I4 = I2+I2
         IFD = IF-I2
         DO 430 I=I2,IFD,I4
            IF (I-NM) 330,330,430
  330       IMI1 = I-I1
            IMI2 = I-I2
            IPI1 = I+I1
            IPI2 = I+I2
            CALL INDXA (I,IR,IDXA,NA)
            CALL INDXC (I,IR,IDXC,NC)
            CALL INDXB (I,IR,IZ,NZ)
            CALL INDXB (IMI1,IRM1,IM1,NM1)
            CALL INDXB (IPI1,IRM1,IP1,NP1)
            IF (I-I2) 340,340,360
  340       DO 350 J=1,M
               W1(J) = 0.
  350       CONTINUE
            GO TO 370
  360       CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2),
     1                  W1,M,AM,BM,CM,WD,WW,WU)
  370       IF (IPI2-NM) 400,400,380
  380       DO 390 J=1,M
               W2(J) = 0.
  390       CONTINUE
            GO TO 410
  400       CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2),
     1                  W2,M,AM,BM,CM,WD,WW,WU)
  410       DO 420 J=1,M
               W1(J) = Y(J,I)+W1(J)+W2(J)
  420       CONTINUE
            CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I),
     1                  M,AM,BM,CM,WD,WW,WU)
  430    CONTINUE
  440 CONTINUE
      RETURN
      END
      SUBROUTINE INDXA (I,IR,IDXA,NA)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
      NA = 2**IR
      IDXA = I-NA+1
      IF (I-NM)  20, 20, 10
   10 NA = 0
   20 RETURN
      END
      SUBROUTINE INDXC (I,IR,IDXC,NC)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
      NC = 2**IR
      IDXC = I
      IF (IDXC+NC-1-NM)  20, 20, 10
   10 NC = 0
   20 RETURN
      END
      SUBROUTINE INDXB (I,IR,IDX,IDP)
C
C B(IDX) IS THE LOCATION OF THE FIRST ROOT OF THE B(I,IR) POLYNOMIAL
C
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
      IDP = 0
      IF (IR)  70, 10, 30
   10 IF (I-NM)  20, 20, 70
   20 IDX = I
      IDP = 1
      RETURN
   30 IZH = 2**IR
      ID = I-IZH-IZH
      IDX = ID+ID+(IR-1)*IK+IR+(IK-I)/IZH+4
      IPL = IZH-1
      IDP = IZH+IZH-1
      IF (I-IPL-NM)  50, 50, 40
   40 IDP = 0
      RETURN
   50 IF (I+IPL-NM)  70, 70, 60
   60 IDP = NM+IPL-I+1
   70 RETURN
      END
      SUBROUTINE PROD0 (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,Y,M,A,B,C,D,W,U)
C
C PROD0 APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN Y.
C
C BD,BM1,BM2 ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS.
C ND,NM1,NM2 THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY.
C AA         ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X.
C NA         THE LENGTH OF THE ARRAY AA.
C X,Y        MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS Y.
C A,B,C      ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX.
C M          THE ORDER OF THE MATRIX.
C D,W,U      WORKING ARRAYS.
C IS         DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE.
C
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
     1                Y(*)       ,D(*)       ,W(*)       ,BD(*)      ,
     2                BM1(*)     ,BM2(*)     ,AA(*)      ,U(*)
C
      DO  10 J=1,M
         W(J) = X(J)
         Y(J) = W(J)
   10 CONTINUE
      MM = M-1
      ID = ND
      IBR = 0
      M1 = NM1
      M2 = NM2
      IA = NA
   20 IF (IA)  50, 50, 30
   30 RT = AA(IA)
      IF (ND .EQ. 0) RT = -RT
      IA = IA-1
C
C SCALAR MULTIPLICATION
C
      DO  40 J=1,M
         Y(J) = RT*W(J)
   40 CONTINUE
   50 IF (ID) 250,250, 60
   60 RT = BD(ID)
      ID = ID-1
      IF (ID .EQ. 0) IBR = 1
C
C BEGIN SOLUTION TO SYSTEM
C
      D(M) = A(M)/(B(M)-RT)
      W(M) = Y(M)/(B(M)-RT)
      DO  70 J=2,MM
         K = M-J
         DEN = B(K+1)-RT-C(K+1)*D(K+2)
         D(K+1) = A(K+1)/DEN
         W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN
   70 CONTINUE
      DEN = B(1)-RT-C(1)*D(2)
      W(1) = 1.
      IF (DEN)  80, 90, 80
   80 W(1) = (Y(1)-C(1)*W(2))/DEN
   90 DO 100 J=2,M
         W(J) = W(J)-D(J)*W(J-1)
  100 CONTINUE
      IF (NA) 130,130, 20
  110 DO 120 J=1,M
         Y(J) = W(J)
  120 CONTINUE
      IBR = 1
      GO TO  20
  130 IF (M1) 140,140,150
  140 IF (M2) 110,110,200
  150 IF (M2) 170,170,160
  160 IF (ABS(BM1(M1))-ABS(BM2(M2))) 200,200,170
  170 IF (IBR) 180,180,190
  180 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 110,190,190
  190 RT = RT-BM1(M1)
      M1 = M1-1
      GO TO 230
  200 IF (IBR) 210,210,220
  210 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 110,220,220
  220 RT = RT-BM2(M2)
      M2 = M2-1
  230 DO 240 J=1,M
         Y(J) = Y(J)+RT*W(J)
  240 CONTINUE
      GO TO  20
  250 RETURN
      END
      SUBROUTINE PRODP (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,Y,M,A,B,C,D,U,W)
C
C PRODP APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN Y.   (PERIODIC BOUNDARY CONDITIONS)
C
C BD,BM1,BM2 ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS.
C ND,NM1,NM2 THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY.
C AA         ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X.
C NA         LENGTH OF THE ARRAY AA.
C X,Y        MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS Y.
C A,B,C      ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX.
C M          THE ORDER OF THE MATRIX.
C D,U,W      WORKING ARRAYS.
C IS         DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE.
C
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
     1                Y(*)       ,D(*)       ,U(*)       ,BD(*)      ,
     2                BM1(*)     ,BM2(*)     ,AA(*)      ,W(*)
C
      DO  10 J=1,M
         Y(J) = X(J)
         W(J) = Y(J)
   10 CONTINUE
      MM = M-1
      MM2 = M-2
      ID = ND
      IBR = 0
      M1 = NM1
      M2 = NM2
      IA = NA
   20 IF (IA)  50, 50, 30
   30 RT = AA(IA)
      IF (ND .EQ. 0) RT = -RT
      IA = IA-1
      DO  40 J=1,M
         Y(J) = RT*W(J)
   40 CONTINUE
   50 IF (ID) 280,280, 60
   60 RT = BD(ID)
      ID = ID-1
      IF (ID .EQ. 0) IBR = 1
C
C BEGIN SOLUTION TO SYSTEM
C
      BH = B(M)-RT
      YM = Y(M)
      DEN = B(1)-RT
      D(1) = C(1)/DEN
      U(1) = A(1)/DEN
      W(1) = Y(1)/DEN
      V = C(M)
      IF (MM2-2)  90, 70, 70
   70 DO  80 J=2,MM2
         DEN = B(J)-RT-A(J)*D(J-1)
         D(J) = C(J)/DEN
         U(J) = -A(J)*U(J-1)/DEN
         W(J) = (Y(J)-A(J)*W(J-1))/DEN
         BH = BH-V*U(J-1)
         YM = YM-V*W(J-1)
         V = -V*D(J-1)
   80 CONTINUE
   90 DEN = B(M-1)-RT-A(M-1)*D(M-2)
      D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN
      W(M-1) = (Y(M-1)-A(M-1)*W(M-2))/DEN
      AM = A(M)-V*D(M-2)
      BH = BH-V*U(M-2)
      YM = YM-V*W(M-2)
      DEN = BH-AM*D(M-1)
      IF (DEN) 100,110,100
  100 W(M) = (YM-AM*W(M-1))/DEN
      GO TO 120
  110 W(M) = 1.
  120 W(M-1) = W(M-1)-D(M-1)*W(M)
      DO 130 J=2,MM
         K = M-J
         W(K) = W(K)-D(K)*W(K+1)-U(K)*W(M)
  130 CONTINUE
      IF (NA) 160,160, 20
  140 DO 150 J=1,M
         Y(J) = W(J)
  150 CONTINUE
      IBR = 1
      GO TO  20
  160 IF (M1) 170,170,180
  170 IF (M2) 140,140,230
  180 IF (M2) 200,200,190
  190 IF (ABS(BM1(M1))-ABS(BM2(M2))) 230,230,200
  200 IF (IBR) 210,210,220
  210 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 140,220,220
  220 RT = RT-BM1(M1)
      M1 = M1-1
      GO TO 260
  230 IF (IBR) 240,240,250
  240 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 140,250,250
  250 RT = RT-BM2(M2)
      M2 = M2-1
  260 DO 270 J=1,M
         Y(J) = Y(J)+RT*W(J)
  270 CONTINUE
      GO TO  20
  280 RETURN
      END
      SUBROUTINE CPROD0(ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,YY,M,A,B,C,D,W,Y)
C
C CPROD0 APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN YY.   (COMPLEX CASE)
C
C AA         ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X.
C ND,NM1,NM2 THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY.
C BD,BM1,BM2 ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS.
C NA         THE LENGTH OF THE ARRAY AA.
C X,YY       MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS YY.
C A,B,C      ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX.
C M          THE ORDER OF THE MATRIX.
C D,W,Y      WORKING ARRAYS.
C ISGN       DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE.
C
      COMPLEX         Y          ,D          ,W          ,BD         ,
     1                CRT        ,DEN        ,Y1         ,Y2
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
     1                Y(*)       ,D(*)       ,W(*)       ,BD(*)      ,
     2                BM1(*)     ,BM2(*)     ,AA(*)      ,YY(*)
C
      DO  10 J=1,M
         Y(J) = CMPLX(X(J),0.)
   10 CONTINUE
      MM = M-1
      ID = ND
      M1 = NM1
      M2 = NM2
      IA = NA
   20 IFLG = 0
      IF (ID)  90, 90, 30
   30 CRT = BD(ID)
      ID = ID-1
C
C BEGIN SOLUTION TO SYSTEM
C
      D(M) = A(M)/(B(M)-CRT)
      W(M) = Y(M)/(B(M)-CRT)
      DO  40 J=2,MM
         K = M-J
         DEN = B(K+1)-CRT-C(K+1)*D(K+2)
         D(K+1) = A(K+1)/DEN
         W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN
   40 CONTINUE
      DEN = B(1)-CRT-C(1)*D(2)
      IF (CABS(DEN))  50, 60, 50
   50 Y(1) = (Y(1)-C(1)*W(2))/DEN
      GO TO  70
   60 Y(1) = (1.,0.)
   70 DO  80 J=2,M
         Y(J) = W(J)-D(J)*Y(J-1)
   80 CONTINUE
   90 IF (M1) 100,100,120
  100 IF (M2) 210,210,110
  110 RT = BM2(M2)
      M2 = M2-1
      GO TO 170
  120 IF (M2) 130,130,140
  130 RT = BM1(M1)
      M1 = M1-1
      GO TO 170
  140 IF (ABS(BM1(M1))-ABS(BM2(M2))) 160,160,150
  150 RT = BM1(M1)
      M1 = M1-1
      GO TO 170
  160 RT = BM2(M2)
      M2 = M2-1
  170 Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)
      IF (MM-2) 200,180,180
C
C MATRIX MULTIPLICATION
C
  180 DO 190 J=2,MM
         Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1)
         Y(J-1) = Y1
         Y1 = Y2
  190 CONTINUE
  200 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)
      Y(M-1) = Y1
      IFLG = 1
      GO TO  20
  210 IF (IA) 240,240,220
  220 RT = AA(IA)
      IA = IA-1
      IFLG = 1
C
C SCALAR MULTIPLICATION
C
      DO 230 J=1,M
         Y(J) = RT*Y(J)
  230 CONTINUE
  240 IF (IFLG) 250,250, 20
  250 DO 260 J=1,M
         YY(J) = REAL(Y(J))
  260 CONTINUE
      RETURN
      END
      SUBROUTINE CPRODP (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,YY,M,A,B,C,D,U,Y)
C
C PRODP APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN YY.  (PERIODIC BOUNDARY CONDITIONS AND
C COMPLEX CASE)
C
C BD,BM1,BM2 ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS.
C ND,NM1,NM2 THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY.
C AA         ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X.
C NA         THE LENGTH OF THE ARRAY AA.
C X,YY       MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS YY.
C A,B,C      ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX.
C M          THE ORDER OF THE MATRIX.
C D,U,Y      WORKING ARRAYS.
C ISGN       DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE.
C
      COMPLEX         Y          ,D          ,U          ,V          ,
     1                DEN        ,BH         ,YM         ,AM         ,
     2                Y1         ,Y2         ,YH         ,BD         ,
     3                CRT
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
     1                Y(*)       ,D(*)       ,U(*)       ,BD(*)      ,
     2                BM1(*)     ,BM2(*)     ,AA(*)      ,YY(*)
C
      DO  10 J=1,M
         Y(J) = CMPLX(X(J),0.)
   10 CONTINUE
      MM = M-1
      MM2 = M-2
      ID = ND
      M1 = NM1
      M2 = NM2
      IA = NA
   20 IFLG = 0
      IF (ID) 110,110, 30
   30 CRT = BD(ID)
      ID = ID-1
      IFLG = 1
C
C BEGIN SOLUTION TO SYSTEM
C
      BH = B(M)-CRT
      YM = Y(M)
      DEN = B(1)-CRT
      D(1) = C(1)/DEN
      U(1) = A(1)/DEN
      Y(1) = Y(1)/DEN
      V = CMPLX(C(M),0.)
      IF (MM2-2)  60, 40, 40
   40 DO  50 J=2,MM2
         DEN = B(J)-CRT-A(J)*D(J-1)
         D(J) = C(J)/DEN
         U(J) = -A(J)*U(J-1)/DEN
         Y(J) = (Y(J)-A(J)*Y(J-1))/DEN
         BH = BH-V*U(J-1)
         YM = YM-V*Y(J-1)
         V = -V*D(J-1)
   50 CONTINUE
   60 DEN = B(M-1)-CRT-A(M-1)*D(M-2)
      D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN
      Y(M-1) = (Y(M-1)-A(M-1)*Y(M-2))/DEN
      AM = A(M)-V*D(M-2)
      BH = BH-V*U(M-2)
      YM = YM-V*Y(M-2)
      DEN = BH-AM*D(M-1)
      IF (CABS(DEN))  70, 80, 70
   70 Y(M) = (YM-AM*Y(M-1))/DEN
      GO TO  90
   80 Y(M) = (1.,0.)
   90 Y(M-1) = Y(M-1)-D(M-1)*Y(M)
      DO 100 J=2,MM
         K = M-J
         Y(K) = Y(K)-D(K)*Y(K+1)-U(K)*Y(M)
  100 CONTINUE
  110 IF (M1) 120,120,140
  120 IF (M2) 230,230,130
  130 RT = BM2(M2)
      M2 = M2-1
      GO TO 190
  140 IF (M2) 150,150,160
  150 RT = BM1(M1)
      M1 = M1-1
      GO TO 190
  160 IF (ABS(BM1(M1))-ABS(BM2(M2))) 180,180,170
  170 RT = BM1(M1)
      M1 = M1-1
      GO TO 190
  180 RT = BM2(M2)
      M2 = M2-1
C
C MATRIX MULTIPLICATION
C
  190 YH = Y(1)
      Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)+A(1)*Y(M)
      IF (MM-2) 220,200,200
  200 DO 210 J=2,MM
         Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1)
         Y(J-1) = Y1
         Y1 = Y2
  210 CONTINUE
  220 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)+C(M)*YH
      Y(M-1) = Y1
      IFLG = 1
      GO TO  20
  230 IF (IA) 260,260,240
  240 RT = AA(IA)
      IA = IA-1
      IFLG = 1
C
C SCALAR MULTIPLICATION
C
      DO 250 J=1,M
         Y(J) = RT*Y(J)
  250 CONTINUE
  260 IF (IFLG) 270,270, 20
  270 DO 280 J=1,M
         YY(J) = REAL(Y(J))
  280 CONTINUE
      RETURN
      END
      SUBROUTINE COMPB (N,IERROR,AN,BN,CN,B,AH,BH)
C
C     COMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS USING TQLRT0,
C     WHICH IS A MODIFICATION OF THE EISPACK SUBROUTINE TQLRAT.
C     IERROR IS SET TO 4 IF EITHER TQLRT0 FAILS OR A(J+1)*C(J) IS
C     LESS THAN 0 FOR SOME J. AH AND BH ARE TEMPORARY WORK ARRAYS.
C
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,B(*)       ,
     1                AH(*)      ,BH(*)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
      EPS = SPMPAR(1)
      BNORM = ABS(BN(1))
      DO  40 J=2,NM
         BNORM = AMAX1(BNORM,ABS(BN(J)))
         ARG = AN(J)*CN(J-1)
         IF (ARG) 220, 30, 30
   30    B(J) = SIGN(SQRT(ARG),AN(J))
   40 CONTINUE
      CNV = EPS*BNORM
      IF = 2**K
      KDO = K-1
      DO 100 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I4 = I2+I2
         IPL = I4-1
         IFD = IF-I4
         DO  90 I=I4,IFD,I4
            CALL INDXB (I,L,IB,NB)
            IF (NB) 100,100, 50
   50       JS = I-IPL
            JF = JS+NB-1
            LS = 0
            DO  60 J=JS,JF
               LS = LS+1
               BH(LS) = BN(J)
               AH(LS) = B(J)
   60       CONTINUE
            CALL TQLRT0 (NB,BH,AH,IERROR)
            IF (IERROR) 210, 70,210
   70       LH = IB-1
            DO  80 J=1,NB
               LH = LH+1
               B(LH) = -BH(J)
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
      DO 110 J=1,NM
         B(J) = -BN(J)
  110 CONTINUE
      IF (NPP .NE. 0) RETURN
C
      NMP = NM+1
      NB = NM+NMP
      DO 150 J=1,NB
         L1 = MOD(J-1,NMP)+1
         L2 = MOD(J+NM-1,NMP)+1
         ARG = AN(L1)*CN(L2)
         IF (ARG .LT. 0.0) GO TO 220
         BH(J) = SIGN(SQRT(ARG),-AN(L1))
         AH(J) = -BN(L1)
  150 CONTINUE
      CALL TQLRT0 (NB,AH,BH,IERROR)
      IF (IERROR .NE. 0) GO TO 210
C
      CALL INDXB (IF,K-1,J2,LH)
      CALL INDXB (IF/2,K-1,J1,LH)
      J2 = J2+1
      LH = J2
      N2M2 = J2+NM+NM-2
  170 D1 = ABS(B(J1)-B(J2-1))
      D2 = ABS(B(J1)-B(J2))
      D3 = ABS(B(J1)-B(J2+1))
      IF ((D2 .LT. D1) .AND. (D2 .LT. D3)) GO TO 180
      B(LH) = B(J2)
      J2 = J2+1
      LH = LH+1
      IF (J2-N2M2) 170,170,190
  180 J2 = J2+1
      J1 = J1+1
      IF (J2-N2M2) 170,170,190
  190 B(LH) = B(N2M2+1)
      CALL INDXB (IF,K-1,J1,J2)
      J2 = J1+NMP+NMP
      CALL PPADD (NM+1,IERROR,AN,CN,B(J1),B(J1),B(J2))
      RETURN
C
C     ERROR RETURN
C
  210 IERROR = 4
      RETURN
  220 IERROR = 5
      RETURN
      END
      SUBROUTINE TQLRT0 (N,D,E2,IERR)
C
      INTEGER         I          ,J          ,L          ,M          ,
     1                N          ,II         ,L1         ,MML        ,
     2                IERR
      REAL            D(N)       ,E2(N)
      REAL            B          ,C          ,F          ,G          ,
     1                H          ,P          ,R          ,S          ,
     2                MACHEP
C
      COMMON /CBLKT/  NPP        ,K          ,MACHEP     ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE EISPACK SUBROUTINE
C     TQLRAT. THE SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E2 CONTAINS THE                SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        E2 HAS BEEN DESTROYED,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C                **********
C
      IERR = 0
      IF (N .EQ. 1) GO TO 150
C
      DO  10 I=2,N
         E2(I-1) = E2(I)*E2(I)
   10 CONTINUE
C
      F = 0.0
      B = 0.0
      E2(N) = 0.0
C
      DO 120 L=1,N
         J = 0
         H = MACHEP*(ABS(D(L))+SQRT(E2(L)))
         IF (B .GT. H) GO TO  20
         B = H
         C = B*B
C
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
C
   20    DO  30 M=L,N
            IF (E2(M) .LE. C) GO TO  40
C
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
C
   30    CONTINUE
C
   40    IF (M .EQ. L) GO TO  80
   50    IF (J .EQ. 30) GO TO 140
         J = J+1
C
C     ********** FORM SHIFT **********
C
         L1 = L+1
         S = SQRT(E2(L))
         G = D(L)
         P = (D(L1)-G)/(2.0*S)
         R = SQRT(P*P+1.0)
         D(L) = S/(P+SIGN(R,P))
         H = G-D(L)
C
         DO  60 I=L1,N
            D(I) = D(I)-H
   60    CONTINUE
C
         F = F+H
C
C     ********** RATIONAL QL TRANSFORMATION **********
C
         G = D(M)
         IF (G .EQ. 0.0) G = B
         H = G
         S = 0.0
         MML = M-L
C
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
C
         DO  70 II=1,MML
            I = M-II
            P = G*H
            R = P+E2(I)
            E2(I+1) = S*R
            S = E2(I)/R
            D(I+1) = H+S*(H+D(I))
            G = D(I)-E2(I)/G
            IF (G .EQ. 0.0) G = B
            H = G*P/R
   70    CONTINUE
C
         E2(L) = S*G
         D(L) = H
C
C     ********** GUARD AGAINST UNDERFLOWED H **********
C
         IF (H .EQ. 0.0) GO TO  80
         IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO  80
         E2(L) = H*E2(L)
         IF (E2(L) .NE. 0.0) GO TO  50
   80    P = D(L)+F
C
C     ********** ORDER EIGENVALUES **********
C
         IF (L .EQ. 1) GO TO 100
C
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
C
         DO  90 II=2,L
            I = L+2-II
            IF (P .GE. D(I-1)) GO TO 110
            D(I) = D(I-1)
   90    CONTINUE
C
  100    I = 1
  110    D(I) = P
  120 CONTINUE
C
      IF (ABS(D(N)) .GE. ABS(D(1))) GO TO 150
      NHALF = N/2
      DO 130 I=1,NHALF
         NTOP = N-I
         DHOLD = D(I)
         D(I) = D(NTOP+1)
         D(NTOP+1) = DHOLD
  130 CONTINUE
      GO TO 150
C
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
C
  140 IERR = L
  150 RETURN
      END
      SUBROUTINE PPADD (N,IERROR,A,C,CBP,BP,BH)
C
C     PPADD COMPUTES THE EIGENVALUES OF THE PERIODIC TRIDIAGONAL MATRIX
C     WITH COEFFICIENTS AN,BN,CN
C
C N   IS THE ORDER OF THE BH AND BP POLYNOMIALS.
C     ON OUTPUT BP CONTAINS THE EIGENVALUES.
C CBP IS THE SAME AS BP EXCEPT TYPE COMPLEX.
C BH  IS USED TO TEMPORARILY STORE THE ROOTS OF THE B HAT POLYNOMIAL
C     WHICH ENTERS THROUGH BP.
C
      COMPLEX         CF         ,CX         ,FSG        ,HSG        ,
     1                DD         ,F          ,FP         ,FPP        ,
     2                CDIS       ,R1         ,R2         ,R3         ,
     3                CBP
      DIMENSION       A(*)       ,C(*)       ,BP(*)      ,BH(*)      ,
     1                CBP(*)
      EXTERNAL        PSGF       ,PPSPF      ,PPSGF
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
      SCNV = SQRT(CNV)
      IZ = N
      IZM = IZ-1
      IZM2 = IZ-2
      IF (BP(N)-BP(1))  10,420, 30
   10 DO  20 J=1,N
         NT = N-J
         BH(J) = BP(NT+1)
   20 CONTINUE
      GO TO  50
   30 DO  40 J=1,N
         BH(J) = BP(J)
   40 CONTINUE
   50 NCMPLX = 0
      MODIZ = MOD(IZ,2)
      IS = 1
      IF (MODIZ)  60, 70, 60
   60 IF (A(1)) 100,420, 70
   70 XL = BH(1)
      DB = BH(3)-BH(1)
   80 XL = XL-DB
      IF (PSGF(XL,IZ,C,A,BH))  80, 80, 90
   90 SGN = -1.
      CBP(1) = CMPLX(BSRH(XL,BH(1),IZ,C,A,BH,PSGF,SGN),0.)
      IS = 2
  100 IF = IZ-1
      IF (MODIZ) 110,120,110
  110 IF (A(1)) 120,420,150
  120 XR = BH(IZ)
      DB = BH(IZ)-BH(IZ-2)
  130 XR = XR+DB
      IF (PSGF(XR,IZ,C,A,BH)) 130,140,140
  140 SGN = 1.
      CBP(IZ) = CMPLX(BSRH(BH(IZ),XR,IZ,C,A,BH,PSGF,SGN),0.)
      IF = IZ-2
  150 DO 360 IG=IS,IF,2
         XL = BH(IG)
         XR = BH(IG+1)
         SGN = -1.
         XM = BSRH(XL,XR,IZ,C,A,BH,PPSPF,SGN)
         PSG = PSGF(XM,IZ,C,A,BH)
         IF (ABS(PSG)-EPS) 180,180,160
  160    IF (PSG*PPSGF(XM,IZ,C,A,BH)) 170,180,190
C
C     CASE OF A REAL ZERO
C
  170    SGN = 1.
         CBP(IG) = CMPLX(BSRH(BH(IG),XM,IZ,C,A,BH,PSGF,SGN),0.)
         SGN = -1.
         CBP(IG+1) = CMPLX(BSRH(XM,BH(IG+1),IZ,C,A,BH,PSGF,SGN),0.)
         GO TO 360
C
C     CASE OF A MULTIPLE ZERO
C
  180    CBP(IG) = CMPLX(XM,0.)
         CBP(IG+1) = CMPLX(XM,0.)
         GO TO 360
C
C     CASE OF A COMPLEX ZERO
C
  190    IT = 0
         ICV = 0
         CX = CMPLX(XM,0.)
  200    FSG = (1.,0.)
         HSG = (1.,0.)
         FP = (0.,0.)
         FPP = (0.,0.)
         DO 210 J=1,IZ
            DD = 1./(CX-BH(J))
            FSG = FSG*A(J)*DD
            HSG = HSG*C(J)*DD
            FP = FP+DD
            FPP = FPP-DD*DD
  210    CONTINUE
         IF (MODIZ) 230,220,230
  220    F = (1.,0.)-FSG-HSG
         GO TO 240
  230    F = (1.,0.)+FSG+HSG
  240    I3 = 0
         IF (CABS(FP)) 260,260,250
  250    I3 = 1
         R3 = -F/FP
  260    I2 = 0
         IF (CABS(FPP)) 320,320,270
  270    I2 = 1
         CDIS = CSQRT(FP**2-2.*F*FPP)
         R1 = CDIS-FP
         R2 = -FP-CDIS
         IF (CABS(R1)-CABS(R2)) 290,290,280
  280    R1 = R1/FPP
         GO TO 300
  290    R1 = R2/FPP
  300    R2 = 2.*F/FPP/R1
         IF (CABS(R2) .LT. CABS(R1)) R1 = R2
         IF (I3) 330,330,310
  310    IF (CABS(R3) .LT. CABS(R1)) R1 = R3
         GO TO 330
  320    R1 = R3
  330    CX = CX+R1
         IT = IT+1
         IF (IT .GT. 50) GO TO 420
         IF (CABS(R1) .GT. SCNV) GO TO 200
         IF (ICV) 340,340,350
  340    ICV = 1
         GO TO 200
  350    CBP(IG) = CX
         CBP(IG+1) = CONJG(CX)
  360 CONTINUE
      IF (CABS(CBP(N))-CABS(CBP(1))) 370,420,390
  370 NHALF = N/2
      DO 380 J=1,NHALF
         NT = N-J
         CX = CBP(J)
         CBP(J) = CBP(NT+1)
         CBP(NT+1) = CX
  380 CONTINUE
  390 NCMPLX = 1
      DO 400 J=2,IZ
         IF (AIMAG(CBP(J))) 430,400,430
  400 CONTINUE
      NCMPLX = 0
      DO 410 J=2,IZ
         BP(J) = REAL(CBP(J))
  410 CONTINUE
      GO TO 430
  420 IERROR = 4
  430 CONTINUE
      RETURN
      END
      FUNCTION PSGF (X,IZ,C,A,BH)
      DIMENSION       A(*)       ,C(*)       ,BH(*)
      FSG = 1.
      HSG = 1.
      DO  10 J=1,IZ
         DD = 1./(X-BH(J))
         FSG = FSG*A(J)*DD
         HSG = HSG*C(J)*DD
   10 CONTINUE
      IF (MOD(IZ,2))  30, 20, 30
   20 PSGF = 1.-FSG-HSG
      RETURN
   30 PSGF = 1.+FSG+HSG
      RETURN
      END
      FUNCTION BSRH (XLL,XRR,IZ,C,A,BH,F,SGN)
      DIMENSION       A(*)       ,C(*)       ,BH(*)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
      XL = XLL
      XR = XRR
      DX = .5*ABS(XR-XL)
   10 X = .5*(XL+XR)
      IF (SGN*F(X,IZ,C,A,BH))  30, 50, 20
   20 XR = X
      GO TO  40
   30 XL = X
   40 DX = .5*DX
      IF (DX-CNV)  50, 50, 10
   50 BSRH = .5*(XL+XR)
      RETURN
      END
      FUNCTION PPSGF (X,IZ,C,A,BH)
      DIMENSION       A(*)       ,C(*)       ,BH(*)
      SUM = 0.
      DO  10 J=1,IZ
         SUM = SUM-1./(X-BH(J))**2
   10 CONTINUE
      PPSGF = SUM
      RETURN
      END
      FUNCTION PPSPF (X,IZ,C,A,BH)
      DIMENSION       A(*)       ,C(*)       ,BH(*)
      SUM = 0.
      DO  10 J=1,IZ
         SUM = SUM+1./(X-BH(J))
   10 CONTINUE
      PPSPF = SUM
      RETURN
      END
      SUBROUTINE URGET (N, IBEG, IEND, IX, L, IERR)
C-----------------------------------------------------------------------
C
C               UNIFORM RANDOM SELECTION OF VALUES FROM
C                       A FINITE SET OF INTEGERS
C
C                           ----------------
C
C     URGET SELECTS N VALUES FROM THE SET OF INTEGERS FROM IBEG TO
C     IEND WHERE IBEG .LT. IEND. THE SELECTION IS PERFORMED SO THAT
C     ANY INTEGER IS EQUALLY LIKELY TO OCCUR WITH PROABILITY 1/M
C     WHERE M = IEND - IBEG + 1. AS N BECOMES LARGE THE MEAN AND
C     VARIANCE OF THE VALUES WILL CLOSELY APPROXIMATE THE MEAN AND
C     VARIANCE OF THE DISCRETE UNIFORM DISTRIBUTION WHERE
C
C               MEAN = IBEG + (IEND - IBEG)/2
C
C               VARIANCE = (M**2 - 1)/12 .
C
C     INPUT...
C
C       N     - NUMBER OF VARIATES TO BE GENERATED
C       IBEG  - LOWER LIMIT OF GENERATION INTERVAL
C       IEND  - UPPER LIMIT OF GENERATION INTERVAL
C       IX    - INTEGER SEED USED TO INITIALIZE THE
C               SEQUENCE OF VARIATES GENERATED
C
C     OUTPUT...
C
C       IX    - SEED FOR OBTAINING MORE VARIATES
C       L     - OUTPUT ARRAY OF DIMENSION N CONTAINING
C               THE GENERATED INTEGERS
C       IERR  - INPUT ERROR FLAG
C               ( 0 - NO INPUT ERRORS
C                 1 - N .LE. 0
C                 2 - IBEG .GE. IEND  OR  M .GE. P.
C                 3 - SEED OUT OF RANGE )
C
C-----------------------------------------------------------------------
      INTEGER L(N)
      INTEGER A, B15, B16, FHI, P, XALO, XHI
      DOUBLE PRECISION C, M, S, T
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C     S = 1/(P-1)   (IT IS ASSUMED THAT THE ARITHMETIC BEING
C                    USED IS ACCURATE TO AT LEAST 14 DIGITS.
C                    S HAS BEEN SET TO A VALUE SLIGHTLY LESS
C                    THAN 1/(P-1) TO ENSURE THAT ROUNDING
C                    ERROR DOES NOT PRODUCE VARIATES THAT
C                    EXCEED IEND.)
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA S /.4656612877413D-09/
C-------------------
      IF (N .LE. 0) GO TO 100
      IF (IBEG .GE. IEND) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. P) GO TO 120
      M = IEND - IBEG + 1
      T = P
      IF (M .GE. T) GO TO 110
C
      IERR = 0
      C = M*S
      DO 10 I = 1,N
C
C        USE THE LINUS SCHRAGE CODE TO OBTAIN THE NEXT SEED IX.
C
C        REFERENCE. SCHRAGE, LINUS, A MORE PORTABLE FORTRAN
C        RANDOM NUMBER GENERATOR, ACM TRANS. MATH SOFTWARE 5
C        (1979), PP. 132-138.
C
         XHI = IX/B16
         XALO = (IX - XHI*B16)*A
         LEFTLO = XALO/B16
         FHI = XHI*A + LEFTLO
         K = FHI/B15
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
         IF (IX .LT. 0) IX = IX + P
C
C        MAP IX TO AN INTEGER IN THE CLOSED INTERVAL (IBEG,IEND).
C        THIS MAPPING IS 1-1 ONLY WHEN M = P - 1, IN WHICH CASE
C        IX IS MAPPED TO THE VALUE (IBEG - 1) + IX.
C
         T = IX
         K = C*T
         L(I) = IBEG + K
   10 CONTINUE
      RETURN
C
C                         ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
      END
      SUBROUTINE URNG (IX, X, N, IERR)
      REAL X(N)
C-----------------------------------------------------------------------
C         UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION
C
C                       IX = IX*A MOD P
C
C     IT IS ASSUMED THAT 0 .LT. IX .LT. P
C-----------------------------------------------------------------------
C     WRITTEN BY
C        LINUS SCHRAGE
C        UNIVERSITY OF CHICAGO
C     ADAPTED BY A.H. MORRIS (NSWC)
C-------------------
      INTEGER A, B15, B16, FHI, P, XALO, XHI
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA S/.465661E-09/
C-------------------
      IF (N .LE. 0) GO TO 100
      IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110
      IERR = 0
      DO 10 L = 1,N
C
C                 GET 15 HIGH ORDER BITS OF IX
C
         XHI = IX/B16
C
C           GET 16 LOWER BITS OF IX AND MULTIPLY WITH A
C
         XALO = (IX - XHI*B16)*A
C
C             GET 15 HIGH ORDER BITS OF THE PRODUCT
C
         LEFTLO = XALO/B16
C
C               FORM THE 31 HIGHEST BITS OF A*IX
C
         FHI = XHI*A + LEFTLO
C
C           OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX
C
         K = FHI/B15
C
C             ASSEMBLE ALL THE PARTS AND PRESUBTRACT P
C                  THE PARENTHESES ARE ESSENTIAL
C
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
C
C                      ADD P IF NECESSARY
C
         IF (IX .LT. 0) IX = IX + P
C
C     RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1.
C     THE SCALE FACTOR S IS SELECTED TO BE AS NEAR 1/P AS IS
C     APPROPRIATE IN ORDER THAT THE FLOATING VALUE FOR IX = 1,
C     NAMELY S, BE ROUGHLY THE SAME DISTANCE FROM 0 AS (P-1)*S
C     IS FROM 1. THE CURRENT VALUE FOR S ASSURES US THAT X(L)
C     IS LESS THAN 1 FOR ANY FLOATING POINT ARITHMETIC OF 6
C     OR MORE DIGITS.
C
         T = IX
         X(L) = S*T
   10 CONTINUE
      RETURN
C
C                         ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE DURNG (IX, X, N, IERR)
      DOUBLE PRECISION X(N)
C-----------------------------------------------------------------------
C         UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION
C
C                       IX = IX*A MOD P
C
C     IT IS ASSUMED THAT 0 .LT. IX .LT. P
C-----------------------------------------------------------------------
C     WRITTEN BY
C        LINUS SCHRAGE
C        UNIVERSITY OF CHICAGO
C     ADAPTED BY A.H. MORRIS (NSWC)
C-------------------
      INTEGER A, B15, B16, FHI, P, XALO, XHI
      DOUBLE PRECISION S, T
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA S/.465661D-09/
C-------------------
      IF (N .LE. 0) GO TO 100
      IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110
      IERR = 0
      DO 10 L = 1,N
C
C                 GET 15 HIGH ORDER BITS OF IX
C
         XHI = IX/B16
C
C           GET 16 LOWER BITS OF IX AND MULTIPLY WITH A
C
         XALO = (IX - XHI*B16)*A
C
C             GET 15 HIGH ORDER BITS OF THE PRODUCT
C
         LEFTLO = XALO/B16
C
C               FORM THE 31 HIGHEST BITS OF A*IX
C
         FHI = XHI*A + LEFTLO
C
C           OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX
C
         K = FHI/B15
C
C             ASSEMBLE ALL THE PARTS AND PRESUBTRACT P
C                  THE PARENTHESES ARE ESSENTIAL
C
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
C
C                      ADD P IF NECESSARY
C
         IF (IX .LT. 0) IX = IX + P
C
C     RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1.
C     THE SCALE FACTOR S IS SELECTED TO BE AS NEAR 1/P AS IS
C     APPROPRIATE IN ORDER THAT THE FLOATING VALUE FOR IX = 1,
C     NAMELY S, BE ROUGHLY THE SAME DISTANCE FROM 0 AS (P-1)*S
C     IS FROM 1. THE CURRENT VALUE FOR S ASSURES US THAT X(L)
C     IS LESS THAN 1 FOR ANY DOUBLE PRECISION ARITHMETIC.
C
         T = IX
         X(L) = S*T
   10 CONTINUE
      RETURN
C
C                         ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE URNG0 (IX, U, V)
C-----------------------------------------------------------------------
C       UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION
C
C                       IX = IX*A MOD P
C
C     U IS THE UNIFORM VARIATE THAT IS GENERATED AND V = 1 - U.
C     U AND V ARE POSITIVE. IT IS ASSUMED THAT 1 .LE. IX .LT. P.
C-----------------------------------------------------------------------
C     WRITTEN BY
C        LINUS SCHRAGE
C        UNIVERSITY OF CHICAGO
C     ADAPTED BY A.H. MORRIS (NSWC)
C-------------------
      INTEGER A, B15, B16, FHI, P, P0, XALO, XHI
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C     DATA P0/2**30 - 1/
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA P0/1073741823/
C-------------------
C
C                 GET 15 HIGH ORDER BITS OF IX
C
      XHI = IX/B16
C
C           GET 16 LOWER BITS OF IX AND MULTIPLY WITH A
C
      XALO = (IX - XHI*B16)*A
C
C             GET 15 HIGH ORDER BITS OF THE PRODUCT
C
      LEFTLO = XALO/B16
C
C               FORM THE 31 HIGHEST BITS OF A*IX
C
      FHI = XHI*A + LEFTLO
C
C           OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX
C
      K = FHI/B15
C
C             ASSEMBLE ALL THE PARTS AND PRESUBTRACT P
C                  THE PARENTHESES ARE ESSENTIAL
C
      IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
C
C                      ADD P IF NECESSARY
C
      IF (IX .LT. 0) IX = IX + P
C
C         RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1
C
      T = P
      IF (IX .GT. P0) GO TO 10
         U = IX
         U = U/T
         V = 0.5 + (0.5 - U)
         RETURN
   10 V = P - IX
      V = V/T
      U = 0.5 + (0.5 - V)
      RETURN
      END
      SUBROUTINE DURNG0 (IX, U, V)
C-----------------------------------------------------------------------
C       UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION
C
C                       IX = IX*A MOD P
C
C     U IS THE UNIFORM VARIATE THAT IS GENERATED AND V = 1 - U.
C     U AND V ARE POSITIVE. IT IS ASSUMED THAT 1 .LE. IX .LT. P.
C-----------------------------------------------------------------------
C     WRITTEN BY
C        LINUS SCHRAGE
C        UNIVERSITY OF CHICAGO
C     ADAPTED BY A.H. MORRIS (NSWC)
C-------------------
      DOUBLE PRECISION U, V, T
      INTEGER A, B15, B16, FHI, P, P0, XALO, XHI
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C     DATA P0/2**30 - 1/
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA P0/1073741823/
C-------------------
C
C                 GET 15 HIGH ORDER BITS OF IX
C
      XHI = IX/B16
C
C           GET 16 LOWER BITS OF IX AND MULTIPLY WITH A
C
      XALO = (IX - XHI*B16)*A
C
C             GET 15 HIGH ORDER BITS OF THE PRODUCT
C
      LEFTLO = XALO/B16
C
C               FORM THE 31 HIGHEST BITS OF A*IX
C
      FHI = XHI*A + LEFTLO
C
C           OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX
C
      K = FHI/B15
C
C             ASSEMBLE ALL THE PARTS AND PRESUBTRACT P
C                  THE PARENTHESES ARE ESSENTIAL
C
      IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
C
C                      ADD P IF NECESSARY
C
      IF (IX .LT. 0) IX = IX + P
C
C         RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1
C
      T = P
      IF (IX .GT. P0) GO TO 10
         U = IX
         U = U/T
         V = 0.5D0 + (0.5D0 - U)
         RETURN
   10 V = P - IX
      V = V/T
      U = 0.5D0 + (0.5D0 - V)
      RETURN
      END
      SUBROUTINE URNG1 (IX, U, V, D)
C-----------------------------------------------------------------------
C       UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION
C
C                       IX = IX*A MOD P
C
C     U IS THE UNIFORM VARIATE THAT IS GENERATED AND V = 1 - U.
C     U AND V ARE POSITIVE AND D = U - 0.5. IT IS ASSUMED THAT
C     1 .LE. IX .LT. P.
C-----------------------------------------------------------------------
C     WRITTEN BY
C        LINUS SCHRAGE
C        UNIVERSITY OF CHICAGO
C     ADAPTED BY A.H. MORRIS (NSWC)
C-------------------
      INTEGER A, B15, B16, FHI, P, P0, XALO, XHI
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C     DATA P0/2**30 - 1/
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA P0/1073741823/
C-------------------
C
C                 GET 15 HIGH ORDER BITS OF IX
C
      XHI = IX/B16
C
C           GET 16 LOWER BITS OF IX AND MULTIPLY WITH A
C
      XALO = (IX - XHI*B16)*A
C
C             GET 15 HIGH ORDER BITS OF THE PRODUCT
C
      LEFTLO = XALO/B16
C
C               FORM THE 31 HIGHEST BITS OF A*IX
C
      FHI = XHI*A + LEFTLO
C
C           OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX
C
      K = FHI/B15
C
C             ASSEMBLE ALL THE PARTS AND PRESUBTRACT P
C                  THE PARENTHESES ARE ESSENTIAL
C
      IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
C
C                      ADD P IF NECESSARY
C
      IF (IX .LT. 0) IX = IX + P
C
C         RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1
C
      J = P - IX
      T = P
      D = IX - J
      D = 0.5*(D/T)
      IF (IX .GT. P0) GO TO 10
         U = IX
         U = U/T
         V = 0.5 + (0.5 - U)
         RETURN
   10 V = J
      V = V/T
      U = 0.5 + (0.5 - V)
      RETURN
      END
      SUBROUTINE DURNG1 (IX, U, V, D)
C-----------------------------------------------------------------------
C       UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION
C
C                       IX = IX*A MOD P
C
C     U IS THE UNIFORM VARIATE THAT IS GENERATED AND V = 1 - U.
C     U AND V ARE POSITIVE AND D = U - 0.5. IT IS ASSUMED THAT
C     1 .LE. IX .LT. P.
C-----------------------------------------------------------------------
C     WRITTEN BY
C        LINUS SCHRAGE
C        UNIVERSITY OF CHICAGO
C     ADAPTED BY A.H. MORRIS (NSWC)
C-------------------
      DOUBLE PRECISION U, V, D, T
      INTEGER A, B15, B16, FHI, P, P0, XALO, XHI
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C     DATA P0/2**30 - 1/
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA P0/1073741823/
C-------------------
C
C                 GET 15 HIGH ORDER BITS OF IX
C
      XHI = IX/B16
C
C           GET 16 LOWER BITS OF IX AND MULTIPLY WITH A
C
      XALO = (IX - XHI*B16)*A
C
C             GET 15 HIGH ORDER BITS OF THE PRODUCT
C
      LEFTLO = XALO/B16
C
C               FORM THE 31 HIGHEST BITS OF A*IX
C
      FHI = XHI*A + LEFTLO
C
C           OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX
C
      K = FHI/B15
C
C             ASSEMBLE ALL THE PARTS AND PRESUBTRACT P
C                  THE PARENTHESES ARE ESSENTIAL
C
      IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
C
C                      ADD P IF NECESSARY
C
      IF (IX .LT. 0) IX = IX + P
C
C         RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1
C
      J = P - IX
      T = P
      D = IX - J
      D = 0.5D0*(D/T)
      IF (IX .GT. P0) GO TO 10
         U = IX
         U = U/T
         V = 0.5D0 + (0.5D0 - U)
         RETURN
   10 V = J
      V = V/T
      U = 0.5D0 + (0.5D0 - V)
      RETURN
      END
      SUBROUTINE URNG2 (IX, X, Y, N, IERR)
C-----------------------------------------------------------------------
C
C         GENERATION OF UNIFORM RANDOM POINTS (X(I),Y(I))
C                     FOR I = 1,...,N WHERE
C
C                      0 .LT. X(I) .LT. 1
C                      0 .LT. Y(I) .LT. 1
C
C     IT IS ASSUMED THAT 0 .LT. IX .LT. P
C-----------------------------------------------------------------------
C     WRITTEN BY
C        LINUS SCHRAGE
C        UNIVERSITY OF CHICAGO
C     ADAPTED BY A.H. MORRIS (NSWC)
C-------------------
      REAL X(N), Y(N)
      INTEGER A, B15, B16, FHI, P, XALO, XHI
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA S/.465661E-09/
C-------------------
      IF (N .LE. 0) GO TO 100
      IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110
      IERR = 0
C
C         SEE THE COMMENTS IN THE SUBROUTINE URNG FOR THE
C                STATEMENTS IN THE FOLLOWING LOOP
C
      DO 10 L = 1,N
         XHI = IX/B16
         XALO = (IX - XHI*B16)*A
         LEFTLO = XALO/B16
         FHI = XHI*A + LEFTLO
         K = FHI/B15
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
         IF (IX .LT. 0) IX = IX + P
         T = IX
         X(L) = S*T
C
         XHI = IX/B16
         XALO = (IX - XHI*B16)*A
         LEFTLO = XALO/B16
         FHI = XHI*A + LEFTLO
         K = FHI/B15
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
         IF (IX .LT. 0) IX = IX + P
         T = IX
         Y(L) = S*T
   10 CONTINUE
      RETURN
C
C                         ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE DURNG2 (IX, X, Y, N, IERR)
C-----------------------------------------------------------------------
C
C         GENERATION OF UNIFORM RANDOM POINTS (X(I),Y(I))
C                     FOR I = 1,...,N WHERE
C
C                      0 .LT. X(I) .LT. 1
C                      0 .LT. Y(I) .LT. 1
C
C     IT IS ASSUMED THAT 0 .LT. IX .LT. P
C-----------------------------------------------------------------------
C     WRITTEN BY
C        LINUS SCHRAGE
C        UNIVERSITY OF CHICAGO
C     ADAPTED BY A.H. MORRIS (NSWC)
C-------------------
      DOUBLE PRECISION X(N), Y(N)
      DOUBLE PRECISION S, T
      INTEGER A, B15, B16, FHI, P, XALO, XHI
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA S/.465661D-09/
C-------------------
      IF (N .LE. 0) GO TO 100
      IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110
      IERR = 0
C
C         SEE THE COMMENTS IN THE SUBROUTINE DURNG FOR THE
C                 STATEMENTS IN THE FOLLOWING LOOP
C
      DO 10 L = 1,N
         XHI = IX/B16
         XALO = (IX - XHI*B16)*A
         LEFTLO = XALO/B16
         FHI = XHI*A + LEFTLO
         K = FHI/B15
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
         IF (IX .LT. 0) IX = IX + P
         T = IX
         X(L) = S*T
C
         XHI = IX/B16
         XALO = (IX - XHI*B16)*A
         LEFTLO = XALO/B16
         FHI = XHI*A + LEFTLO
         K = FHI/B15
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
         IF (IX .LT. 0) IX = IX + P
         T = IX
         Y(L) = S*T
   10 CONTINUE
      RETURN
C
C                         ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE RCIR (N, IX, X, Y, IERR)
C-----------------------------------------------------------------------
C
C          GENERATION OF N UNIFORM RANDOM POINTS (X(I),Y(I))
C              IN THE UNIT CIRCLE CENTERED AT THE ORIGIN
C
C-----------------------------------------------------------------------
      REAL X(N), Y(N)
C------------------
      CALL RCIR1 (N, IX, X, 1, Y, 1, IERR)
      RETURN
      END
      SUBROUTINE RCIR1 (N, IX, X, KX, Y, KY, IERR)
C-----------------------------------------------------------------------
C
C      GENERATION OF N UNIFORM RANDOM POINTS IN THE UNIT CIRCLE
C      CENTERED AT THE ORIGIN. THE ABSCISSA AND ORDINATE OF THE
C      I-TH POINT ARE STORED IN X(I1) AND Y(I2) WHERE
C
C                      I1 = 1 + KX*(I - 1)
C                      I2 = 1 + KY*(I - 1) .
C
C-----------------------------------------------------------------------
      REAL X(*), Y(*)
      INTEGER A, B15, B16, FHI, P, P0, XALO, XHI
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C     P0 = 2**30 - 1
C     S  = 2/P
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA P0/1073741823/
      DATA S/.931322E-09/
C-------------------
      IF (N .LE. 0) GO TO 100
      IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110
      IERR = 0
C
      I1 = 1
      I2 = 1
      DO 20 I = 1,N
C
C        USE THE LINUS SCHRAGE CODE TO OBTAIN NEW SEEDS IX.
C
C        REFERENCE. SCHRAGE, LINUS, A MORE PORTABLE FORTRAN
C        RANDOM NUMBER GENERATOR, ACM TRANS. MATH SOFTWARE 5
C        (1979), PP. 132-138.
C
   10    XHI = IX/B16
         XALO = (IX - XHI*B16)*A
         LEFTLO = XALO/B16
         FHI = XHI*A + LEFTLO
         K = FHI/B15
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
         IF (IX .LT. 0) IX = IX + P
         J = IX
C
         XHI = IX/B16
         XALO = (IX - XHI*B16)*A
         LEFTLO = XALO/B16
         FHI = XHI*A + LEFTLO
         K = FHI/B15
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
         IF (IX .LT. 0) IX = IX + P
C
C        SUBTRACT THE MIDPOINT P0 AND RESCALE SO THAT THE
C          UNIFORM VARIATES ARE IN THE INTERVAL (-1,1).
C
         U = J - P0
         U = S*U
         V = IX - P0
         V = S*V
C
C         CHECK IF THE POINT (U,V) IS IN THE UNIT CIRCLE
C
         R = (U*U + V*V) - 1.0
         IF (R .GE. 0.0) GO TO 10
C
C            STORE THE POINT WHEN IT IS IN THE CIRCLE
C
         X(I1) = U
         Y(I2) = V
         I1 = I1 + KX
         I2 = I2 + KY
   20 CONTINUE
      RETURN
C
C                          ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE DRCIR (N, IX, X, Y, IERR)
C-----------------------------------------------------------------------
C
C          GENERATION OF N UNIFORM RANDOM POINTS (X(I),Y(I))
C              IN THE UNIT CIRCLE CENTERED AT THE ORIGIN
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X(N), Y(N)
C------------------
      CALL DRCIR1 (N, IX, X, 1, Y, 1, IERR)
      RETURN
      END
      SUBROUTINE DRCIR1 (N, IX, X, KX, Y, KY, IERR)
C-----------------------------------------------------------------------
C
C      GENERATION OF N UNIFORM RANDOM POINTS IN THE UNIT CIRCLE
C      CENTERED AT THE ORIGIN. THE ABSCISSA AND ORDINATE OF THE
C      I-TH POINT ARE STORED IN X(I1) AND Y(I2) WHERE
C
C                      I1 = 1 + KX*(I - 1)
C                      I2 = 1 + KY*(I - 1) .
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION X(*), Y(*)
      DOUBLE PRECISION R, S, U, V
      INTEGER A, B15, B16, FHI, P, P0, XALO, XHI
C-------------------
C     DATA A/7**5/,  B15/2**15/, B16/2**16/, P/2**31 - 1/
C     P0 = 2**30 - 1
C     S  = 2/P
C-------------------
      DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
      DATA P0/1073741823/
      DATA S/.931322D-09/
C-------------------
      IF (N .LE. 0) GO TO 100
      IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110
      IERR = 0
C
      I1 = 1
      I2 = 1
      DO 20 I = 1,N
C
C        USE THE LINUS SCHRAGE CODE TO OBTAIN NEW SEEDS IX.
C
C        REFERENCE. SCHRAGE, LINUS, A MORE PORTABLE FORTRAN
C        RANDOM NUMBER GENERATOR, ACM TRANS. MATH SOFTWARE 5
C        (1979), PP. 132-138.
C
   10    XHI = IX/B16
         XALO = (IX - XHI*B16)*A
         LEFTLO = XALO/B16
         FHI = XHI*A + LEFTLO
         K = FHI/B15
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
         IF (IX .LT. 0) IX = IX + P
         J = IX
C
         XHI = IX/B16
         XALO = (IX - XHI*B16)*A
         LEFTLO = XALO/B16
         FHI = XHI*A + LEFTLO
         K = FHI/B15
         IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K
         IF (IX .LT. 0) IX = IX + P
C
C        SUBTRACT THE MIDPOINT P0 AND RESCALE SO THAT THE
C          UNIFORM VARIATES ARE IN THE INTERVAL (-1,1).
C
         U = J - P0
         U = S*U
         V = IX - P0
         V = S*V
C
C         CHECK IF THE POINT (U,V) IS IN THE UNIT CIRCLE
C
         R = (U*U + V*V) - 1.D0
         IF (R .GE. 0.D0) GO TO 10
C
C            STORE THE POINT WHEN IT IS IN THE CIRCLE
C
         X(I1) = U
         Y(I2) = V
         I1 = I1 + KX
         I2 = I2 + KY
   20 CONTINUE
      RETURN
C
C                          ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE RNOR (IX, A, N, IERR)
C-----------------------------------------------------------------------
C                 NORMAL RANDOM NUMBER GENERATOR
C-----------------------------------------------------------------------
      REAL A(N), T(2)
C---------------------
      DATA MAX /2147483647/
C---------------------
      IF (N .LE. 0) GO TO 100
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 110
      IERR = 0
C
      IF (N .EQ. 1) GO TO 20
      M = N/2
      CALL RCIR1 (M, IX, A(1), 2, A(2), 2, IERR)
      M = M + M
C
C                  OBTAIN THE FIRST M VARIATES
C
      DO 10 I = 1,M,2
         U = A(I)
         V = A(I + 1)
         R = U*U + V*V
         S = SQRT(-2.0*ALOG(R)/R)
         A(I) = S*U
         A(I + 1) = S*V
   10 CONTINUE
      IF (M .EQ. N) RETURN
C
C            OBTAIN THE LAST VARIATE (WHEN N IS ODD)
C
   20 CALL RCIR1 (1, IX, T(1), 1, T(2), 1, IERR)
      R = T(1)*T(1) + T(2)*T(2)
      S = SQRT(-2.0*ALOG(R)/R)
      A(N) = S*T(1)
      RETURN
C
C                         ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE DRNOR (IX, A, N, IERR)
C-----------------------------------------------------------------------
C                 NORMAL RANDOM NUMBER GENERATOR
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(N)
      DOUBLE PRECISION R, S, U, V, T(2)
C---------------------
      DATA MAX /2147483647/
C---------------------
      IF (N .LE. 0) GO TO 100
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 110
      IERR = 0
C
      IF (N .EQ. 1) GO TO 20
      M = N/2
      CALL DRCIR1 (M, IX, A(1), 2, A(2), 2, IERR)
      M = M + M
C
C                  OBTAIN THE FIRST M VARIATES
C
      DO 10 I = 1,M,2
         U = A(I)
         V = A(I + 1)
         R = U*U + V*V
         S = DSQRT(-2.D0*DLOG(R)/R)
         A(I) = S*U
         A(I + 1) = S*V
   10 CONTINUE
      IF (M .EQ. N) RETURN
C
C            OBTAIN THE LAST VARIATE (WHEN N IS ODD)
C
   20 CALL DRCIR1 (1, IX, T(1), 1, T(2), 1, IERR)
      R = T(1)*T(1) + T(2)*T(2)
      S = DSQRT(-2.D0*DLOG(R)/R)
      A(N) = S*T(1)
      RETURN
C
C                         ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
      END
      SUBROUTINE NRNG (IX, A, N, IERR)
C-----------------------------------------------------------------------
C                 GAUSSIAN RANDOM NUMBER GENERATOR
C-----------------------------------------------------------------------
      REAL A(N), TEMP(1)
      DATA PI2 /6.2831853071796/
C
      CALL URNG (IX,A,N,IERR)
      IF (IERR .NE. 0) RETURN
      IF (N .EQ. 1) GO TO 20
C
      M = N/2
      M = M + M
      DO 10 I = 1,M,2
         R = SQRT(-2.0*ALOG(A(I)))
         PHI = PI2*A(I+1)
         A(I) = R*COS(PHI)
   10    A(I+1) = R*SIN(PHI)
      IF (M .EQ. N) RETURN
C
   20 CALL URNG (IX,TEMP,1,IERR)
      R = SQRT(-2.0*ALOG(A(N)))
      A(N) = R*COS(PI2*TEMP(1))
      RETURN
      END
      SUBROUTINE DNRNG (IX, A, N, IERR)
C-----------------------------------------------------------------------
C                 GAUSSIAN RANDOM NUMBER GENERATOR
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(N)
      DOUBLE PRECISION PHI, PI2, R, TEMP(1)
C
      DATA PI2 /6.28318530717958647692528676656D0/
C
      CALL DURNG (IX, A, N, IERR)
      IF (IERR .NE. 0) RETURN
      IF (N .EQ. 1) GO TO 20
C
      M = N/2
      M = M + M
      DO 10 I = 1,M,2
         R = DSQRT(-2.D0*DLOG(A(I)))
         PHI = PI2*A(I+1)
         A(I) = R*DCOS(PHI)
   10    A(I+1) = R*DSIN(PHI)
      IF (M .EQ. N) RETURN
C
   20 CALL DURNG (IX, TEMP, 1, IERR)
      R = DSQRT(-2.D0*DLOG(A(N)))
      A(N) = R*DCOS(PI2*TEMP(1))
      RETURN
      END
      SUBROUTINE NRVG (MO, IX, N, M, A, FMU, X, KX, IERR)
C-----------------------------------------------------------------------
C
C           GENERATION OF N RANDOM NORMAL VECTORS OF LENGTH M
C           FROM A MULTIVARIATE NORMAL DISTRIBUTION WITH MEAN
C           VECTOR FMU AND VARIANCE-COVARIANCE MATRIX A.
C
C                          ---------------
C
C     INPUT...
C
C        MO      - INTEGER SPECIFYING IF THE ROUTINE IS
C                  BEING CALLED FOR THE FIRST TIME TO
C                  GENERATE NORMAL VECTORS FROM A MATRIX
C                  A. SET MO = 0 ON AN INITIAL CALL TO
C                  THE ROUTINE, AND MO .NE. 0 ON A LATER
C                  CALL TO GENERATE MORE VECTORS FROM
C                  THE SAME MATRIX A.
C
C        IX      - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES.
C
C        N       - NUMBER OF RANDOM VECTORS TO BE GENERATED.
C
C        M       - LENGTH OF THE DESIRED RANDOM VECTORS.
C                  IT IS ASSUMED THAT M .GE. 2. M SHOULD
C                  NOT BE MODIFIED BY THE USER ON A LATER
C                  CALL TO THE ROUTINE (WHEN MO .NE. 0).
C
C        A       - VARIANCE-COVARIANCE MATRIX OF ORDER M.
C                  A IS A SYMMETRIC POSITIVE DEFINITE MATRIX
C                  STORED IN PACKED FORM. THE ARRAY A MUST
C                  BE OF LENGTH (M*(M + 1))/2 OR LARGER.
C
C                  ON AN INITIAL CALL TO THE ROUTINE, THE
C                  LOWER TRIANGULAR MATRIX IN THE CHOLESKY
C                  DECOMPOSITION OF A REPLACES THE ORIGINAL
C                  DATA IN THE ARRAY A. A SHOULD NEVER BE
C                  MODIFIED BY THE USER ON A LATER CALL TO
C                  THE ROUTINE (WHEN MO .NE. 0).
C
C        FMU     - MEAN VECTOR OF DIMENSION M OF THE
C                  MULTIVARIATE NORMAL DISTRIBUTION
C
C        KX      - ROW DIMENSION OF THE MATRIX X (SEE THE
C                  DESCRIPTION OF X BELOW). IT IS ASSUMED
C                  THAT KX .GE. M.
C
C     OUTPUT...
C
C        IX      - SEED TO BE USED FOR OBTAINING MORE VARIATES.
C
C        X       - OUTPUT ARRAY OF DIMENSION KX BY N CONTAINING
C                  THE N GENERATED RANDOM NORMAL VECTORS. THE
C                  J-TH VECTOR IS STORED IN THE J-TH COLUMN OF
C                  X FOR J = 1,...,N.
C
C        IERR    - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - M .LE. 1  OR  M .GT. KX
C                   3 - A IS NOT POSITIVE DEFINITE
C                   4 - SEED OUT OF RANGE         )
C
C-----------------------------------------------------------------------
C
C        ***REFERENCES***
C
C     FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT
C     DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973,
C     PP. 215 - 217.
C
C     MORRISON, DONALD F., MULTIVARIATE STATISTICAL METHODS,
C     MCGRAW-HILL, NEW YORK, 1967, PP. 80 - 81.
C
C     SCHEUER, E. AND STOLLER, D. S., ON THE GENERATION OF
C     NORMAL RANDOM VECTORS, TECHNOMETRICS, VOLUME 4, MAY, 1962,
C     PP. 278 - 281.
C
C-----------------------------------------------------------------------
      REAL A(*), FMU(M), X(KX,N)
C--------------------
      DATA MAX /2147483647/
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (M .LE. 1 .OR. M .GT. KX) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130
C
C           COMPUTE THE LOWER TRIANGULAR MATRIX
C           L HAVING POSITIVE DIAGONAL ELEMENTS
C           AND SATISFYING A = L*TRANSPOSE(L).
C
      IF (MO .NE. 0) GO TO 10
      CALL SPPFA (A, M, IERR)
      IF (IERR .NE. 0) GO TO 120
C
C           GENERATE THE N RANDOM NORMAL VECTORS
C
   10 LDIM = (M*(M + 1))/2
      DO 40 J = 1,N
         CALL RNOR (IX, X(1,J), M, IERR)
C
C         OBTAIN THE COMPONENTS OF THE J-TH VECTOR
C                    IN REVERSE ORDER
C
         L0 = LDIM
         I = M
         DO 30 II = 1,M
            L0 = L0 - I
            L = L0
            SUM = 0.0
            DO 20 K = 1,I
               L = L + 1
   20          SUM = SUM + A(L)*X(K,J)
            X(I,J) = SUM + FMU(I)
            I = I - 1
   30    CONTINUE
   40 CONTINUE
      RETURN
C
C                      ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE NRVG1 (MO, IX, N, M, A, FMU, X, KX, IERR)
C-----------------------------------------------------------------------
C
C           GENERATION OF N RANDOM NORMAL VECTORS OF LENGTH M
C           FROM A MULTIVARIATE NORMAL DISTRIBUTION WITH MEAN
C           VECTOR FMU AND VARIANCE-COVARIANCE MATRIX A. IT IS
C           ASSUMED THAT A IS A DIAGONAL MATRIX.
C
C                          ---------------
C
C     INPUT...
C
C        MO      - INTEGER SPECIFYING IF THE ROUTINE IS
C                  BEING CALLED FOR THE FIRST TIME TO
C                  GENERATE NORMAL VECTORS FROM A MATRIX
C                  A. SET MO = 0 ON AN INITIAL CALL TO
C                  THE ROUTINE, AND MO .NE. 0 ON A LATER
C                  CALL TO GENERATE MORE VECTORS FROM
C                  THE SAME MATRIX A.
C
C        IX      - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES.
C
C        N       - NUMBER OF RANDOM VECTORS TO BE GENERATED.
C
C        M       - LENGTH OF THE DESIRED RANDOM VECTORS.
C                  IT IS ASSUMED THAT M .GE. 2. M SHOULD
C                  NOT BE MODIFIED BY THE USER ON A LATER
C                  CALL TO THE ROUTINE (WHEN MO .NE. 0).
C
C        A       - VARIANCE-COVARIANCE MATRIX OF ORDER M.
C                  A IS A DIAGONAL MATRIX WITH POSITIVE
C                  DIAGONAL ELEMENTS. THE DIAGONAL ELEMENTS
C                  ARE STORED IN THE ARRAY A. A IS AN ARRAY
C                  OF LENGTH M OR LARGER.
C
C                  ON AN INITIAL CALL TO THE ROUTINE, THE
C                  SQUARE ROOTS OF THE ELEMENTS OF A REPLACE
C                  THE ORIGINAL DATA IN A. A SHOULD NOT BE
C                  MODIFIED BY THE USER ON A LATER CALL TO
C                  THE ROUTINE (WHEN MO .NE. 0).
C
C        FMU     - MEAN VECTOR OF DIMENSION M OF THE
C                  MULTIVARIATE NORMAL DISTRIBUTION
C
C        KX      - ROW DIMENSION OF THE MATRIX X (SEE THE
C                  DESCRIPTION OF X BELOW). IT IS ASSUMED
C                  THAT KX .GE. M.
C
C     OUTPUT...
C
C        IX      - SEED TO BE USED FOR OBTAINING MORE VARIATES.
C
C        X       - OUTPUT ARRAY OF DIMENSION KX BY N CONTAINING
C                  THE N GENERATED RANDOM NORMAL VECTORS. THE
C                  J-TH VECTOR IS STORED IN THE J-TH COLUMN OF
C                  X FOR J = 1,...,N.
C
C        IERR    - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - M .LE. 1  OR  M .GT. KX
C                   3 - A(I) .LE. 0 FOR SOME I
C                   4 - SEED OUT OF RANGE      )
C
C-----------------------------------------------------------------------
      REAL A(M), FMU(M), X(KX,N)
C--------------------
      DATA MAX /2147483647/
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (M .LE. 1 .OR. M .GT. KX) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130
C
C        COMPUTE THE ROOTS OF THE DIAGONAL ELEMENTS
C
      IF (MO .NE. 0) GO TO 20
      DO 10 I = 1,M
         IF (A(I) .LE. 0.0) GO TO 120
         A(I) = SQRT(A(I))
   10 CONTINUE
C
C           GENERATE THE N RANDOM NORMAL VECTORS
C
   20 DO 40 J = 1,N
         CALL RNOR (IX, X(1,J), M, IERR)
         DO 30 I = 1,M
            X(I,J) = A(I)*X(I,J) + FMU(I)
   30    CONTINUE
   40 CONTINUE
      RETURN
C
C                       ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE DNRVG (MO, IX, N, M, A, FMU, X, KX, IERR)
C-----------------------------------------------------------------------
C
C           GENERATION OF N RANDOM NORMAL VECTORS OF LENGTH M
C           FROM A MULTIVARIATE NORMAL DISTRIBUTION WITH MEAN
C           VECTOR FMU AND VARIANCE-COVARIANCE MATRIX A.
C
C                          ---------------
C
C     INPUT...
C
C        MO      - INTEGER SPECIFYING IF THE ROUTINE IS
C                  BEING CALLED FOR THE FIRST TIME TO
C                  GENERATE NORMAL VECTORS FROM A MATRIX
C                  A. SET MO = 0 ON AN INITIAL CALL TO
C                  THE ROUTINE, AND MO .NE. 0 ON A LATER
C                  CALL TO GENERATE MORE VECTORS FROM
C                  THE SAME MATRIX A.
C
C        IX      - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES.
C
C        N       - NUMBER OF RANDOM VECTORS TO BE GENERATED.
C
C        M       - LENGTH OF THE DESIRED RANDOM VECTORS.
C                  IT IS ASSUMED THAT M .GE. 2. M SHOULD
C                  NOT BE MODIFIED BY THE USER ON A LATER
C                  CALL TO THE ROUTINE (WHEN MO .NE. 0).
C
C        A       - VARIANCE-COVARIANCE MATRIX OF ORDER M.
C                  A IS A SYMMETRIC POSITIVE DEFINITE MATRIX
C                  STORED IN PACKED FORM. THE ARRAY A MUST
C                  BE OF LENGTH (M*(M + 1))/2 OR LARGER.
C
C                  ON AN INITIAL CALL TO THE ROUTINE, THE
C                  LOWER TRIANGULAR MATRIX IN THE CHOLESKY
C                  DECOMPOSITION OF A REPLACES THE ORIGINAL
C                  DATA IN THE ARRAY A. A SHOULD NEVER BE
C                  MODIFIED BY THE USER ON A LATER CALL TO
C                  THE ROUTINE (WHEN MO .NE. 0).
C
C        FMU     - MEAN VECTOR OF DIMENSION M OF THE
C                  MULTIVARIATE NORMAL DISTRIBUTION
C
C        KX      - ROW DIMENSION OF THE MATRIX X (SEE THE
C                  DESCRIPTION OF X BELOW). IT IS ASSUMED
C                  THAT KX .GE. M.
C
C     OUTPUT...
C
C        IX      - SEED TO BE USED FOR OBTAINING MORE VARIATES.
C
C        X       - OUTPUT ARRAY OF DIMENSION KX BY N CONTAINING
C                  THE N GENERATED RANDOM NORMAL VECTORS. THE
C                  J-TH VECTOR IS STORED IN THE J-TH COLUMN OF
C                  X FOR J = 1,...,N.
C
C        IERR    - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - M .LE. 1  OR  M .GT. KX
C                   3 - A IS NOT POSITIVE DEFINITE
C                   4 - SEED OUT OF RANGE         )
C
C-----------------------------------------------------------------------
C
C        ***REFERENCES***
C
C     FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT
C     DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973,
C     PP. 215 - 217.
C
C     MORRISON, DONALD F., MULTIVARIATE STATISTICAL METHODS,
C     MCGRAW-HILL, NEW YORK, 1967, PP. 80 - 81.
C
C     SCHEUER, E. AND STOLLER, D. S., ON THE GENERATION OF
C     NORMAL RANDOM VECTORS, TECHNOMETRICS, VOLUME 4, MAY, 1962,
C     PP. 278 - 281.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(*), FMU(M), X(KX,N), SUM
C--------------------
      DATA MAX /2147483647/
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (M .LE. 1 .OR. M .GT. KX) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130
C
C           COMPUTE THE LOWER TRIANGULAR MATRIX
C           L HAVING POSITIVE DIAGONAL ELEMENTS
C           AND SATISFYING A = L*TRANSPOSE(L).
C
      IF (MO .NE. 0) GO TO 10
      CALL DPPFA (A, M, IERR)
      IF (IERR .NE. 0) GO TO 120
C
C           GENERATE THE N RANDOM NORMAL VECTORS
C
   10 LDIM = (M*(M + 1))/2
      DO 40 J = 1,N
         CALL DRNOR (IX, X(1,J), M, IERR)
C
C         OBTAIN THE COMPONENTS OF THE J-TH VECTOR
C                    IN REVERSE ORDER
C
         L0 = LDIM
         I = M
         DO 30 II = 1,M
            L0 = L0 - I
            L = L0
            SUM = 0.D0
            DO 20 K = 1,I
               L = L + 1
   20          SUM = SUM + A(L)*X(K,J)
            X(I,J) = SUM + FMU(I)
            I = I - 1
   30    CONTINUE
   40 CONTINUE
      RETURN
C
C                      ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE DNRVG1 (MO, IX, N, M, A, FMU, X, KX, IERR)
C-----------------------------------------------------------------------
C
C           GENERATION OF N RANDOM NORMAL VECTORS OF LENGTH M
C           FROM A MULTIVARIATE NORMAL DISTRIBUTION WITH MEAN
C           VECTOR FMU AND VARIANCE-COVARIANCE MATRIX A. IT IS
C           ASSUMED THAT A IS A DIAGONAL MATRIX.
C
C                          ---------------
C
C     INPUT...
C
C        MO      - INTEGER SPECIFYING IF THE ROUTINE IS
C                  BEING CALLED FOR THE FIRST TIME TO
C                  GENERATE NORMAL VECTORS FROM A MATRIX
C                  A. SET MO = 0 ON AN INITIAL CALL TO
C                  THE ROUTINE, AND MO .NE. 0 ON A LATER
C                  CALL TO GENERATE MORE VECTORS FROM
C                  THE SAME MATRIX A.
C
C        IX      - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES.
C
C        N       - NUMBER OF RANDOM VECTORS TO BE GENERATED.
C
C        M       - LENGTH OF THE DESIRED RANDOM VECTORS.
C                  IT IS ASSUMED THAT M .GE. 2. M SHOULD
C                  NOT BE MODIFIED BY THE USER ON A LATER
C                  CALL TO THE ROUTINE (WHEN MO .NE. 0).
C
C        A       - VARIANCE-COVARIANCE MATRIX OF ORDER M.
C                  A IS A DIAGONAL MATRIX WITH POSITIVE
C                  DIAGONAL ELEMENTS. THE DIAGONAL ELEMENTS
C                  ARE STORED IN THE ARRAY A. A IS AN ARRAY
C                  OF LENGTH M OR LARGER.
C
C                  ON AN INITIAL CALL TO THE ROUTINE, THE
C                  SQUARE ROOTS OF THE ELEMENTS OF A REPLACE
C                  THE ORIGINAL DATA IN A. A SHOULD NOT BE
C                  MODIFIED BY THE USER ON A LATER CALL TO
C                  THE ROUTINE (WHEN MO .NE. 0).
C
C        FMU     - MEAN VECTOR OF DIMENSION M OF THE
C                  MULTIVARIATE NORMAL DISTRIBUTION
C
C        KX      - ROW DIMENSION OF THE MATRIX X (SEE THE
C                  DESCRIPTION OF X BELOW). IT IS ASSUMED
C                  THAT KX .GE. M.
C
C     OUTPUT...
C
C        IX      - SEED TO BE USED FOR OBTAINING MORE VARIATES.
C
C        X       - OUTPUT ARRAY OF DIMENSION KX BY N CONTAINING
C                  THE N GENERATED RANDOM NORMAL VECTORS. THE
C                  J-TH VECTOR IS STORED IN THE J-TH COLUMN OF
C                  X FOR J = 1,...,N.
C
C        IERR    - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - M .LE. 1  OR  M .GT. KX
C                   3 - A(I) .LE. 0 FOR SOME I
C                   4 - SEED OUT OF RANGE      )
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A(M), FMU(M), X(KX,N)
C--------------------
      DATA MAX /2147483647/
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (M .LE. 1 .OR. M .GT. KX) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130
C
C        COMPUTE THE ROOTS OF THE DIAGONAL ELEMENTS
C
      IF (MO .NE. 0) GO TO 20
      DO 10 I = 1,M
         IF (A(I) .LE. 0.D0) GO TO 120
         A(I) = DSQRT(A(I))
   10 CONTINUE
C
C           GENERATE THE N RANDOM NORMAL VECTORS
C
   20 DO 40 J = 1,N
         CALL DRNOR (IX, X(1,J), M, IERR)
         DO 30 I = 1,M
            X(I,J) = A(I)*X(I,J) + FMU(I)
   30    CONTINUE
   40 CONTINUE
      RETURN
C
C                       ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE RANEXP (N,A,ISEED,X,IERROR)
C
C              ***SUBROUTINE PURPOSE AND DESCRIPTION***
C
C           RANEXP GENERATES N EXPONENTIAL RANDOM VARIATES FROM AN
C           EXPONENTIAL DISTRIBUTION WITH PARAMETER A (A .GT. 0).
C           A IS THE MEAN OF THE DISTRIBUTION.  HENCE, A IS INTERPRETED
C           AS THE AVERAGE RATE PER UNIT OF TIME OR THE AVERAGE TIME
C           TO FAILURE (AVERAGE LIFETIME).
C
C           FORM OF THE EXPONENTIAL PROBABILITY DENSITY FUNCTION...
C
C                   F(X) = (1/A) * EXP(-X/A)      , X .GE. 0
C                                                   A .GT. 0
C
C           MEAN AND VARIANCE OF THE EXPONENTIAL DISTRIBUTION...
C
C                    MEAN = A
C
C                    VARIANCE = A**2
C
C           ***PARAMETER LIST***
C
C           INPUT...
C
C           N       - NUMBER OF VARIATES TO BE GENERATED
C           A       - MEAN OF THE EXPONENTIAL DISTRIBUTION
C           ISEED   - INTEGER SEED USED TO INITIALIZE THE
C                     SEQUENCE OF VARIATES GENERATED
C
C           OUTPUT...
C
C           ISEED   - SEED TO BE USED ON THE NEXT CALL TO THE
C                     ROUTINE
C           X       - OUTPUT ARRAY OF DIMENSION N CONTAINING
C                     THE GENERATED REAL VARIATES
C           IERROR  - INPUT ERROR FLAG
C                     ( 0 - NO INPUT ERRORS
C                       1 - N .LE. 0
C                       2 - A .LE. 0.0
C                       3 - SEED OUT OF RANGE )
C
C           ***REFERENCE***
C
C           FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT
C           DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973,
C           P. 203.
C
      REAL X(N)
C
C        CHECK TO ENSURE THAT THE DESIRED NUMBER OF VARIATES IS WITHIN
C        ACCEPTABLE RANGE
C
      IF (N .LE. 0) GO TO 100
C
C        CHECK TO ENSURE THAT THE EXPONENTIAL PARAMETER HAS BEEN
C        PROPERLY SPECIFIED
C
      IF (A .LE. 0.0) GO TO 110
C
C        GENERATION OF UNIFORM RANDOM VARIATES
C
      CALL URNG (ISEED, X, N, IERROR)
      IF (IERROR .NE. 0) GO TO 120
C
C        LOOP WHICH GENERATES THE N DESIRED VARIATES
C
      DO 10 I=1,N
         X(I) = - A*ALOG(X(I))
   10 CONTINUE
      RETURN
C
C              ERROR RETURN
C
  100 IERROR = 1
      RETURN
  110 IERROR = 2
      RETURN
  120 IERROR = 3
      RETURN
      END
      SUBROUTINE DRNEXP (N,A,ISEED,X,IERROR)
C
C              ***SUBROUTINE PURPOSE AND DESCRIPTION***
C
C           DRNEXP GENERATES N EXPONENTIAL RANDOM VARIATES FROM AN
C           EXPONENTIAL DISTRIBUTION WITH PARAMETER A (A .GT. 0).
C           A IS THE MEAN OF THE DISTRIBUTION.  HENCE, A IS INTERPRETED
C           AS THE AVERAGE RATE PER UNIT OF TIME OR THE AVERAGE TIME
C           TO FAILURE (AVERAGE LIFETIME).
C
C           FORM OF THE EXPONENTIAL PROBABILITY DENSITY FUNCTION...
C
C                   F(X) = (1/A) * EXP(-X/A)      , X .GE. 0
C                                                   A .GT. 0
C
C           MEAN AND VARIANCE OF THE EXPONENTIAL DISTRIBUTION...
C
C                    MEAN = A
C
C                    VARIANCE = A**2
C
C           ***PARAMETER LIST***
C
C           INPUT...
C
C           N       - NUMBER OF VARIATES TO BE GENERATED
C           A       - MEAN OF THE EXPONENTIAL DISTRIBUTION
C           ISEED   - INTEGER SEED USED TO INITIALIZE THE
C                     SEQUENCE OF VARIATES GENERATED
C
C           OUTPUT...
C
C           ISEED   - SEED TO BE USED ON THE NEXT CALL TO THE
C                     ROUTINE
C           X       - OUTPUT ARRAY OF DIMENSION N CONTAINING
C                     THE GENERATED REAL VARIATES
C           IERROR  - INPUT ERROR FLAG
C                     ( 0 - NO INPUT ERRORS
C                       1 - N .LE. 0
C                       2 - A .LE. 0.0
C                       3 - SEED OUT OF RANGE )
C
C           ***REFERENCE***
C
C           FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT
C           DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973,
C           P. 203.
C
      DOUBLE PRECISION A, X(N)
C
C        CHECK TO ENSURE THAT THE DESIRED NUMBER OF VARIATES IS WITHIN
C        ACCEPTABLE RANGE
C
      IF (N .LE. 0) GO TO 100
C
C        CHECK TO ENSURE THAT THE EXPONENTIAL PARAMETER HAS BEEN
C        PROPERLY SPECIFIED
C
      IF (A .LE. 0.D0) GO TO 110
C
C        GENERATION OF UNIFORM RANDOM VARIATES
C
      CALL DURNG (ISEED, X, N, IERROR)
      IF (IERROR .NE. 0) GO TO 120
C
C        LOOP WHICH GENERATES THE N DESIRED VARIATES
C
      DO 10 I=1,N
         X(I) = - A*DLOG(X(I))
   10 CONTINUE
      RETURN
C
C              ERROR RETURN
C
  100 IERROR = 1
      RETURN
  110 IERROR = 2
      RETURN
  120 IERROR = 3
      RETURN
      END
      SUBROUTINE RGAM (IX, A, N, X, IERR)
C-----------------------------------------------------------------------
C
C               COMPUTATION OF N VARIATES X(1),...,X(N)
C               FROM THE GAMMA DISTRIBUTION HAVING THE
C                    PROBABILITY DENSITY FUNCTION
C
C                 F(T) = EXP(-T)*T**(A-1)/GAMMA(A)
C
C                        ------------------
C
C     IX IS A VARIABLE. ON INPUT IX IS A SEED FOR INITIALIZING THE
C     SEQUENCE OF VARIATES. ON OUTPUT IX IS A NEW SEED FOR OBTAINING
C     MORE VARIATES. IT IS ASSUMED THAT 1 .LE. IX .LT. 2**31 - 1.
C
C     IERR IS A VARIABLE WHICH REPORTS THE STATUS OF THE RESULTS.
C     WHEN THE SUBROUTINE TERMINATES IERR HAS ONE OF THE FOLLOWING
C     VALUES ...
C
C          IERR = 0   THE GAMMA VARIATES WERE OBTAINED.
C          IERR = 1   (INPUT ERROR) N .LE. 0
C          IERR = 2   (INPUT ERROR) A .LT. 0.1
C          IERR = 3   (INPUT ERROR) IX IS NOT A PROPER
C                      SEED.
C
C-----------------------------------------------------------------------
      REAL X(N)
C
      DATA MAX /2147483647/
C
      IF (N .LE. 0) GO TO 100
      IF (A .LT. 0.1) GO TO 110
      IF (IX .LT. 1 .OR. IX .GE. MAX) GO TO 120
      IERR = 0
C
C             THE FOLLOWING CODE ASSUMES THAT THE UNIFORM
C             VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT
C                   THE SETTING IND = -8 IS AVOIDED
C
      DO 10 I = 1,N
         CALL URNG0 (IX, U, V)
         CALL GAMINV (A, W, 0.0, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) W = 0.0
         X(I) = W
   10 CONTINUE
      RETURN
C
C                            ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
      END
      SUBROUTINE DRGAM (IX, A, N, X, IERR)
C-----------------------------------------------------------------------
C
C             COMPUTATION OF N DOUBLE PRECISION VARIATES
C             X(1),...,X(N)  FROM THE GAMMA DISTRIBUTION
C              HAVING THE PROBABILITY DENSITY FUNCTION
C
C                 F(T) = EXP(-T)*T**(A-1)/GAMMA(A)
C
C                        ------------------
C
C     IX IS A VARIABLE. ON INPUT IX IS A SEED FOR INITIALIZING THE
C     SEQUENCE OF VARIATES. ON OUTPUT IX IS A NEW SEED FOR OBTAINING
C     MORE VARIATES. IT IS ASSUMED THAT 1 .LE. IX .LT. 2**31 - 1.
C
C     IERR IS A VARIABLE WHICH REPORTS THE STATUS OF THE RESULTS.
C     WHEN THE SUBROUTINE TERMINATES IERR HAS ONE OF THE FOLLOWING
C     VALUES ...
C
C          IERR = 0   THE GAMMA VARIATES WERE OBTAINED.
C          IERR = 1   (INPUT ERROR) N .LE. 0
C          IERR = 2   (INPUT ERROR) A .LT. 0.1
C          IERR = 3   (INPUT ERROR) IX IS NOT A PROPER
C                      SEED.
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, X(N)
      DOUBLE PRECISION U, V, W
C
      DATA MAX /2147483647/
C
      IF (N .LE. 0) GO TO 100
      IF (A .LT. 0.1D0) GO TO 110
      IF (IX .LT. 1 .OR. IX .GE. MAX) GO TO 120
      IERR = 0
C
C             THE FOLLOWING CODE ASSUMES THAT THE UNIFORM
C             VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT
C                   THE SETTING IND = -8 IS AVOIDED
C
      DO 10 I = 1,N
         CALL DURNG0 (IX, U, V)
         CALL DGINV (A, W, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) W = 0.D0
         X(I) = W
   10 CONTINUE
      RETURN
C
C                            ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
      END
      SUBROUTINE RBETA (N, A, B, IX, X, IERR)
C-----------------------------------------------------------------------
C
C                GENERATION OF BETA RANDOM VARIATES
C
C                           ------------
C
C     RBETA GENERATES N VARIATES FROM THE BETA DISTRIBUTION WITH
C     PARAMETERS A AND B WHERE A .GE. 0.25 AND B .GE. 0.25. THE
C     GENERATION SCHEME IS BASED ON THE FACT THAT X1 / (X1 + X2)
C     IS A VARIATE FROM THE BETA DISTRIBUTION WHEN X1 AND X2 ARE
C     INDEPENDENT VARIATES FROM THE STANDARD GAMMA DISTRIBUTIONS
C     WITH PARAMETERS A AND B RESPECTIVELY.
C
C     FORM OF THE BETA PROBABILITY DENSITY FUNCTION USED...
C
C       F(X) = X**(A - 1) * (1 - X)**(B - 1) / BETA(A,B)
C
C              WHERE  0 .LE. X .LE. 1  AND
C              BETA(A,B) IS THE BETA FUNCTION.
C
C     MEAN AND VARIANCE OF THE BETA DISTRIBUTION...
C
C              MEAN = A / (A + B)
C
C              VARIANCE = (A * B) / ((A + B)**2 * (A + B + 1))
C
C     INPUT...
C
C        N       - NUMBER OF VARIATES TO BE GENERATED
C        A       - PARAMETER OF THE BETA DISTRIBUTION
C        B       - PARAMETER OF THE BETA DISTRIBUTION
C        IX      - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES
C
C     OUTPUT...
C
C        IX      - SEED TO BE USED FOR OBTAINING MORE
C                  VARIATES
C        X       - ARRAY OF DIMENSION N CONTAINING THE
C                  BETA VARIATES
C        IERR    - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - A OR B IS LESS THAN 0.25
C                   3 - SEED OUT OF RANGE        )
C
C-----------------------------------------------------------------------
      REAL X(N)
C--------------------
      DATA MAX /2147483647/
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (AMIN1(A,B) .LT. 0.25) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 120
      IERR = 0
C
      DO 10 I = 1,N
C
C        THE FOLLOWING CODE ASSUMES THAT THE UNIFORM
C        VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT
C        THE SETTING IND = -8 IN GAMINV IS AVOIDED.
C
         CALL URNG0 (IX, U, V)
         CALL GAMINV (A, X1, 0.0, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) X1 = 0.0
C
         CALL URNG0 (IX, U, V)
         CALL GAMINV (B, X2, 0.0, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) X2 = 0.0
C
C        IT IS REQUIRED THAT A AND B NOT BE LESS
C        THAN 0.25 SO THAT X1 + X2 IS NONZERO.
C
         X(I) = X1/(X1 + X2)
C
   10 CONTINUE
      RETURN
C
C                      ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
      END
      SUBROUTINE DRBETA (N, A, B, IX, X, IERR)
C-----------------------------------------------------------------------
C
C                         DOUBLE PRECISION
C                GENERATION OF BETA RANDOM VARIATES
C
C                           ------------
C
C     DRBETA GENERATES N DOUBLE PRECISION VARIATES FROM THE BETA
C     DISTRIBUTION WITH PARAMETERS A AND B WHERE A .GE. 0.25 AND
C     B .GE. 0.25. THE GENERATION SCHEME IS BASED ON THE FACT
C     THAT X1 / (X1 + X2) IS A VARIATE FROM THE BETA DISTRIBUTION
C     WHEN X1 AND X2 ARE INDEPENDENT VARIATES FROM THE STANDARD
C     GAMMA DISTRIBUTIONS WITH PARAMETERS A AND B RESPECTIVELY.
C
C     FORM OF THE BETA PROBABILITY DENSITY FUNCTION USED...
C
C       F(X) = X**(A - 1) * (1 - X)**(B - 1) / BETA(A,B)
C
C              WHERE  0 .LE. X .LE. 1  AND
C              BETA(A,B) IS THE BETA FUNCTION.
C
C     MEAN AND VARIANCE OF THE BETA DISTRIBUTION...
C
C              MEAN = A / (A + B)
C
C              VARIANCE = (A * B) / ((A + B)**2 * (A + B + 1))
C
C     INPUT...
C
C        N       - NUMBER OF VARIATES TO BE GENERATED
C        A       - PARAMETER OF THE BETA DISTRIBUTION
C        B       - PARAMETER OF THE BETA DISTRIBUTION
C        IX      - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES
C
C     OUTPUT...
C
C        IX      - SEED TO BE USED FOR OBTAINING MORE
C                  VARIATES
C        X       - ARRAY OF DIMENSION N CONTAINING THE
C                  BETA VARIATES
C        IERR    - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - A OR B IS LESS THAN 0.25
C                   3 - SEED OUT OF RANGE        )
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, B, X(N)
      DOUBLE PRECISION U, V, X1, X2
C--------------------
      DATA MAX /2147483647/
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (DMIN1(A,B) .LT. 0.25D0) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 120
      IERR = 0
C
      DO 10 I = 1,N
C
C        THE FOLLOWING CODE ASSUMES THAT THE UNIFORM
C        VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT
C        THE SETTING IND = -8 IN GAMINV IS AVOIDED.
C
         CALL DURNG0 (IX, U, V)
         CALL DGINV (A, X1, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) X1 = 0.D0
C
         CALL DURNG0 (IX, U, V)
         CALL DGINV (B, X2, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) X2 = 0.D0
C
C        IT IS REQUIRED THAT A AND B NOT BE LESS
C        THAN 0.25 SO THAT X1 + X2 IS NONZERO.
C
         X(I) = X1/(X1 + X2)
C
   10 CONTINUE
      RETURN
C
C                      ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
      END
      SUBROUTINE FRAN (N, A, B, IX, X, IERR)
C-----------------------------------------------------------------------
C
C          GENERATION OF VARIATES FROM THE F-DISTRIBUTION
C
C                          --------------
C
C     FRAN GENERATES N VARIATES FROM THE F-DISTRIBUTION WITH
C     PARAMETERS A AND B (CALLED THE NUMERATOR AND DENOMINATOR
C     DEGREES OF FREEDOM) WHERE A .GE. 0.5 AND B .GE. 0.5. THE
C     GENERATION SCHEME IS BASED ON THE FACT THAT (B/A)*(X1/X2)
C     IS A VARIATE FROM THE F-DISTRIBUTION WHEN X1 AND X2 ARE
C     INDEPENDENT VARIATES FROM THE STANDARD GAMMA DISTRIBUTIONS
C     WITH PARAMETERS A/2 AND B/2 RESPECTIVELY.
C
C
C     INPUT...
C
C        N       - NUMBER OF VARIATES TO BE GENERATED
C        A       - NUMERATOR DEGREES OF FREEDOM PARAMETER
C        B       - DENOMINATOR DEGREES OF FREEDOM PARAMETER
C        IX      - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES
C
C     OUTPUT...
C
C        IX      - SEED TO BE USED FOR OBTAINING MORE
C                  VARIATES
C        X       - ARRAY OF DIMENSION N CONTAINING THE
C                  F DISTRIBUTION VARIATES
C        IERR    - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - A OR B IS LESS THAN 0.5
C                   3 - B IS TOO SMALL FOR THE
C                       FLOATING ARITHMETIC USED
C                   4 - SEED OUT OF RANGE       )
C
C-----------------------------------------------------------------------
      REAL X(N)
C--------------------
      DATA MAX /2147483647/
C--------------------
C
C     ****** XMAX IS A MACHINE DEPENDENT CONSTANT. XMAX IS THE
C            LARGEST NUMBER IN THE FLOATING ARITHMETIC USED.
C
                   XMAX = SPMPAR(3)
C
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (AMIN1(A,B) .LT. 0.5) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130
      IERR = 0
C
      AHALF = 0.5*A
      BHALF = 0.5*B
      C = B/A
      BIG = 0.5*XMAX
      BOUND = AMAX1(C, 1.0)
C
      DO 10 I = 1,N
C
C        THE FOLLOWING CODE ASSUMES THAT THE UNIFORM
C        VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT
C        THE SETTING IND = -8 IN GAMINV IS AVOIDED.
C
         CALL URNG0 (IX, U, V)
         CALL GAMINV (AHALF, X1, 0.0, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) X1 = 0.0
C
         CALL URNG0 (IX, U, V)
         CALL GAMINV (BHALF, X2, 0.0, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) GO TO 120
C
C        PROTECT AGAINST OVERFLOW IN COMPUTING THE
C        VARIATE C*(X1/X2).
C
         T = X1 + X2
         X1 = X1/T
         X2 = X2/T
         IF (X2*BIG .LE. BOUND) GO TO 120
         X(I) = C * (X1/X2)
   10 CONTINUE
      RETURN
C
C                      ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE DFRAN (N, A, B, IX, X, IERR)
C-----------------------------------------------------------------------
C
C                  DOUBLE PRECISION GENERATION OF
C                 VARIATES FROM THE F-DISTRIBUTION
C
C                          --------------
C
C     DFRAN GENERATES N VARIATES FROM THE F-DISTRIBUTION WITH
C     PARAMETERS A AND B (CALLED THE NUMERATOR AND DENOMINATOR
C     DEGREES OF FREEDOM) WHERE A .GE. 0.5 AND B .GE. 0.5. THE
C     GENERATION SCHEME IS BASED ON THE FACT THAT (B/A)*(X1/X2)
C     IS A VARIATE FROM THE F-DISTRIBUTION WHEN X1 AND X2 ARE
C     INDEPENDENT VARIATES FROM THE STANDARD GAMMA DISTRIBUTIONS
C     WITH PARAMETERS A/2 AND B/2 RESPECTIVELY.
C
C
C     INPUT...
C
C        N       - NUMBER OF VARIATES TO BE GENERATED
C        A       - NUMERATOR DEGREES OF FREEDOM PARAMETER
C        B       - DENOMINATOR DEGREES OF FREEDOM PARAMETER
C        IX      - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES
C
C     OUTPUT...
C
C        IX      - SEED TO BE USED FOR OBTAINING MORE
C                  VARIATES
C        X       - ARRAY OF DIMENSION N CONTAINING THE
C                  F DISTRIBUTION VARIATES
C        IERR    - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - A OR B IS LESS THAN 0.5
C                   3 - B IS TOO SMALL FOR THE
C                       FLOATING ARITHMETIC USED
C                   4 - SEED OUT OF RANGE       )
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, B, X(N)
      DOUBLE PRECISION AHALF, BHALF, BIG, BOUND, C, T, U, V,
     *                 XMAX, X1, X2
      DOUBLE PRECISION DPMPAR
C--------------------
      DATA MAX /2147483647/
C--------------------
C
C     ****** XMAX IS A MACHINE DEPENDENT CONSTANT. XMAX IS THE
C            LARGEST NUMBER IN THE FLOATING ARITHMETIC USED.
C
                   XMAX = DPMPAR(3)
C
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (DMIN1(A,B) .LT. 0.5D0) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130
      IERR = 0
C
      AHALF = 0.5D0*A
      BHALF = 0.5D0*B
      C = B/A
      BIG = 0.5D0*XMAX
      BOUND = DMAX1(C, 1.D0)
C
      DO 10 I = 1,N
C
C        THE FOLLOWING CODE ASSUMES THAT THE UNIFORM
C        VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT
C        THE SETTING IND = -8 IN GAMINV IS AVOIDED.
C
         CALL DURNG0 (IX, U, V)
         CALL DGINV (AHALF, X1, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) X1 = 0.D0
C
         CALL DURNG0 (IX, U, V)
         CALL DGINV (BHALF, X2, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) GO TO 120
C
C        PROTECT AGAINST OVERFLOW IN COMPUTING THE
C        VARIATE C*(X1/X2).
C
         T = X1 + X2
         X1 = X1/T
         X2 = X2/T
         IF (X2*BIG .LE. BOUND) GO TO 120
         X(I) = C * (X1/X2)
   10 CONTINUE
      RETURN
C
C                      ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE TRAN (N, A, IX, X, IERR)
C-----------------------------------------------------------------------
C
C          GENERATION OF VARIATES FROM THE T-DISTRIBUTION
C
C                          --------------
C
C        TRAN GENERATES N RANDOM VARIATES FROM A T-DISTRIBUTION
C        WITH PARAMETER A (CALLED THE DEGREES OF FREEDOM) WHERE
C        A .GE. 0.5. THE GENERATION SCHEME IS BASED ON THE FACT
C        THAT X/SQRT(Y/A) IS A VARIATE FROM THE T-DISTRIBUTION
C        WHEN X IS A STANDARD NORMAL VARIATE AND Y A CHI-SQUARE
C        VARIATE WITH A DEGREES OF FREEDOM.
C
C
C        INPUT...
C
C           N    - NUMBER OF VARIATES TO BE GENERATED
C           A    - DEGREES OF FREEDOM PARAMETER
C           IX   - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES
C
C        OUTPUT...
C
C           IX   - SEED TO BE USED FOR OBTAINING MORE
C                  VARIATES
C           X    - ARRAY OF DIMENSION N CONTAINING THE
C                  T-DISTRIBUTION VARIATES
C           IERR - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - A .LT. 0.5
C                   3 - A IS TOO SMALL FOR THE
C                       FLOATING ARITHMETIC USED
C                   4 - SEED OUT OF RANGE       )
C
C-----------------------------------------------------------------------
      REAL X(N)
C--------------------
      DATA MAX /2147483647/
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (A .LT. 0.5) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130
C
      IERR = 0
      AHALF = 0.5*A
C
      DO 10 I = 1,N
C
C                    GET A NORMAL VARIATE
C
         CALL URNG1 (IX, U, V, D)
         CALL PNI (U, V, D, Z, IND)
C
C                    GET A GAMMA VARIATE
C
C        THE FOLLOWING CODE ASSUMES THAT THE UNIFORM
C        VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT
C        THE SETTING IND = -8 IN GAMINV IS AVOIDED.
C
         CALL URNG0 (IX, U, V)
         CALL GAMINV (AHALF, W, 0.0, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) GO TO 120
C
         S = SQRT(W/AHALF)
         X(I) = Z/S
   10 CONTINUE
      RETURN
C
C              ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE DTRAN (N, A, IX, X, IERR)
C-----------------------------------------------------------------------
C
C                  DOUBLE PRECISION GENERATION OF
C                 VARIATES FROM THE T-DISTRIBUTION
C
C                          --------------
C
C        DTRAN GENERATES N RANDOM VARIATES FROM A T-DISTRIBUTION
C        WITH PARAMETER A (CALLED THE DEGREES OF FREEDOM) WHERE
C        A .GE. 0.5. THE GENERATION SCHEME IS BASED ON THE FACT
C        THAT X/SQRT(Y/A) IS A VARIATE FROM THE T-DISTRIBUTION
C        WHEN X IS A STANDARD NORMAL VARIATE AND Y A CHI-SQUARE
C        VARIATE WITH A DEGREES OF FREEDOM.
C
C
C        INPUT...
C
C           N    - NUMBER OF VARIATES TO BE GENERATED
C           A    - DEGREES OF FREEDOM PARAMETER
C           IX   - INTEGER SEED USED TO INITIALIZE THE
C                  SEQUENCE OF VARIATES
C
C        OUTPUT...
C
C           IX   - SEED TO BE USED FOR OBTAINING MORE
C                  VARIATES
C           X    - ARRAY OF DIMENSION N CONTAINING THE
C                  T-DISTRIBUTION VARIATES
C           IERR - INPUT ERROR FLAG
C                  (0 - NO INPUT ERRORS
C                   1 - N .LE. 0
C                   2 - A .LT. 0.5
C                   3 - A IS TOO SMALL FOR THE
C                       FLOATING ARITHMETIC USED
C                   4 - SEED OUT OF RANGE       )
C
C-----------------------------------------------------------------------
      DOUBLE PRECISION A, X(N)
      DOUBLE PRECISION AHALF, D, S, U, V, W, Z
C--------------------
      DATA MAX /2147483647/
C--------------------
      IF (N .LE. 0) GO TO 100
      IF (A .LT. 0.5D0) GO TO 110
      IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130
C
      IERR = 0
      AHALF = 0.5D0*A
C
      DO 10 I = 1,N
C
C                    GET A NORMAL VARIATE
C
         CALL DURNG1 (IX, U, V, D)
         CALL DPNI (U, V, D, Z, IND)
C
C                    GET A GAMMA VARIATE
C
C        THE FOLLOWING CODE ASSUMES THAT THE UNIFORM
C        VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT
C        THE SETTING IND = -8 IN GAMINV IS AVOIDED.
C
         CALL DURNG0 (IX, U, V)
         CALL DGINV (AHALF, W, U, V, IND)
         IF (IND .EQ. -3 .OR. IND .EQ. -7) GO TO 120
C
         S = DSQRT(W/AHALF)
         X(I) = Z/S
   10 CONTINUE
      RETURN
C
C              ERROR RETURN
C
  100 IERR = 1
      RETURN
  110 IERR = 2
      RETURN
  120 IERR = 3
      RETURN
  130 IERR = 4
      RETURN
      END
      SUBROUTINE RMK1 (N, FMU, SIG, ALPHA, ISEED, X, IERROR)
C
C              ***SUBROUTINE PURPOSE AND DESCRIPTION***
C
C           RMK1 GENERATES AN AUTOCORRELATED SEQUENCE X OF
C           LENGTH N WHERE X IS A FIRST-ORDER MARKOV PROCESS
C           WITH PARAMETER ALPHA (ABS(ALPHA) .LT. 1). THE SEQUENCE
C           X(J) (J = 2,...,N) IS GENERATED BY
C
C                  X(J) - FMU = ALPHA*(X(J-1) - FMU) + Z(J).
C
C           Z(J) IS THE RANDOM ERROR TERM, ASSUMED TO BE NORMALLY
C           DISTRIBUTED WITH MEAN 0 AND STANDARD DEVIATION SIG
C           (SIG .GE. 0). THE GENERATION SCHEME ASSUMES THAT X IS
C           A NORMAL PROCESS WITH MEAN FMU AND VARIANCE
C
C                      SIG*SIG / (1 - ALPHA*ALPHA) .
C
C           X IS A STATIONARY PROCESS PROVIDED THAT ABS(ALPHA) .LT.
C           1. THE AUTOCORRELATION STRUCTURE OF THE SEQUENCE IS
C           CHARACTERIZED BY THE FACT THAT THE CORRELATION BETWEEN
C           TERMS BECOMES PROGRESSIVELY WEAKER WITH INCREASING LAG.
C           WE NOTE THAT A FIRST-ORDER MARKOV PROCESS IS SYNONOMOUS
C           WITH A FIRST-ORDER AUTOREGRESSIVE (AR) PROCESS.
C
C           ***PARAMETER LIST***
C
C           INPUT...
C
C           N       - LENGTH OF THE SEQUENCE TO BE GENERATED.
C                     IT IS ASSUMED THAT N .GE. 2.
C           FMU     - MEAN OF THE NORMAL PROCESS
C           SIG     - STANDARD DEVIATION OF THE NORMALLY
C                     DISTRIBUTED ERROR TERM
C           ALPHA   - VALUE OF THE MARKOV MODEL PARAMETER
C           ISEED   - INTEGER SEED USED TO INITIALIZE THE
C                     SEQUENCE OF NORMAL VARIATES GENERATED
C                     BY SUBROUTINE RNOR
C
C           OUTPUT...
C
C           ISEED   - SEED TO BE USED ON THE NEXT CALL TO THE
C                     ROUTINE
C           X       - OUTPUT ARRAY OF DIMENSION N CONTAINING
C                     THE GENERATED FIRST-ORDER MARKOV SEQUENCE
C           IERROR  - INPUT ERROR FLAG
C                     ( 0 - NO INPUT ERRORS
C                       1 - N .LE. 1
C                       2 - SIG .LT. 0
C                       3 - ABS(ALPHA) .GE. 1
C                       4 - SEED OUT OF RANGE )
C
C           ***REFERENCE***
C
C           FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT
C           DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973,
C           PP. 236 - 237.
C
      REAL X(N)
C
C        CHECK TO ENSURE THAT THE DESIRED SEQUENCE LENGTH IS WITHIN
C        ACCEPTABLE RANGE
C
      IF (N .LE. 1) GO TO 100
C
C        CHECK TO ENSURE THAT THE STANDARD DEVIATION OF THE ERROR TERM
C        IS WITHIN ACCEPTABLE RANGE
C
      IF (SIG .LE. 0.0) GO TO 110
C
C        CHECK TO ENSURE THAT THE FIRST-ORDER MARKOV MODEL
C        PARAMETER IS WITHIN THE RANGE REQUIRED TO GUARANTEE
C        PROCESS STATIONARITY
C
      IF (ABS(ALPHA) .GE. 1.0) GO TO 120
C
C        GENERATION OF STANDARD NORMAL RANDOM VARIATES
C
      CALL RNOR (ISEED,X,N,IERROR)
      IF (IERROR .NE. 0) GO TO 130
C
C        COMPUTES THE STANDARD DEVIATION OF THE INITIAL TERM OF THE
C        AUTOCORRELATED SEQUENCE
C
      C = 0.5 + (0.5 - ALPHA)
      T = 0.5 + (0.5 + ALPHA)
      SIGI = SIG/SQRT(C*T)
C
C        COMPUTES THE INITIAL TERM OF THE REQUIRED AUTOCORRELATED
C        SEQUENCE
C
      X(1) = FMU + SIGI*X(1)
C
C        GENERATES THE LAST N - 1 TERMS OF THE REQUIRED AUTOCORRELATED
C        SEQUENCE
C
      C = FMU*C
      DO 10 I=2,N
         X(I) = ALPHA*X(I-1) + C + SIG*X(I)
   10 CONTINUE
      RETURN
C
C        ERROR RETURN
C
  100 IERROR = 1
      RETURN
  110 IERROR = 2
      RETURN
  120 IERROR = 3
      RETURN
  130 IERROR = 4
      RETURN
      END
      SUBROUTINE DRMK1 (N, FMU, SIG, ALPHA, ISEED, X, IERROR)
C
C              ***SUBROUTINE PURPOSE AND DESCRIPTION***
C
C           DRMK1 GENERATES AN AUTOCORRELATED SEQUENCE X OF
C           LENGTH N WHERE X IS A FIRST-ORDER MARKOV PROCESS
C           WITH PARAMETER ALPHA (ABS(ALPHA) .LT. 1). THE SEQUENCE
C           X(J) (J = 2,...,N) IS GENERATED BY
C
C                  X(J) - FMU = ALPHA*(X(J-1) - FMU) + Z(J).
C
C           Z(J) IS THE RANDOM ERROR TERM, ASSUMED TO BE NORMALLY
C           DISTRIBUTED WITH MEAN 0 AND STANDARD DEVIATION SIG
C           (SIG .GE. 0). THE GENERATION SCHEME ASSUMES THAT X IS
C           A NORMAL PROCESS WITH MEAN FMU AND VARIANCE
C
C                      SIG*SIG / (1 - ALPHA*ALPHA) .
C
C           X IS A STATIONARY PROCESS PROVIDED THAT ABS(ALPHA) .LT.
C           1. THE AUTOCORRELATION STRUCTURE OF THE SEQUENCE IS
C           CHARACTERIZED BY THE FACT THAT THE CORRELATION BETWEEN
C           TERMS BECOMES PROGRESSIVELY WEAKER WITH INCREASING LAG.
C           WE NOTE THAT A FIRST-ORDER MARKOV PROCESS IS SYNONOMOUS
C           WITH A FIRST-ORDER AUTOREGRESSIVE (AR) PROCESS.
C
C           ***PARAMETER LIST***
C
C           INPUT...
C
C           N       - LENGTH OF THE SEQUENCE TO BE GENERATED.
C                     IT IS ASSUMED THAT N .GE. 2.
C           FMU     - MEAN OF THE NORMAL PROCESS
C           SIG     - STANDARD DEVIATION OF THE NORMALLY
C                     DISTRIBUTED ERROR TERM
C           ALPHA   - VALUE OF THE MARKOV MODEL PARAMETER
C           ISEED   - INTEGER SEED USED TO INITIALIZE THE
C                     SEQUENCE OF NORMAL VARIATES GENERATED
C                     BY SUBROUTINE DRNOR
C
C           OUTPUT...
C
C           ISEED   - SEED TO BE USED ON THE NEXT CALL TO THE
C                     ROUTINE
C           X       - OUTPUT ARRAY OF DIMENSION N CONTAINING
C                     THE GENERATED FIRST-ORDER MARKOV SEQUENCE
C           IERROR  - INPUT ERROR FLAG
C                     ( 0 - NO INPUT ERRORS
C                       1 - N .LE. 1
C                       2 - SIG .LT. 0
C                       3 - ABS(ALPHA) .GE. 1
C                       4 - SEED OUT OF RANGE )
C
C           ***REFERENCE***
C
C           FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT
C           DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973,
C           PP. 236 - 237.
C
      DOUBLE PRECISION FMU, SIG, ALPHA, X(N)
      DOUBLE PRECISION C, SIGI, T
C
C        CHECK TO ENSURE THAT THE DESIRED SEQUENCE LENGTH IS WITHIN
C        ACCEPTABLE RANGE
C
      IF (N .LE. 1) GO TO 100
C
C        CHECK TO ENSURE THAT THE STANDARD DEVIATION OF THE ERROR TERM
C        IS WITHIN ACCEPTABLE RANGE
C
      IF (SIG .LE. 0.D0) GO TO 110
C
C        CHECK TO ENSURE THAT THE FIRST-ORDER MARKOV MODEL
C        PARAMETER IS WITHIN THE RANGE REQUIRED TO GUARANTEE
C        PROCESS STATIONARITY
C
      IF (DABS(ALPHA) .GE. 1.D0) GO TO 120
C
C        GENERATION OF STANDARD NORMAL RANDOM VARIATES
C
      CALL DRNOR (ISEED,X,N,IERROR)
      IF (IERROR .NE. 0) GO TO 130
C
C        COMPUTES THE STANDARD DEVIATION OF THE INITIAL TERM OF THE
C        AUTOCORRELATED SEQUENCE
C
      C = 0.5D0 + (0.5D0 - ALPHA)
      T = 0.5D0 + (0.5D0 + ALPHA)
      SIGI = SIG/DSQRT(C*T)
C
C        COMPUTES THE INITIAL TERM OF THE REQUIRED AUTOCORRELATED
C        SEQUENCE
C
      X(1) = FMU + SIGI*X(1)
C
C        GENERATES THE LAST N - 1 TERMS OF THE REQUIRED AUTOCORRELATED
C        SEQUENCE
C
      C = FMU*C
      DO 10 I=2,N
         X(I) = ALPHA*X(I-1) + C + SIG*X(I)
   10 CONTINUE
      RETURN
C
C        ERROR RETURN
C
  100 IERROR = 1
      RETURN
  110 IERROR = 2
      RETURN
  120 IERROR = 3
      RETURN
  130 IERROR = 4
      RETURN
      END
