C   IMSL ROUTINE NAME   - MGAMAD=DGAMMA
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/DOUBLE
C
C   LATEST REVISION     - NOVEMBER 1, 1984
C
C   PURPOSE             - EVALUATE THE GAMMA FUNCTION OF A DOUBLE
C                           PRECISION ARGUMENT
C
C   USAGE               - RESULT = DGAMMA(X)
C
C   ARGUMENTS    X      - INPUT DOUBLE PRECISION ARGUMENT.
C                           DGAMMA IS SET TO MACHINE INFINITY, WITH THE
C                           PROPER SIGN, WHENEVER
C                             X IS ZERO,
C                             X IS A NEGATIVE INTEGER,
C                             ABS(X) .LE. XMIN, OR
C                             ABS(X) .GE. XMAX.
C                             XMIN IS OF THE ORDER OF 10**(-39) AND
C                             XMAX IS AT LEAST 34.8. THE EXACT VALUES
C                             OF XMIN AND XMAX MAY ALLOW LARGER RANGES
C                             FOR X ON SOME COMPUTERS.
C                             SEE THE PROGRAMMING NOTES IN THE MANUAL
C                             FOR THE EXACT VALUES.
C                DGAMMA - OUTPUT DOUBLE PRECISION VALUE OF THE GAMMA
C                           FUNCTION. DGAMMA MUST BE TYPED DOUBLE
C                           PRECISION IN THE CALLING PROGRAM.
C
C   PRECISION/HARDWARE  - DOUBLE/H32,H36
C                       - NOT AVAILABLE/H48,H60
C                         NOTE - DGAMMA MAY NOT BE SUPPLIED BY IMSL IF
C                           IT RESIDES IN THE MATHEMATICAL SUBPROGRAM
C                           LIBRARY SUPPLIED BY THE MANUFACTURER.
C
C   REQD. IMSL ROUTINES - UERTST,UGETIO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   REMARKS      AN ERROR MESSAGE PRINTED BY UERTST FROM DGAMMA SHOULD
C                BE INTERPRETED AS FOLLOWS
C                IER    - ERROR INDICATOR
C                         TERMINAL ERROR
C                           IER = 129 INDICATES THAT THE ABSOLUTE VALUE
C                             OF THE INPUT ARGUMENT X IS SPECIFIED
C                             GREATER THAN OR EQUAL TO XMAX. DGAMMA
C                             IS SET TO MACHINE INFINITY.
C                           IER = 130 INDICATES THAT THE INPUT ARGUMENT
C                             X IS SPECIFIED AS ZERO OR A NEGATIVE
C                             INTEGER OR THAT THE ABSOLUTE VALUE OF THE
C                             INPUT ARGUMENT IS LESS THAN OR EQUAL TO
C                             XMIN. DGAMMA IS SET TO MACHINE INFINITY
C                             WITH THE PROPER SIGN FOR THE DGAMMA
C                             FUNCTION. IF X IS ZERO OR AN EVEN
C                             NEGATIVE INTEGER, GAMMA HAS A NEGATIVE
C                             SIGN. OTHERWISE IT HAS A POSITIVE SIGN.
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      DOUBLE PRECISION FUNCTION DGAMMA (X)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      DOUBLE PRECISION X
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I, IER, J
      DOUBLE PRECISION, DIMENSION(9) :: P
      DOUBLE PRECISION, DIMENSION(8) :: Q
      DOUBLE PRECISION, DIMENSION(7) :: P4
      DOUBLE PRECISION::A,B,DEN,PI,T,TOP,BIG1,XINF,XMIN,Y,SIGN,R
      LOGICAL :: MFLAG
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
C                                  COEFFICIENTS FOR MINIMAX
C                                  APPROXIMATION TO GAMMA(X),
C                                  2.0 .LE. X .LE. 3.0
      DATA P(1)/ - 5.966047488753637D01/
      DATA P(2)/5.864023793062003D01/
      DATA P(3)/ - 1.364106217165365D03/
      DATA P(4)/ - 8.117569271425580D02/
      DATA P(5)/ - 1.569414683149179D04/
      DATA P(6)/ - 1.525979925758372D04/
      DATA P(7)/ - 7.264059615964330D04/
      DATA P(8)/ - 8.972275718101010D-01/
      DATA P(9)/3.349618189847578D00/
      DATA Q(1)/4.103991474182904D02/
      DATA Q(2)/ - 2.262590291514875D03/
      DATA Q(3)/2.494325576714903D03/
      DATA Q(4)/2.362106244383048D04/
      DATA Q(5)/ - 5.741873227396418D04/
      DATA Q(6)/ - 7.257239715408240D04/
      DATA Q(7)/ - 9.491399521686949D00/
      DATA Q(8)/ - 3.255006939455704D01/
C                                  COEFFICIENTS FOR MINIMAX
C                                  APPROXIMATION TO LN(GAMMA(X)),
C                                  12.0 .LE. X
      DATA P4(1)/8.40596949829D-04/
      DATA P4(2)/ - 5.9523334141881D-04/
      DATA P4(3)/7.9365078409227D-04/
      DATA P4(4)/ - 2.777777777769526D-03/
      DATA P4(5)/8.333333333333333D-02/
      DATA P4(6)/9.189385332046727D-01/
      DATA P4(7)/ - 1.7816839846D-03/
      DATA PI/3.141592653589793D0/
      DATA XINF/1.7D+38/
C                                  DGAMMA(XMIN) .APPROX. XINF
C                                  DGAMMA(BIG1) .APPROX. XINF
      DATA XMIN/5.8775D-39/
      DATA BIG1/34.844D0/
C                                  FIRST EXECUTABLE STATEMENT
      IER = 0
      MFLAG = .FALSE.
      T = X
      IF (DABS(T) <= XMIN) THEN
         IER = 130
         DGAMMA = XINF
         IF (T <= 0.0D0) DGAMMA = -XINF
      ELSE
         IF (DABS(T) >= BIG1) THEN
            IER = 129
            DGAMMA = XINF
         ELSE
            IF (T <= 0.0D0) THEN
C                                  ARGUMENT IS NEGATIVE
               MFLAG = .TRUE.
               T = -T
               R = DINT(T)
               SIGN = 1.0D0
               IF (DMOD(R,2.0D0) == 0.0D0) SIGN = -1.0D0
               R = T - R
               IF (R == 0.0D0) THEN
                  IER = 130
                  DGAMMA = XINF
                  IF (SIGN == (-1.0D0)) DGAMMA = -XINF
                  GO TO 9000
C                                  ARGUMENT IS NOT A NEGATIVE INTEGER
               ENDIF
               R = PI/DSIN(R*PI)*SIGN
               T = T + 1.0D0
C                                  EVALUATE APPROXIMATION FOR DGAMMA(T)
C                                    T .GT. XMIN
            ENDIF
            IF (T <= 12.0D0) THEN
               I = T
               A = 1.0D0
               IF (I <= 2) THEN
                  I = I + 1
                  GO TO (25,30,45) I
C                                  0.0 .LT. T .LT. 1.0
   25             CONTINUE
                  A = A/(T*(T + 1.0D0))
                  T = T + 2.0D0
                  GO TO 45
C                                  1.0 .LE. T .LT. 2.0
   30             CONTINUE
                  A = A/T
                  T = T + 1.0D0
                  GO TO 45
C                                  3.0 .LE. T .LE. 12.0
               ENDIF
               DO J = 3, I
                  T = T - 1.0D0
                  A = A*T
               END DO
C                                  2.0 .LE. T .LE. 3.0
   45          CONTINUE
               TOP = P(8)*T + P(9)
               DEN = T + Q(8)
               DO J = 1, 7
                  TOP = TOP*T + P(J)
               END DO
               DO J = 1, 7
                  DEN = DEN*T + Q(J)
               END DO
               Y = (TOP/DEN)*A
               IF (MFLAG) Y = R/Y
               DGAMMA = Y
               GO TO 9005
C                                  T .GT. 12.0
            ENDIF
            TOP = DLOG(T)
            TOP = T*(TOP - 1.0D0) - .5D0*TOP
            T = 1.0D0/T
            B = T*T
            A = P4(7)
            DO J = 1, 5
               A = A*B + P4(J)
            END DO
            Y = A*T + P4(6) + TOP
            Y = DEXP(Y)
            IF (MFLAG) Y = R/Y
            DGAMMA = Y
            GO TO 9005
         ENDIF
      ENDIF
 9000 CONTINUE
      CALL UERTST ((-IER), 6HMGAMAD)
      CALL UERTST (IER, 6HDGAMMA)
 9005 CONTINUE
      RETURN 
      END FUNCTION DGAMMA
C   IMSL ROUTINE NAME   - IBCCCU
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1982
C
C   PURPOSE             - BICUBIC SPLINE TWO-DIMENSIONAL COEFFICIENT
C                           CALCULATOR
C
C   USAGE               - CALL IBCCCU (F,X,NX,Y,NY,C,IC,WK,IER)
C
C   ARGUMENTS    F      - NX BY NY MATRIX CONTAINING THE FUNCTION
C                           VALUES. (INPUT) F(I,J) IS THE FUNCTION VALUE
C                           AT THE POINT (X(I),Y(J)) FOR I=1,...,NX AND
C                           J=1,...,NY.
C                X      - VECTOR OF LENGTH NX. (INPUT) X MUST BE
C                           ORDERED SO THAT X(I) .LT. X(I+1) FOR
C                           I=1,...,NX-1.
C                NX     - NUMBER OF ELEMENTS IN X. (INPUT) NX MUST BE
C                           .GE. 4.
C                Y      - VECTOR OF LENGTH NY. (INPUT) Y MUST BE
C                           ORDERED SO THAT Y(J) .LT. Y(J+1) FOR
C                           J=1,...,NY-1.
C                NY     - NUMBER OF ELEMENTS IN Y. (INPUT) NY MUST BE
C                           .GE. 4.
C                         NOTE - THE COORDINATE PAIRS (X(I),Y(J)), FOR
C                           I=1,...,NX AND J=1,...,NY, GIVE THE POINTS
C                           WHERE THE FUNCTION VALUES F(I,J) ARE
C                           DEFINED.
C                C      - ARRAY OF SPLINE COEFFICIENTS. (OUTPUT)
C                           C IS OF DIMENSION 2 BY NX BY 2 BY NY.
C                           AT THE POINT (X(I),Y(J))
C                             C(1,I,1,J) = S
C                             C(2,I,1,J) = DS/DX
C                             C(1,I,2,J) = DS/DY
C                             C(2,I,2,J) = D(DS/DX)/DY
C                           WHERE S(X,Y) IS THE SPLINE APPROXIMATION.
C                           (NOTE - C IS TREATED INTERNALLY AS A
C                             2 BY NX BY 2*NY ARRAY BECAUSE CERTAIN
C                             ENVIRONMENTS DO NOT PERMIT QUADRUPLY-
C                             DIMENSIONED ARRAYS.  IN THESE
C                             ENVIRONMENTS THE CALLING PROGRAM MAY
C                             DIMENSION C IN THE SAME MANNER.)
C                IC     - ROW DIMENSION OF MATRIX F AND SECOND
C                           DIMENSION OF ARRAY C EXACTLY AS
C                           SPECIFIED IN THE DIMENSION STATEMENT.
C                           (INPUT). IC MUST BE .GE. NX.
C                WK     - WORK VECTOR OF LENGTH
C                           2*NX*NY+2*MAX(NX,NY)
C                IER    - ERROR PARAMETER. (OUTPUT)
C                         TERMINAL ERROR
C                           IER = 129, IC IS LESS THAN NX
C                           IER = 130, NX IS LESS THAN 4
C                           IER = 131, NY IS LESS THAN 4
C                           IER = 132, X OR Y ARE NOT ORDERED SO THAT
C                             X(I) .LT. X(I+1) AND
C                             Y(I) .LT. Y(I+1)
C
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32
C                       - SINGLE/H36,H48,H60
C
C   REQD. IMSL ROUTINES - IBCDCU,UERTST,UGETIO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE IBCCCU(F, X, NX, Y, NY, C, IC, WK, IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NX, NY, IC, IER
      REAL, DIMENSION(IC,1) :: F
      REAL, DIMENSION(1) :: X, Y
      REAL, DIMENSION(2,IC,1) :: C
      REAL, DIMENSION(1) :: WK
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: IWK
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
C                                  FIRST EXECUTABLE STATEMENT
      IER = 129
      IF (IC < NX) GO TO 9000
      IER = 130
      IF (NX < 4) GO TO 9000
      IER = 131
      IF (NY < 4) GO TO 9000
      IWK = 2*NY*NX
      CALL IBCDCU (X, F, NX, NY, WK(IWK+1), WK, IC, NY, IER)
      IF (IER > 0) GO TO 9000
      CALL IBCDCU (Y, WK, NY, 2*NX, WK(IWK+1), C, NY, 2*IC, IER)
      IF (IER == 0) GO TO 9005
 9000 CONTINUE
      CALL UERTST (IER, 6HIBCCCU)
 9005 CONTINUE
      RETURN 
      END SUBROUTINE IBCCCU
C   IMSL ROUTINE NAME   - IBCDCU
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1982
C
C   PURPOSE             - NUCLEUS CALLED ONLY BY IMSL SUBROUTINE IBCCCU
C
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32
C                       - SINGLE/H36,H48,H60
C
C   REQD. IMSL ROUTINES - NONE REQUIRED
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE IBCDCU(TAU, GTAU, N, M, W, VS, IC1, IC2, IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER N, M, IC1, IC2, IER
      REAL, DIMENSION(N) :: TAU
      REAL, DIMENSION(IC1,1) :: GTAU
      REAL, DIMENSION(N,2) :: W
      REAL, DIMENSION(IC2,2,1) :: VS
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: J1, J2, I, JJ, JM1, JP1, J, K, LIM, LL, LP1, NM1
      REAL :: AA, BB, C1, C2, CC, DD, DTAU, G, H, RATIO, U, XILIM
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
C                                  FIRST EXECUTABLE STATEMENT
      LIM = N - 3
      NM1 = N - 1
      LP1 = LIM + 1
      IER = 132
      W(2,1) = TAU(3) - TAU(1)
      IF (W(2,1) <= 0.0) RETURN 
      VS(:M,1,1) = GTAU(1,:M)
      XILIM = TAU(1)
      IF (LIM >= 2) THEN
         XILIM = TAU(N-2)
         DO I = 2, LIM
            J = I + 1
            W(J,1) = TAU(I+2) - TAU(J)
            IF (W(J,1) <= 0.0) RETURN 
            VS(:M,1,I) = GTAU(J,:M)
         END DO
      ENDIF
      W(LP1,1) = TAU(N) - XILIM
      IF (W(LP1,1) <= 0.0) RETURN 
      VS(:M,1,LP1) = GTAU(N,:M)
      DO I = 2, LP1
         VS(:M,2,I) = (VS(:M,1,I)-VS(:M,1,I-1))/W(I,1)
      END DO
      DTAU = TAU(2) - TAU(1)
      RATIO = DTAU/W(2,1)
      W(1,2) = (RATIO - 1.)**2
      W(1,1) = RATIO*(RATIO - 1.)
      C1 = RATIO*(2.*RATIO - 3.)
      VS(:M,2,1) = (GTAU(2,:M)-GTAU(1,:M))/DTAU + VS(:M,2,2)*C1
      IF (LIM >= 2) THEN
         DO I = 2, LIM
            J = I + 1
            JJ = I - 1
            G = -W(J,1)/W(JJ,2)
            C1 = 3.*W(I,1)
            C2 = 3.*W(J,1)
            VS(:M,2,I) = G*VS(:M,2,JJ) + C1*VS(:M,2,J) + C2*VS(:M,2,I)
            W(I,2) = G*W(JJ,1) + 2.*(W(I,1)+W(J,1))
         END DO
      ENDIF
      DTAU = TAU(N-1) - XILIM
      RATIO = DTAU/W(LP1,1)
      G = -(RATIO - 1.)**2/W(LIM,2)
      W(LP1,2) = RATIO*(RATIO - 1.)
      C1 = RATIO*(2.*RATIO - 3.)
      VS(:M,2,LP1) = (GTAU(N-1,:M)-VS(:M,1,LIM))/DTAU + VS(:M,2,LP1)*C1
      W(LP1,2) = G*W(LIM,1) + W(LP1,2)
      VS(:M,2,LP1) = (G*VS(:M,2,LIM)+VS(:M,2,LP1))/W(LP1,2)
      J = LIM
      J1 = J
      J2 = MIN0(1,J1)
      DO J = J1, J2, -1
         VS(:M,2,J) = (VS(:M,2,J)-W(J,1)*VS(:M,2,J+1))/W(J,2)
      END DO
      DO K = 1, M
         DO JJ = 1, N
            J = N + 1 - JJ
            JM1 = J - 1
            IF (J == N) JM1 = J - 2
            IF (J == 1) JM1 = J
            VS(K,:,J) = VS(K,:,JM1)
         END DO
         DO J = 2, NM1, LIM
            JM1 = J - 1
            JP1 = J + 1
            IF (JM1 == 2) JM1 = 1
            IF (JP1 == NM1) JP1 = N
            H = TAU(JP1) - TAU(JM1)
            U = TAU(J) - TAU(JM1)
            AA = VS(K,1,JM1)
            BB = VS(K,2,JM1)
            CC = (3.*(VS(K,1,JP1)-VS(K,1,JM1))/H-(VS(K,2,JP1)+2.*VS(K,2,
     1         JM1)))/H
            DD = (2.*(VS(K,1,JM1)-VS(K,1,JP1))/H+(VS(K,2,JP1)+VS(K,2,JM1
     1         )))/H**2
            VS(K,1,J) = AA + U*(BB + U*(CC + DD*U))
            VS(K,2,J) = BB + U*(2.*CC + 3.*DD*U)
         END DO
      END DO
      IER = 0
      RETURN 
      END SUBROUTINE IBCDCU
C   IMSL ROUTINE NAME   - ICSCCU
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1980
C
C   PURPOSE             - CUBIC SPLINE INTERPOLATION
C                           (EASY-TO-USE VERSION)
C
C   USAGE               - CALL ICSCCU (X,Y,NX,C,IC,IER)
C
C   ARGUMENTS    X      - VECTOR OF LENGTH NX CONTAINING THE ABSCISSAE
C                           OF THE NX DATA POINTS (X(I),Y(I)) I=1,...,
C                           NX. (INPUT) X MUST BE ORDERED SO THAT
C                           X(I) .LT. X(I+1).
C                Y      - VECTOR OF LENGTH NX CONTAINING THE ORDINATES
C                           (OR FUNCTION VALUES) OF THE NX DATA POINTS.
C                           (INPUT)
C                NX     - NUMBER OF ELEMENTS IN X AND Y. (INPUT) NX
C                           MUST BE .GE. 2.
C                C      - SPLINE COEFFICIENTS. (OUTPUT) C IS AN NX-1 BY
C                           3 MATRIX. THE VALUE OF THE SPLINE
C                           APPROXIMATION AT T IS
C                           S(T) = ((C(I,3)*D+C(I,2))*D+C(I,1))*D+Y(I)
C                           WHERE X(I) .LE. T .LT. X(I+1) AND
C                           D = T-X(I).
C                IC     - ROW DIMENSION OF MATRIX C EXACTLY AS
C                           SPECIFIED IN THE DIMENSION STATEMENT IN
C                           THE CALLING PROGRAM. (INPUT)
C                IER    - ERROR PARAMETER. (OUTPUT)
C                         TERMINAL ERROR
C                           IER = 129, IC IS LESS THAN NX-1.
C                           IER = 130, NX IS LESS THAN 2.
C                           IER = 131, INPUT ABSCISSA ARE NOT ORDERED
C                             SO THAT X(1) .LT. X(2) ... .LT. X(NX).
C
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32
C                       - SINGLE/H36,H48,H60
C
C   REQD. IMSL ROUTINES - UERTST,UGETIO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1980 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE ICSCCU(X, Y, NX, C, IC, IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NX, IC, IER
      REAL, DIMENSION(NX) :: X, Y
      REAL, DIMENSION(IC,3) :: C
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: IM1, I, JJ, J, MM1, MP1, M, NM1, NM2
      REAL :: DIVDF1, DIVDF3, DTAU, G
      REAL, DIMENSION(3) :: CNX
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
C                                  FIRST EXECUTABLE STATEMENT
      NM1 = NX - 1
      IER = 129
      IF (IC < NM1) GO TO 9000
      IER = 130
      IF (NX < 2) GO TO 9000
      IER = 131
      IF (NX /= 2) THEN
C                                  COMPUTE NOT-A-KNOT SPLINE
         DO M = 2, NM1
            MM1 = M - 1
            C(M,2) = X(M) - X(MM1)
            IF (C(M,2) <= 0.0) GO TO 9000
            C(M,3) = (Y(M)-Y(MM1))/C(M,2)
         END DO
         CNX(2) = X(NX) - X(NM1)
         IF (CNX(2) <= 0.0) GO TO 9000
         CNX(3) = (Y(NX)-Y(NM1))/CNX(2)
         IER = 0
         NM2 = NX - 2
         IF (NX <= 3) THEN
            C(1,3) = CNX(2)
            C(1,2) = C(2,2) + CNX(2)
            C(1,1) = ((C(2,2)+2.*C(1,2))*C(2,3)*CNX(2)+C(2,2)**2*CNX(3))
     1         /C(1,2)
         ELSE
            C(1,3) = C(3,2)
            C(1,2) = C(2,2) + C(3,2)
            C(1,1) = ((C(2,2)+2.*C(1,2))*C(2,3)*C(3,2)+C(2,2)**2*C(3,3))
     1         /C(1,2)
            DO M = 2, NM2
               MP1 = M + 1
               MM1 = M - 1
               G = -C(MP1,2)/C(MM1,3)
               C(M,1) = G*C(MM1,1) + 3.*C(M,2)*C(MP1,3) + 3.*C(MP1,2)*C(
     1            M,3)
               C(M,3) = G*C(MM1,2) + 2.*C(M,2) + 2.*C(MP1,2)
            END DO
         ENDIF
         G = -CNX(2)/C(NM2,3)
         C(NM1,1) = G*C(NM2,1) + 3.*C(NM1,2)*CNX(3) + 3.*CNX(2)*C(NM1,3)
         C(NM1,3) = G*C(NM2,2) + 2.*C(NM1,2) + 2.*CNX(2)
         IF (NX <= 3) THEN
            CNX(1) = 2.*CNX(3)
            CNX(3) = 1.
            G = -1./C(NM1,3)
         ELSE
            G = C(NM1,2) + CNX(2)
            CNX(1) = ((CNX(2)+2.*G)*CNX(3)*C(NM1,2)+CNX(2)**2*(Y(NM1)-Y(
     1         NX-2))/C(NM1,2))/G
            G = -G/C(NM1,3)
            CNX(3) = C(NM1,2)
         ENDIF
         CNX(3) = G*C(NM1,2) + CNX(3)
         CNX(1) = (G*C(NM1,1)+CNX(1))/CNX(3)
         C(NM1,1) = (C(NM1,1)-C(NM1,2)*CNX(1))/C(NM1,3)
         DO JJ = 1, NM2
            J = NM1 - JJ
            C(J,1) = (C(J,1)-C(J,2)*C(J+1,1))/C(J,3)
         END DO
         DO I = 2, NM1
            IM1 = I - 1
            DTAU = C(I,2)
            DIVDF1 = (Y(I)-Y(IM1))/DTAU
            DIVDF3 = C(IM1,1) + C(I,1) - 2.*DIVDF1
            C(IM1,2) = (DIVDF1 - C(IM1,1)-DIVDF3)/DTAU
            C(IM1,3) = DIVDF3/DTAU**2
         END DO
         DTAU = CNX(2)
         DIVDF1 = (Y(NX)-Y(NM1))/DTAU
         DIVDF3 = C(NM1,1) + CNX(1) - 2.*DIVDF1
         C(NM1,2) = (DIVDF1 - C(NM1,1)-DIVDF3)/DTAU
         C(NM1,3) = DIVDF3/DTAU**2
         GO TO 9005
      ENDIF
      IF (X(1) >= X(2)) GO TO 9000
      IER = 0
      C(1,1) = (Y(2)-Y(1))/(X(2)-X(1))
      C(1,2) = 0.0
      C(1,3) = 0.0
      GO TO 9005
 9000 CONTINUE
      CALL UERTST (IER, 6HICSCCU)
 9005 CONTINUE
      RETURN 
      END SUBROUTINE ICSCCU
C   IMSL ROUTINE NAME   - ICSEVU
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JANUARY 1, 1978
C
C   PURPOSE             - EVALUATION OF A CUBIC SPLINE
C
C   USAGE               - CALL ICSEVU(X,Y,NX,C,IC,U,S,M,IER)
C
C   ARGUMENTS    X      - VECTOR OF LENGTH NX CONTAINING THE ABSCISSAE
C                           OF THE NX DATA POINTS (X(I),Y(I)) I=1,...,
C                           NX (INPUT). X MUST BE ORDERED SO THAT
C                           X(I) .LT. X(I+1).
C                Y      - VECTOR OF LENGTH NX CONTAINING THE ORDINATES
C                           (OR FUNCTION VALUES) OF THE NX DATA POINTS
C                           (INPUT).
C                NX     - NUMBER OF ELEMENTS IN X AND Y (INPUT).
C                           NX MUST BE .GE. 2.
C                C      - SPLINE COEFFICIENTS (INPUT). C IS AN NX-1 BY
C                           3 MATRIX.
C                IC     - ROW DIMENSION OF MATRIX C EXACTLY AS
C                           SPECIFIED IN THE DIMENSION STATEMENT
C                           IN THE CALLING PROGRAM (INPUT).
C                           IC MUST BE .GE. NX-1.
C                U      - VECTOR OF LENGTH M CONTAINING THE ABSCISSAE
C                           OF THE M POINTS AT WHICH THE CUBIC SPLINE
C                           IS TO BE EVALUATED (INPUT).
C                S      - VECTOR OF LENGTH M (OUTPUT).
C                           THE VALUE OF THE SPLINE APPROXIMATION AT
C                           U(I) IS
C                           S(I) = ((C(J,3)*D+C(J,2))*D+C(J,1))*D+Y(J)
C                           WHERE X(J) .LE. U(I) .LT. X(J+1) AND
C                           D = U(I)-X(J).
C                M      - NUMBER OF ELEMENTS IN U AND S (INPUT).
C                IER    - ERROR PARAMETER (OUTPUT).
C                         WARNING ERROR
C                           IER = 33, U(I) IS LESS THAN X(1).
C                           IER = 34, U(I) IS GREATER THAN X(NX).
C
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32
C                       - SINGLE/H36,H48,H60
C
C   REQD. IMSL ROUTINES - UERTST,UGETIO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   REMARKS  1.  THE ROUTINE ASSUMES THAT THE ABSCISSAE OF THE NX
C                DATA POINTS ARE ORDERED SUCH THAT X(I) IS LESS THAN
C                X(I+1) FOR I=1,...,NX-1. NO CHECK OF THIS CONDITION
C                IS MADE IN THE ROUTINE. UNORDERED ABSCISSAE WILL CAUSE
C                THE ALGORITHM TO PRODUCE INCORRECT RESULTS.
C            2.  THE ROUTINE GENERATES TWO WARNING ERRORS. ONE ERROR
C                OCCURS IF U(I) IS LESS THAN X(1), FOR SOME I IN THE
C                THE INTERVAL (1,M) INCLUSIVELY. THE OTHER ERROR OCCURS
C                IF U(I) IS GREATER THAN X(NX), FOR SOME I IN THE
C                INTERVAL (1,M) INCLUSIVELY.
C            3.  THE ORDINATE Y(NX) IS NOT USED BY THE ROUTINE. FOR
C                U(K) .GT. X(NX-1), THE VALUE OF THE SPLINE, S(K), IS
C                GIVEN BY
C                 S(K)=((C(NX-1,3)*D+C(NX-1,2))*D+C(NX-1,1))*D+Y(NX-1)
C                WHERE D=U(K)-X(NX-1).
C
C   COPYRIGHT           - 1978 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE ICSEVU(X, Y, NX, C, IC, U, S, M, IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NX, IC, M, IER
      REAL, DIMENSION(NX) :: X, Y
      REAL, DIMENSION(IC,3) :: C
      REAL, DIMENSION(M) :: U, S
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I, JER, KER, NXM1, K
      REAL :: D, DD, ZERO
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      DATA I/1/
      DATA ZERO/0.0/
C                                  FIRST EXECUTABLE STATEMENT
      JER = 0
      KER = 0
      IF (M > 0) THEN
         NXM1 = NX - 1
         IF (I > NXM1) I = 1
C                                  EVALUATE SPLINE AT M POINTS
         DO K = 1, M
C                                  FIND THE PROPER INTERVAL
            D = U(K) - X(I)
            IF (D > 0.) GO TO 15
            IF (D == 0.) GO TO 25
            IF (I == 1) GO TO 30
            I = I - 1
            D = U(K) - X(I)
            DO WHILE(D < 0.)
               IF (I == 1) GO TO 30
               I = I - 1
               D = U(K) - X(I)
            END DO
            IF (D == 0.) GO TO 25
            GO TO 20
   10       CONTINUE
            I = I + 1
            D = DD
   15       CONTINUE
            IF (I >= NX) GO TO 35
            DD = U(K) - X(I+1)
            IF (DD >= ZERO) GO TO 10
            IF (D == ZERO) GO TO 25
C                                  PERFORM EVALUATION
   20       CONTINUE
            S(K) = ((C(I,3)*D+C(I,2))*D+C(I,1))*D + Y(I)
            CYCLE 
   25       CONTINUE
            S(K) = Y(I)
            CYCLE 
C                                  WARNING - U(I) .LT. X(1)
   30       CONTINUE
            JER = 33
            GO TO 20
C                                  IF U(I) .GT. X(NX) - WARNING
   35       CONTINUE
            IF (DD > ZERO) KER = 34
            D = U(K) - X(NXM1)
            I = NXM1
            GO TO 20
         END DO
         IER = MAX0(JER,KER)
         IF (JER > 0) CALL UERTST (JER, 6HICSEVU)
         IF (KER > 0) CALL UERTST (KER, 6HICSEVU)
      ENDIF
      RETURN 
      END SUBROUTINE ICSEVU
C   IMSL ROUTINE NAME   - ICSICU
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JANUARY 1, 1978
C
C   PURPOSE             - INTERPOLATORY APPROXIMATION BY CUBIC SPLINES
C                           WITH ARBITRARY SECOND DERIVATIVE END
C                           CONDITIONS.
C
C   USAGE               - CALL ICSICU (X,Y,NX,BPAR,C,IC,IER)
C
C   ARGUMENTS    X      - VECTOR OF LENGTH NX CONTAINING THE ABSCISSAE
C                           OF THE NX DATA POINTS (X(I),Y(I)) I=1,...,
C                           NX. (INPUT) X MUST BE ORDERED SO THAT
C                           X(I) .LT. X(I+1).
C                Y      - VECTOR OF LENGTH NX CONTAINING THE ORDINATES
C                           (OR FUNCTION VALUES) OF THE NX DATA POINTS.
C                           (INPUT)
C                NX     - NUMBER OF ELEMENTS IN X AND Y. (INPUT) NX
C                           MUST BE .GE. 2.
C                BPAR   - VECTOR OF LENGTH 4 CONTAINING THE END
C                           CONDITION PARAMETERS. (INPUT)
C                           2.0*SPP(1)+BPAR(1)*SPP(2) = BPAR(2),
C                           BPAR(3)*SPP(NX-1)+2.0*SPP(NX) = BPAR(4),
C                           WHERE SPP(I) = SECOND DERIVATIVE OF THE
C                           CUBIC SPLINE FUNCTION S EVALUATED AT X(I).
C                C      - SPLINE COEFFICIENTS. (OUTPUT) C IS AN NX-1 BY
C                           3 MATRIX. THE VALUE OF THE SPLINE
C                           APPROXIMATION AT T IS
C                           S(T) = ((C(I,3)*D+C(I,2))*D+C(I,1))*D+Y(I)
C                           WHERE X(I) .LE. T .LT. X(I+1) AND
C                           D = T-X(I).
C                IC     - ROW DIMENSION OF MATRIX C EXACTLY AS
C                           SPECIFIED IN THE DIMENSION STATEMENT IN
C                           THE CALLING PROGRAM. (INPUT)
C                IER    - ERROR PARAMETER. (OUTPUT)
C                         TERMINAL ERROR
C                           IER = 129, IC IS LESS THAN NX-1.
C                           IER = 130, NX IS LESS THAN 2.
C                           IER = 131, INPUT ABSCISSA ARE NOT ORDERED
C                             SO THAT X(1) .LT. X(2) ... .LT. X(NX).
C
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32
C                       - SINGLE/H36,H48,H60
C
C   REQD. IMSL ROUTINES - UERTST,UGETIO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1978 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE ICSICU(X, Y, NX, BPAR, C, IC, IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NX, IC, IER
      REAL, DIMENSION(NX) :: X, Y
      REAL, DIMENSION(4) :: BPAR
      REAL, DIMENSION(IC,3) :: C
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I, J, NXM1
      REAL :: DX, DXJ, DXJP1, DXP, DYJ, DYJP1, HALF, ONE, PJ, SIX, SIXI
     1   , TWO, YPPA, YPPB, ZERO
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      EQUIVALENCE (DXJ, YPPB), (PJ, SIXI), (DXJP1, YPPA)
      DATA ZERO/0.0/
      DATA HALF/0.5/
      DATA ONE/1.0/
      DATA TWO/2.0/
      DATA SIX/6.0/
C                                  FIRST EXECUTABLE STATEMENT
      IER = 0
C                                  CHECK ERROR CONDITIONS
      NXM1 = NX - 1
      IF (IC >= NXM1) THEN
         IF (NX < 2) GO TO 35
         IF (NX /= 2) THEN
C                                  COMPUTE COEFFICIENTS AND RIGHT
C                                  HAND SIDE OF THE TRIDIAGONAL
C                                  SYSTEM DEFINING THE SECOND
C                                  DERIVATIVES OF THE SPLINE
C                                  INTERPOLANT FOR (X,Y)
C                                  C(J,1) = LAMBDA(J)
C                                  C(J,2) = MU(J)
C                                  C(J,3) = D(J)
            DXJ = X(2) - X(1)
            J = 1
            IF (DXJ <= ZERO) GO TO 40
            DYJ = Y(2) - Y(1)
            DO J = 2, NXM1
               DXJP1 = X(J+1) - X(J)
               IF (DXJP1 <= ZERO) GO TO 40
               DYJP1 = Y(J+1) - Y(J)
               DXP = DXJ + DXJP1
               C(J,1) = DXJP1/DXP
               C(J,2) = ONE - C(J,1)
               C(J,3) = SIX*(DYJP1/DXJP1 - DYJ/DXJ)/DXP
               DXJ = DXJP1
               DYJ = DYJP1
            END DO
C                                  FACTOR THE TRIDIAGONAL MATRIX
C                                  AND SOLVE FOR U
C                                  C(J,2) = U(J)
C                                  C(J,1) = Q(J)
C                                  BPAR(1) = LAMBDA(1)
C                                  BPAR(2) = D(1)
C                                  BPAR(3) = MU(NX)
C                                  BPAR(4) = D(NX)
         ENDIF
         C(1,1) = -BPAR(1)*HALF
         C(1,2) = BPAR(2)*HALF
         IF (NX /= 2) THEN
            DO J = 2, NXM1
               PJ = C(J,2)*C(J-1,1) + TWO
               C(J,1) = -C(J,1)/PJ
               C(J,2) = (C(J,3)-C(J,2)*C(J-1,2))/PJ
            END DO
C                                  SOLVE FOR CUBIC COEFFICIENTS
C                                  OF SPLINE INTERPOLANT
C                                  C(J,1), C(J,2), AND C(J,3)
         ENDIF
         YPPB = (BPAR(4)-BPAR(3)*C(NXM1,2))/(BPAR(3)*C(NXM1,1)+TWO)
         SIXI = ONE/SIX
         DO I = 1, NXM1
            J = NX - I
            YPPA = C(J,1)*YPPB + C(J,2)
            DX = X(J+1) - X(J)
            C(J,3) = SIXI*(YPPB - YPPA)/DX
            C(J,2) = HALF*YPPA
            C(J,1) = (Y(J+1)-Y(J))/DX - (C(J,2)+C(J,3)*DX)*DX
            YPPB = YPPA
         END DO
         GO TO 9005
      ENDIF
      IER = 129
      GO TO 9000
   35 CONTINUE
      IER = 130
      GO TO 9000
   40 CONTINUE
      IER = 131
 9000 CONTINUE
      CALL UERTST (IER, 6HICSICU)
 9005 CONTINUE
      RETURN 
      END SUBROUTINE ICSICU
C   IMSL ROUTINE NAME   - LEQT2F
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1982
C
C   PURPOSE             - LINEAR EQUATION SOLUTION - FULL STORAGE
C                           MODE - HIGH ACCURACY SOLUTION
C
C   USAGE               - CALL LEQT2F (A,M,N,IA,B,IDGT,WKAREA,IER)
C
C   ARGUMENTS    A      - INPUT MATRIX OF DIMENSION N BY N CONTAINING
C                           THE COEFFICIENT MATRIX OF THE EQUATION
C                           AX = B.
C                M      - NUMBER OF RIGHT-HAND SIDES. (INPUT)
C                N      - ORDER OF A AND NUMBER OF ROWS IN B. (INPUT)
C                IA     - ROW DIMENSION OF A AND B EXACTLY AS SPECIFIED
C                           IN THE DIMENSION STATEMENT IN THE CALLING
C                           PROGRAM. (INPUT)
C                B      - INPUT MATRIX OF DIMENSION N BY M CONTAINING
C                           THE RIGHT-HAND SIDES OF THE EQUATION AX = B.
C                           ON OUTPUT, THE N BY M MATRIX OF SOLUTIONS
C                           REPLACES B.
C                IDGT   - INPUT OPTION.
C                         IF IDGT IS GREATER THAN 0, THE ELEMENTS OF
C                           A AND B ARE ASSUMED TO BE CORRECT TO IDGT
C                           DECIMAL DIGITS AND THE ROUTINE PERFORMS
C                           AN ACCURACY TEST.
C                         IF IDGT EQUALS 0, THE ACCURACY TEST IS
C                           BYPASSED.
C                         ON OUTPUT, IDGT CONTAINS THE APPROXIMATE
C                           NUMBER OF DIGITS IN THE ANSWER WHICH
C                           WERE UNCHANGED AFTER IMPROVEMENT.
C                WKAREA - WORK AREA OF DIMENSION GREATER THAN OR EQUAL
C                           TO N**2+3N.
C                IER    - ERROR PARAMETER. (OUTPUT)
C                         WARNING ERROR
C                           IER = 34 INDICATES THAT THE ACCURACY TEST
C                             FAILED. THE COMPUTED SOLUTION MAY BE IN
C                             ERROR BY MORE THAN CAN BE ACCOUNTED FOR
C                             BY THE UNCERTAINTY OF THE DATA. THIS
C                             WARNING CAN BE PRODUCED ONLY IF IDGT IS
C                             GREATER THAN 0 ON INPUT. (SEE THE
C                             CHAPTER L PRELUDE FOR FURTHER DISCUSSION.)
C                         TERMINAL ERROR
C                           IER = 129 INDICATES THAT THE MATRIX IS
C                             ALGORITHMICALLY SINGULAR. (SEE THE
C                             CHAPTER L PRELUDE).
C                           IER = 131 INDICATES THAT THE MATRIX IS TOO
C                             ILL-CONDITIONED FOR ITERATIVE IMPROVEMENT
C                             TO BE EFFECTIVE.
C
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32
C                       - SINGLE/H36,H48,H60
C
C   REQD. IMSL ROUTINES - SINGLE/LUDATN,LUELMN,LUREFN,UERTST,UGETIO
C                       - DOUBLE/LUDATN,LUELMN,LUREFN,UERTST,UGETIO,
C                           VXADD,VXMUL,VXSTO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE LEQT2F(A, M, N, IA, B, IDGT, WKAREA, IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER M, N, IA, IDGT, IER
      REAL, DIMENSION(IA,1) :: A, B
      REAL, DIMENSION(1) :: WKAREA
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: JER, J, K, MM, KK, MM1, JJ, L, I, II
      REAL :: D1, D2, WA
C-----------------------------------------------
C
C                                  FIRST EXECUTABLE STATEMENT
C                                  INITIALIZE IER
      IER = 0
      JER = 0
      J = N*N + 1
      K = J + N
      MM = K + N
      KK = 0
      MM1 = MM - 1
      JJ = 1
      DO L = 1, N
         WKAREA(JJ:N-1+JJ) = A(:N,L)
         JJ = N + JJ
      END DO
C                                  DECOMPOSE A
      CALL LUDATN (WKAREA, N, N, A, IA, IDGT, D1, D2, WKAREA(J), WKAREA(
     1   K), WA, IER)
      IF (IER <= 128) THEN
         IF (IDGT==0 .OR. IER/=0) KK = 1
         DO I = 1, M
C                                  PERFORMS THE ELIMINATION PART OF
C                                  AX = B
            CALL LUELMN (A, IA, N, B(1,I), WKAREA(J), WKAREA(MM))
C                                  REFINEMENT OF SOLUTION TO AX = B
            IF (KK /= 0) CALL LUREFN (WKAREA, N, N, A, IA, B(1,I), IDGT
     1         , WKAREA(J), WKAREA(MM), WKAREA(K), WKAREA(K), JER)
            B(:N,I) = WKAREA(MM1+1:N+MM1)
            IF (JER /= 0) GO TO 20
         END DO
         GO TO 25
   20    CONTINUE
         IER = 131
      ENDIF
   25 CONTINUE
      JJ = 1
      DO J = 1, N
         A(:N,J) = WKAREA(JJ:N-1+JJ)
         JJ = N + JJ
      END DO
      IF (IER /= 0) CALL UERTST (IER, 6HLEQT2F)
      RETURN 
      END SUBROUTINE LEQT2F
C   IMSL ROUTINE NAME   - LUDATN
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1982
C
C   PURPOSE             - NUCLEUS CALLED ONLY BY IMSL SUBROUTINE LEQT2F
C
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32
C                       - SINGLE/H36,H48,H60
C
C   REQD. IMSL ROUTINES - UERTST,UGETIO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE LUDATN(A, IA, N, LU, ILU, IDGT, D1, D2, APVT, EQUIL, WA
     1   , IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IA, N, ILU, IDGT, IER
      REAL D1, D2, WA
      REAL, DIMENSION(IA,1) :: A
      REAL, DIMENSION(ILU,1) :: LU
      REAL, DIMENSION(1) :: APVT, EQUIL
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I, J, JM1, IM1, K, IMAX, JP1
      REAL :: ZERO, ONE, FOUR, SIXTN, SIXTH, RN, WREL, BIGA, BIG, P, SUM
     1   , AI, WI, T, TEST, Q
C-----------------------------------------------
C
      DATA ZERO, ONE, FOUR, SIXTN, SIXTH/0.0, 1., 4., 16., .0625/
C                                  FIRST EXECUTABLE STATEMENT
C                                  INITIALIZATION
      IER = 0
      RN = N
      WREL = ZERO
      D1 = ONE
      D2 = ZERO
      BIGA = ZERO
      DO I = 1, N
         BIG = ZERO
         LU(I,:N) = A(I,:N)
         BIG = AMAX1(MAXVAL(ABS(A(I,:N))),BIG)
         BIGA = AMAX1(BIG,BIGA)
         IF (BIG == ZERO) GO TO 110
         EQUIL(I) = ONE/BIG
      END DO
      DO J = 1, N
         JM1 = J - 1
         IF (JM1 >= 1) THEN
C                                  COMPUTE U(I,J), I=1,...,J-1
            DO I = 1, JM1
               SUM = LU(I,J)
               IM1 = I - 1
               IF (IDGT /= 0) THEN
C                                  WITH ACCURACY TEST
                  AI = ABS(SUM)
                  WI = ZERO
                  IF (IM1 >= 1) THEN
                     DO K = 1, IM1
                        T = LU(I,K)*LU(K,J)
                        SUM = SUM - T
                        WI = WI + ABS(T)
                     END DO
                     LU(I,J) = SUM
                  ENDIF
                  WI = WI + ABS(SUM)
                  IF (AI == ZERO) AI = BIGA
                  TEST = WI/AI
                  WREL = AMAX1(TEST,WREL)
               ELSE
C                                  WITHOUT ACCURACY
                  IF (IM1 >= 1) THEN
                     DO K = 1, IM1
                        SUM = SUM - LU(I,K)*LU(K,J)
                     END DO
                     LU(I,J) = SUM
                  ENDIF
               ENDIF
            END DO
         ENDIF
         P = ZERO
C                                  COMPUTE U(J,J) AND L(I,J), I=J+1,...,
         DO I = J, N
            SUM = LU(I,J)
            IF (IDGT /= 0) THEN
C                                  WITH ACCURACY TEST
               AI = ABS(SUM)
               WI = ZERO
               IF (JM1 >= 1) THEN
                  DO K = 1, JM1
                     T = LU(I,K)*LU(K,J)
                     SUM = SUM - T
                     WI = WI + ABS(T)
                  END DO
                  LU(I,J) = SUM
               ENDIF
               WI = WI + ABS(SUM)
               IF (AI == ZERO) AI = BIGA
               TEST = WI/AI
               WREL = AMAX1(TEST,WREL)
            ELSE
C                                  WITHOUT ACCURACY TEST
               IF (JM1 >= 1) THEN
                  DO K = 1, JM1
                     SUM = SUM - LU(I,K)*LU(K,J)
                  END DO
                  LU(I,J) = SUM
               ENDIF
            ENDIF
            Q = EQUIL(I)*ABS(SUM)
            IF (P < Q) THEN
               P = Q
               IMAX = I
            ENDIF
         END DO
C                                  TEST FOR ALGORITHMIC SINGULARITY
         IF (RN + P == RN) GO TO 110
         IF (J /= IMAX) THEN
C                                  INTERCHANGE ROWS J AND IMAX
            D1 = -D1
            DO K = 1, N
               P = LU(IMAX,K)
               LU(IMAX,K) = LU(J,K)
               LU(J,K) = P
            END DO
            EQUIL(IMAX) = EQUIL(J)
         ENDIF
         APVT(J) = IMAX
         D1 = D1*LU(J,J)
   85    CONTINUE
         IF (ABS(D1) <= ONE) GO TO 90
         D1 = D1*SIXTH
         D2 = D2 + FOUR
         GO TO 85
   90    CONTINUE
         IF (ABS(D1) >= SIXTH) GO TO 95
         D1 = D1*SIXTN
         D2 = D2 - FOUR
         GO TO 90
   95    CONTINUE
         JP1 = J + 1
         IF (JP1 <= N) THEN
C                                  DIVIDE BY PIVOT ELEMENT U(J,J)
            P = LU(J,J)
            LU(JP1:N,J) = LU(JP1:N,J)/P
         ENDIF
      END DO
C                                  PERFORM ACCURACY TEST
      IF (IDGT == 0) GO TO 9005
      P = 3*N + 3
      WA = P*WREL
      IF (WA + 10.0**(-IDGT) /= WA) GO TO 9005
      IER = 34
      GO TO 9000
C                                  ALGORITHMIC SINGULARITY
  110 CONTINUE
      IER = 129
      D1 = ZERO
      D2 = ZERO
 9000 CONTINUE
C                                  PRINT ERROR
      CALL UERTST (IER, 6HLUDATN)
 9005 CONTINUE
      RETURN 
      END SUBROUTINE LUDATN
C   IMSL ROUTINE NAME   - LUELMN
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1982
C
C   PURPOSE             - NUCLEUS CALLED ONLY BY IMSL SUBROUTINE LEQT2F
C
C   REQD. IMSL ROUTINES - NONE REQUIRED
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE LUELMN(A, IA, N, B, APVT, X)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IA, N
      REAL, DIMENSION(IA,1) :: A
      REAL, DIMENSION(1) :: B, APVT, X
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I, IW, IP, IM1, J, IB, IP1
      REAL :: SUM
C-----------------------------------------------
C
C                                  FIRST EXECUTABLE STATEMENT
C                                  SOLVE LY = B FOR Y
      X(:N) = B(:N)
      IW = 0
      DO I = 1, N
         IP = APVT(I)
         SUM = X(IP)
         X(IP) = X(I)
         IF (IW /= 0) THEN
            IM1 = I - 1
            DO J = IW, IM1
               SUM = SUM - A(I,J)*X(J)
            END DO
         ELSE
            IF (SUM /= 0.) IW = I
         ENDIF
         X(I) = SUM
      END DO
C                                  SOLVE UX = Y FOR X
      DO IB = 1, N
         I = N + 1 - IB
         IP1 = I + 1
         SUM = X(I)
         IF (IP1 <= N) THEN
            DO J = IP1, N
               SUM = SUM - A(I,J)*X(J)
            END DO
         ENDIF
         X(I) = SUM/A(I,I)
      END DO
      RETURN 
      END SUBROUTINE LUELMN
C   IMSL ROUTINE NAME   - LUREFN
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1982
C
C   PURPOSE             - NUCLEUS CALLED ONLY BY IMSL SUBROUTINE LEQT2F
C
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32
C                       - SINGLE/H36,H48,H60
C
C   REQD. IMSL ROUTINES - SINGLE/LUELMN,UERTST,UGETIO
C                       - DOUBLE/LUELMN,UERTST,UGETIO,VXADD,VXMUL,
C                           VXSTO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE LUREFN(A, IA, N, UL, IUL, B, IDGT, APVT, X, RES, DX, 
     1   IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IA, N, IUL, IDGT, IER
      REAL, DIMENSION(IA,1) :: A
      REAL, DIMENSION(IUL,1) :: UL
      REAL, DIMENSION(1) :: B, APVT, X, RES, DX
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: ITMAX, I, ITER, J
      REAL :: ZERO, XNORM, DXNORM
      DOUBLE PRECISION :: SUM
C-----------------------------------------------
C
      DATA ITMAX/50/
      DATA ZERO/0.0/
C                                  FIRST EXECUTABLE STATEMENT
      IER = 0
      XNORM = ZERO
      XNORM = AMAX1(XNORM,MAXVAL(ABS(X(:N))))
      IF (XNORM == ZERO) THEN
         IDGT = 50
      ELSE
         DO ITER = 1, ITMAX
            DO I = 1, N
               SUM = DBLE(B(I))
               DO J = 1, N
                  SUM = SUM - DBLE(A(I,J))*DBLE(X(J))
               END DO
               RES(I) = SUM
            END DO
            CALL LUELMN (UL, IUL, N, RES, APVT, DX)
            DXNORM = ZERO
            XNORM = ZERO
            X(:N) = X(:N) + DX(:N)
            DXNORM = AMAX1(DXNORM,MAXVAL(ABS(DX(:N))))
            XNORM = AMAX1(XNORM,MAXVAL(ABS(X(:N))))
            IF (ITER == 1) THEN
               IDGT = 50
               IF (DXNORM /= ZERO) IDGT = -ALOG10(DXNORM/XNORM)
            ENDIF
            IF (XNORM + DXNORM == XNORM) GO TO 9005
         END DO
C                                  ITERATION DID NOT CONVERGE
         IER = 129
         CALL UERTST (IER, 6HLUREFN)
      ENDIF
 9005 CONTINUE
      RETURN 
      END SUBROUTINE LUREFN
C   IMSL ROUTINE NAME   - MMBSIR
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/DOUBLE
C
C   LATEST REVISION     - JULY 1, 1983
C
C   PURPOSE             - MODIFIED BESSEL FUNCTION OF THE FIRST KIND
C                           OF NONNEGATIVE REAL ORDER FOR REAL POSITIVE
C                           ARGUMENTS WITH EXPONENTIAL SCALING OPTION
C
C   USAGE               - CALL MMBSIR (ARG,ORDER,N,IOPT,B,IER)
C
C   ARGUMENTS    ARG    - INPUT ARGUMENT. ARG MUST BE TYPED APPRO-
C                           PRIATELY IN THE CALLING PROGRAM. (SEE THE
C                           PRECISION/HARDWARE SECTION.) ARG MUST BE
C                           GREATER THAN OR EQUAL TO ZERO. IF SCALING
C                           IS NOT DESIRED (IOPT = 1), THEN ARG MUST BE
C                           LESS THAN EXPARG. EXPARG IS APPROXIMATELY
C                           THE LARGEST ACCEPTABLE ARGUMENT FOR THE
C                           FORTRAN EXP FUNCTION. SEE THE PROGRAMMING
C                           NOTES IN THE MANUAL FOR THE EXACT VALUE OF
C                           EXPARG.
C                ORDER  - INPUT VALUE SPECIFYING THE DESIRED ORDER OF
C                           THE BESSEL FUNCTION. ORDER MUST BE TYPED
C                           APPROPRIATELY IN THE CALLING PROGRAM. (SEE
C                           THE PRECISION/HARDWARE SECTION.) ORDER MUST
C                           BE GREATER THAN OR EQUAL TO ZERO AND LESS
C                           THAN ONE.
C                N      - INPUT PARAMETER SPECIFYING THE NUMBER OF
C                           FUNCTION VALUES TO BE COMPUTED.
C                IOPT   - INPUT SCALING OPTION SWITCH.
C                           IF IOPT = 1 THEN THE BESSEL FUNCTIONS
C                           CALCULATED ARE UNSCALED.
C                           IF IOPT = 2 THEN THE BESSEL FUNCTIONS
C                           CALCULATED ARE SCALED BY EXP(-ARG).
C                B      - OUTPUT VECTOR OF LENGTH N CONTAINING THE
C                           COMPUTED FUNCTION VALUES. B MUST BE TYPED
C                           APPROPRIATELY IN THE CALLING PROGRAM. (SEE
C                           THE PRECISION/HARDWARE SECTION.) B(1) WILL
C                           CONTAIN THE COMPUTED VALUE FOR THE INPUT
C                           ORDER, B(2) WILL CONTAIN THE COMPUTED
C                           FUNCTION VALUE FOR ORDER + 1, B(3) FOR
C                           ORDER + 2, ETC.
C                IER    - ERROR PARAMETER. (OUTPUT)
C                         TERMINAL ERROR
C                           IER = 129 INDICATES THAT ONE OR MORE OF
C                             THE INPUT ARGUMENTS, ARG, ORDER, N,
C                             OR IOPT, IS OUT OF RANGE. B(I), (I=1,N)
C                             IS SET TO MACHINE INFINITY.
C                           IER = 129+J INDICATES THAT N WAS SO MUCH
C                             GREATER THAN THE LARGEST INTEGER IN ARG
C                             THAT ONLY B(I), (I=1,J) WAS CALCULATED
C                             CORRECTLY. SEE THE PROGRAMMING NOTES
C                             FOR THE ACCURACY OF THE REMAINING B(I).
C
C   PRECISION/HARDWARE  - DOUBLE/H32,H36
C                       - SINGLE/H48,H60
C
C   REQD. IMSL ROUTINES - H32,H36/MGAMAD=DGAMMA,UERTST,UGETIO
C                         H48,H60/MGAMA=GAMMA,UERTST,UGETIO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE MMBSIR(ARG, ORDER, N, IOPT, B, IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER N, IOPT, IER
      DOUBLE PRECISION ARG, ORDER
      DOUBLE PRECISION, DIMENSION(1) :: B
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: IDUM, NSIG, ISUM, MAGX, NCALC, NBMX, ISTEP, NEND, 
     1   NSTART, NN, L, I, INTEN
      DOUBLE PRECISION :: P, TEST, TEMPA, TEMPB, TEMPC, EXPARG, SUM, 
     1   TOVER, PLAST, POLD, PSAVE, PSAVEL, ENTEN, ENSIG, RTNSIG, EN, EM
     2   , EMPAL, EMP2AL, ENMTEN, STEP, STEP2, XLARGE, HALFX, ZSIG, 
     3   SMALL, XINF, XNTEN
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      DOUBLE PRECISION , EXTERNAL :: DGAMMA
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      DATA SMALL/2.938735878D-39/
      DATA XLARGE/1.D+04/
      DATA XINF/1.700000000D+38/
      DATA ZSIG/16.8D0/
      DATA EXPARG/88.0/
      DATA XNTEN/38.D0/
C                                  FIRST EXECUTABLE STATEMENT
      NSIG = IFIX(SNGL(ZSIG))
      ISUM = -NSIG/4
      RTNSIG = 10.D0**ISUM
      IER = 0
      INTEN = XNTEN
      ENTEN = 10.D0**INTEN
      ENSIG = 10.0D0**NSIG
      ENMTEN = 4.D0*SMALL
      TEMPA = ARG
C                                  CHECK ARGUMENT RANGE
      IF (.NOT.(N>0 .AND. ARG>=0.D0 .AND. (IOPT==1 .AND. ARG<=EXPARG
     1    .OR. IOPT==2 .AND. ARG<=XLARGE) .AND. ORDER>=0.D0 .AND. ORDER<
     2   1.D0)) THEN
         IER = 129
         NN = N
         IF (N <= 0) NN = 1
         B(:NN) = XINF
      ELSE
C                                  USE 2-TERM ASCENDING SERIES FOR
C                                    SMALL ARG
         MAGX = IFIX(SNGL(TEMPA))
         NCALC = N
         IF (TEMPA >= RTNSIG) THEN
C                                  INITIALIZE THE CALCULATION OF P*S
            NBMX = N - MAGX
            NN = MAGX + 1
            ISTEP = NN + NN
            STEP = ORDER + ORDER
            EN = DBLE(FLOAT(ISTEP)) + STEP
            PLAST = 1.D0
            P = EN/TEMPA
C                                  CALCULATE GENERAL SIGNIFICANCE TEST
            TEST = ENSIG + ENSIG
            STEP = TEST*P
            IF (2*MAGX > 5*NSIG) THEN
               TEST = DSQRT(STEP)
            ELSE
               TEST = TEST/1.585D0**MAGX
            ENDIF
            IF (NBMX >= 3) THEN
C                                  CALCULATE P*S UNTIL NN = N-1.
C                                    CHECK FOR POSSIBLE OVERFLOW.
               TOVER = ENTEN/ENSIG
               NSTART = MAGX + 2
               NEND = N - 1
               ISTEP = NSTART + NSTART
               STEP = ORDER + ORDER
               EN = DBLE(FLOAT(ISTEP)) - 2.D0 + STEP
               DO NN = NSTART, NEND
                  EN = EN + 2.D0
                  POLD = PLAST
                  PLAST = P
                  P = EN*PLAST/TEMPA + POLD
                  IF (P > TOVER) GO TO 25
               END DO
               NN = NEND
               ISTEP = NN + NN
               STEP = ORDER + ORDER
               EN = DBLE(FLOAT(ISTEP)) + STEP
C                                  CALCULATE SPECIAL SIGNIFICANCE
C                                    TEST FOR NBMX .GT. 2.
               STEP = PLAST*ENSIG
               STEP2 = P + P
               STEP = DSQRT(STEP)*DSQRT(STEP2)
               TEST = DMAX1(TEST,STEP)
C                                  CALCULATE P*S UNTIL SIGNIFICANCE
C                                    TEST PASSES
            ENDIF
            NN = NN + 1
            EN = EN + 2.D0
            POLD = PLAST
            PLAST = P
            P = EN*PLAST/TEMPA + POLD
            DO WHILE(P < TEST)
               NN = NN + 1
               EN = EN + 2.D0
               POLD = PLAST
               PLAST = P
               P = EN*PLAST/TEMPA + POLD
            END DO
            GO TO 45
C                                  TO AVOID OVERFLOW, DIVIDE P*S BY
C                                    TOVER. CALCULATE P*S UNTIL
C                                    ABS(P).GT.1.
   25       CONTINUE
            TOVER = ENTEN
            P = P/TOVER
            PLAST = PLAST/TOVER
            PSAVE = P
            PSAVEL = PLAST
            NSTART = NN + 1
            NN = NN + 1
            EN = EN + 2.D0
            POLD = PLAST
            PLAST = P
            P = EN*PLAST/TEMPA + POLD
            DO WHILE(P <= 1.D0)
               NN = NN + 1
               EN = EN + 2.D0
               POLD = PLAST
               PLAST = P
               P = EN*PLAST/TEMPA + POLD
            END DO
            TEMPB = EN/TEMPA
C                                  CALCULATE BACKWARD TEST, AND FIND
C                                    NCALC, THE HIGHEST N SUCH THAT
C                                    THE TEST IS PASSED.
            TEST = POLD*PLAST*(.5D0 - .5D0/(TEMPB*TEMPB))/ENSIG
            P = PLAST*TOVER
            NN = NN - 1
            EN = EN - 2.D0
            NEND = MIN0(N,NN)
            DO NCALC = NSTART, NEND
               POLD = PSAVEL
               PSAVEL = PSAVE
               PSAVE = EN*PSAVEL/TEMPA + POLD
               IF (PSAVE*PSAVEL > TEST) GO TO 40
            END DO
            NCALC = NEND + 1
   40       CONTINUE
            NCALC = NCALC - 1
C                                  INITIALIZE THE BACKWARD RECURSION
C                                    AND THE NORMALIZATION SUM
   45       CONTINUE
            NN = NN + 1
            EN = EN + 2.D0
            TEMPB = 0.D0
            TEMPA = 1.D0/P
            EM = DBLE(FLOAT(NN)) - 1.D0
            EMPAL = EM + ORDER
            EMP2AL = (EM - 1.D0) + (ORDER + ORDER)
            SUM = TEMPA*EMPAL*EMP2AL/EM
            NEND = NN - N
            IF (NEND >= 0) THEN
               IF (NEND /= 0) THEN
                  DO L = 1, NEND
                     NN = NN - 1
                     EN = EN - 2.D0
                     TEMPC = TEMPB
                     TEMPB = TEMPA
                     TEMPA = (EN*TEMPB)/ARG + TEMPC
                     EM = EM - 1.D0
                     EMP2AL = EMP2AL - 1.D0
                     IF (NN == 1) GO TO 60
                     IF (NN == 2) EMP2AL = 1.D0
                     EMPAL = EMPAL - 1.D0
                     SUM = (SUM + TEMPA*EMPAL)*EMP2AL/EM
                  END DO
C                                  STORE B(N)
               ENDIF
   60          CONTINUE
               B(NN) = TEMPA
               IF (N <= 1) THEN
                  SUM = (SUM + SUM) + TEMPA
                  GO TO 100
C                                  CALCULATE AND STORE B(N-1)
               ENDIF
               NN = NN - 1
               EN = EN - 2.D0
               B(NN) = (EN*TEMPA)/ARG + TEMPB
               IF (NN == 1) GO TO 95
               EM = EM - 1.D0
               EMP2AL = EMP2AL - 1.D0
               IF (NN == 2) EMP2AL = 1.D0
               EMPAL = EMPAL - 1.D0
               SUM = (SUM + B(NN)*EMPAL)*EMP2AL/EM
            ELSE
C                                  NN.LT.N, SO STORE B(NN) AND SET
C                                    HIGHER ORDERS TO ZERO
               B(NN) = TEMPA
               NEND = -NEND
               B(NN+1:NEND+NN) = 0.D0
            ENDIF
            NEND = NN - 2
            IF (NEND /= 0) THEN
C                                  CALCULATE VIA DIFFERENCE EQUATION
C                                    AND STORE B(NN), UNTIL NN = 2
               DO L = 1, NEND
                  NN = NN - 1
                  EN = EN - 2.D0
                  B(NN) = (EN*B(NN+1))/ARG + B(NN+2)
                  EM = EM - 1.D0
                  EMP2AL = EMP2AL - 1.D0
                  IF (NN == 2) EMP2AL = 1.D0
                  EMPAL = EMPAL - 1.D0
                  SUM = (SUM + B(NN)*EMPAL)*EMP2AL/EM
               END DO
C                                  CALCULATE B(1)
            ENDIF
            B(1) = 2.D0*EMPAL*B(2)/ARG + B(3)
   95       CONTINUE
            SUM = (SUM + SUM) + B(1)
C                                  NORMALIZE. DIVIDE ALL B(NN) BY SUM
  100       CONTINUE
            IF (ORDER /= 0.D0) THEN
               STEP = 1.D0 + ORDER
               SUM = SUM*DGAMMA(STEP)*(ARG*.5D0)**(-ORDER)
            ENDIF
            STEP = -ARG
            IF (IOPT == 1) SUM = SUM*DEXP(STEP)
            TEMPA = ENMTEN
            IF (SUM > 1.D0) TEMPA = TEMPA*SUM
            WHERE (B(:N) < TEMPA) B(:N) = 0.D0
            B(:N) = B(:N)/SUM
         ELSE
C                                  TWO-TERM ASCENDING SERIES FOR SMALL A
            TEMPA = 1.D0
            EMPAL = 1.D0 + ORDER
            HALFX = 0.D0
            IF (ARG > ENMTEN) HALFX = .5D0*ARG
            IF (ORDER /= 0.D0) TEMPA = HALFX**ORDER/DGAMMA(EMPAL)
            STEP = -ARG
            IF (IOPT == 2) TEMPA = TEMPA*DEXP(STEP)
            TEMPB = 0.D0
            IF (ARG + 1.D0 > 1.D0) TEMPB = HALFX*HALFX
            B(1) = TEMPA + TEMPA*TEMPB/EMPAL
            IF (ARG/=0.D0 .AND. B(1)==0.D0) NCALC = 0
            IF (N /= 1) THEN
               IF (ARG <= 0.D0) THEN
                  B(2:N) = 0.D0
                  GO TO 9005
               ENDIF
               TEMPC = HALFX
               TOVER = (ENMTEN + ENMTEN)/ARG
               IF (TEMPB /= 0.D0) TOVER = ENMTEN/TEMPB
               DO NN = 2, N
                  TEMPA = TEMPA/EMPAL
                  EMPAL = EMPAL + 1.D0
                  TEMPA = TEMPA*TEMPC
                  IF (TEMPA <= TOVER*EMPAL) TEMPA = 0.D0
                  B(NN) = TEMPA + TEMPA*TEMPB/EMPAL
                  IF (B(NN)==0.D0 .AND. NCALC>NN) NCALC = NN - 1
               END DO
            ENDIF
         ENDIF
         IF (NCALC == N) GO TO 9005
         IER = 129 + NCALC
      ENDIF
      CALL UERTST (IER, 6HMMBSIR)
 9005 CONTINUE
      RETURN 
      END SUBROUTINE MMBSIR
C   IMSL ROUTINE NAME   - MMBSKR
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/DOUBLE
C
C   LATEST REVISION     - JUNE 1, 1982
C
C   PURPOSE             - MODIFIED BESSEL FUNCTION OF THE SECOND KIND
C                           OF NONNEGATIVE REAL FRACTIONAL ORDER
C                           FOR REAL POSITIVE ARGUMENTS SCALED BY
C                           EXP(ARG)
C
C   USAGE               - CALL MMBSKR (ARG,ORDER,N,BK,IER)
C
C   ARGUMENTS    ARG    - INPUT ARGUMENT. ARG MUST BE TYPED APPRO-
C                           PRIATELY IN THE CALLING PROGRAM. (SEE THE
C                           PRECISION/HARDWARE SECTION.) ARG MUST BE
C                           GREATER THAN ZERO.
C                ORDER  - INPUT VALUE SPECIFYING THE DESIRED ORDER OF
C                           THE BESSEL FUNCTION. ORDER MUST BE TYPED
C                           APPROPRIATELY IN THE CALLING PROGRAM. (SEE
C                           THE PRECISION/HARDWARE SECTION.) ORDER MUST
C                           BE GREATER THAN OR EQUAL TO ZERO.
C                N       - INPUT VALUE SPECIFYING THE NUMBER OF
C                           FUNCTION VALUES TO BE COMPUTED.
C                BK     - OUTPUT VECTOR OF LENGTH N CONTAINING THE
C                           COMPUTED FUNCTION VALUES. BK MUST BE TYPED
C                           APPROPRIATELY IN THE CALLING PROGRAM. (SEE
C                           THE PRECISION/HARDWARE SECTION.) BK(1) WILL
C                           CONTAIN THE COMPUTED VALUE FOR THE INPUT
C                           ORDER, BK(2) WILL CONTAIN THE COMPUTED
C                           FUNCTION VALUE FOR ORDER + 1, BK(3) FOR
C                           ORDER + 2, ETC.
C                IER    - ERROR PARAMETER. (OUTPUT)
C                         TERMINAL ERROR
C                           IER = 129 INDICATES THAT ONE OR MORE OF
C                             THE INPUT ARGUMENTS, ARG, ORDER, OR N IS
C                             OUT OF RANGE. BK(I), I=1,N, IS SET TO
C                             MACHINE INFINITY.
C                           IER = 130 INDICATES THAT BK(1) IS GREATER
C                             THAN MACHINE INFINITY. BK(I), I=1,N, IS
C                             SET TO MACHINE INFINITY.
C                           IER = 131 INDICATES THAT BK(N)/BK(N-1) IS
C                             GREATER THAN MACHINE INFINITY, BUT THAT
C                             BK(1) IS COMPUTED CORRECTLY.  BK(I),
C                             I=2,N, IS SET TO MACHINE INFINITY.
C                           IER = 131+J INDICATES THAT BK(J) WOULD HAVE
C                             BEEN GREATER THAN MACHINE INFINITY.
C                             BK(L), L=J,N, IS SET TO MACHINE INFINITY.
C                             BK(L), L=1,J-1, IS COMPUTED CORRECTLY.
C
C   PRECISION/HARDWARE  - DOUBLE/H32,H36
C                       - SINGLE/H48,H60
C
C   REQD. IMSL ROUTINES - UERTST,UGETIO
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE MMBSKR(ARG, ORDER, N, BK, IER)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER N, IER
      DOUBLE PRECISION ARG, ORDER
      DOUBLE PRECISION, DIMENSION(1) :: BK
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: K, IEND, I, JER, M, J, MPLUS1, KK
      DOUBLE PRECISION :: DMINF, DNTEN, EX, TEMP, TEMP2, A, ALPHA, BK1, 
     1   BK2, C, D, DM, DMAX, DMIN, D1, D2, D3, ENU, F0, F1, F2
      DOUBLE PRECISION, DIMENSION(8) :: P
      DOUBLE PRECISION :: P0
      DOUBLE PRECISION, DIMENSION(7) :: Q
      DOUBLE PRECISION :: Q0
      DOUBLE PRECISION, DIMENSION(4) :: R
      DOUBLE PRECISION :: RATIO
      DOUBLE PRECISION, DIMENSION(4) :: S
      DOUBLE PRECISION, DIMENSION(7) :: T
      DOUBLE PRECISION :: TOL, TWONU, TWOX, T1, T2, X2BY4, XINF
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      DATA A/.1159315156584124D0/
      DATA D/.7978845608028654D0/
      DATA DNTEN/38.D0/
      DATA DMIN/2.938735878D-39/
      DATA XINF/1.700000000D+38/
      DATA P(1)/.8056298755690433D0/
      DATA P(2)/.2040455002053652D02/
      DATA P(3)/.1577056051066762D03/
      DATA P(4)/.5366711164692075D03/
      DATA P(5)/.9003827592912888D03/
      DATA P(6)/.7309238866506604D03/
      DATA P(7)/.2292993015094251D03/
      DATA P(8)/.8224670334241132D00/
      DATA Q(1)/.2946019862478505D02/
      DATA Q(2)/.2775778685102212D03/
      DATA Q(3)/.1206703255910274D04/
      DATA Q(4)/.2762914441597915D04/
      DATA Q(5)/.3443740505065646D04/
      DATA Q(6)/.2210631901133786D04/
      DATA Q(7)/.5722673383598922D03/
      DATA R(1)/ - .1363145832225935D-02/
      DATA R(2)/.3314384097399805D-01/
      DATA R(3)/ - .2506099471699884D0/
      DATA R(4)/.8224670334241132D0/
      DATA S(1)/.2755746186513600D-02/
      DATA S(2)/ - .6530826876446539D-01/
      DATA S(3)/.5187115283864121D0/
      DATA S(4)/ - .1456159004551443D01/
      DATA T(1)/.0779373862881377D-12/
      DATA T(2)/.1605596120426673D-09/
      DATA T(3)/.2505214205064134D-07/
      DATA T(4)/.2755731902076135D-05/
      DATA T(5)/.1984126984193444D-03/
      DATA T(6)/.8333333333332269D-02/
      DATA T(7)/.1666666666666667D0/
      DATA TOL/2.775557562D-17/
C                                  A = DLOG(2.D0) - EULER S CONSTANT
C                                  D = DSQRT(2.D0/PI)
C                                  P, Q - APPROXIMATION FOR
C                                    DLOG(DGAMMA(1+ENU))/ENU + EULER S
C                                    CONSTANT
C                                  R, S - APPROXIMATION FOR
C                                    (1-ENU*PI/DSIN(ENU*PI))/(2.D0*ENU)
C                                  T - APPROXIMATION FOR DSINH(Y)/Y
C
C                                  FIRST EXECUTABLE STATEMENT
      EX = ARG
      DMAX = 10.D0**DNTEN
      IER = 0
      IF (.NOT.(ORDER>=0.D0 .AND. N>=1 .AND. EX>0.D0)) THEN
         IER = 129
         BK(1) = XINF
         IF (N < 2) GO TO 9000
         BK(2:N) = XINF
         GO TO 9000
      ENDIF
      K = ORDER + 0.5D0
      ENU = ORDER - FLOAT(K)
      IF (DABS(ENU) < 1.D-30) ENU = 0.D0
      TWONU = ENU + ENU
      IEND = N + K - 1
      C = ENU*ENU
      D3 = -C
      IF (EX <= 1.D0) THEN
C                                  CALCULATION OF P0, Q0 AND F0
         D1 = 0.D0
         D2 = P(1)
         T1 = 1.D0
         T2 = Q(1)
         DO I = 1, 3
            D1 = C*D1 + P(I*2)
         END DO
         DO I = 1, 3
            D2 = C*D2 + P(1+I*2)
         END DO
         DO I = 1, 3
            T1 = C*T1 + Q(I*2)
         END DO
         DO I = 1, 3
            T2 = C*T2 + Q(1+I*2)
         END DO
         D1 = ENU*D1
         T1 = ENU*T1
         F1 = DLOG(ARG)
         F0 = A + ENU*(P(8)-ENU*(D1+D2)/(T1+T2)) - F1
         P0 = DEXP(ENU*F0)
         Q0 = DEXP((-ENU*(A - ENU*(P(8)+ENU*(D1-D2)/(T1-T2))-F1)))
         D1 = 0.D0
         T1 = 0.D0
         DO I = 1, 4
            D1 = C*D1 + R(I)
         END DO
         DO I = 1, 4
            T1 = C*T1 + S(I)
         END DO
         F1 = ENU*F0
         F1 = F1*F1
         IF (F1 <= 1.3D0) THEN
            D2 = 0.D0
            DO I = 1, 7
               D2 = F1*D2 + T(I)
            END DO
            D2 = F0 + F0*F1*D2
         ELSE
            D2 = (DEXP(ENU*F0) - DEXP((-ENU*F0)))*.5D0
            D2 = D2/ENU
         ENDIF
         F0 = D2 - ENU*D1/((1.D0 + C*T1)*P0)
         IF (EX <= 1.D-10) THEN
C                                  X.LE.1.0E-10
C                                    CALCULATION OF K(ENU,X) AND
C                                    X*K(ENU+1,X)/K(ENU,X)
            BK(1) = F0 + ARG*F0
            RATIO = P0/F0
            C = ARG*DMAX
            IF (K == 0) GO TO 55
C                                  CALCULATION OF K(ORDER,X) AND
C                                    X*K(ORDER+1,X)/K(ORDER,X)
C                                    FOR ORDER .GE. 1/2
            DO I = 1, K
               TEMP = C/RATIO
               IF (BK(1) >= TEMP) GO TO 45
               BK(1) = RATIO*BK(1)/ARG
               TWONU = TWONU + 2.D0
               RATIO = TWONU
            END DO
            GO TO 55
   45       CONTINUE
            IER = 130
            BK(:N) = XINF
            GO TO 9000
   55       CONTINUE
            IF (N == 1) GO TO 9005
C                                  CALCULATION OF
C                                    K(ORDER+L,X)/K(ORDER+L-1,X)
C                                    FOR L = 1, 2,. . ., N
            DO I = 2, N
               IF (RATIO >= C) GO TO 65
               BK(I) = RATIO/ARG
               TWONU = TWONU + 2.D0
               RATIO = TWONU
            END DO
            JER = 1
            GO TO 140
   65       CONTINUE
            BK(2:N) = XINF
            IER = 131
            GO TO 9000
C                                  1.0E-10 .LT. X .LE. 1.0
         ENDIF
         C = 1.D0
         X2BY4 = 0.25D0*ARG*ARG
         P0 = 0.5D0*P0
         Q0 = 0.5D0*Q0
         D1 = -1.D0
         D2 = 0.D0
         BK1 = 0.D0
         BK2 = 0.D0
         F1 = F0
         F2 = P0
         D1 = D1 + 2.D0
         D2 = D2 + 1.D0
         D3 = D1 + D3
         C = X2BY4*C/D2
         F0 = (D2*F0 + P0 + Q0)/D3
         P0 = P0/(D2 - ENU)
         Q0 = Q0/(D2 + ENU)
         T1 = C*F0
         T2 = C*(P0 - D2*F0)
         BK1 = BK1 + T1
         BK2 = BK2 + T2
         TEMP = DABS(T1/(F1 + BK1))
         TEMP2 = DABS(T2/(F2 + BK2))
         DO WHILE(TEMP>TOL .OR. TEMP2>TOL)
            D1 = D1 + 2.D0
            D2 = D2 + 1.D0
            D3 = D1 + D3
            C = X2BY4*C/D2
            F0 = (D2*F0 + P0 + Q0)/D3
            P0 = P0/(D2 - ENU)
            Q0 = Q0/(D2 + ENU)
            T1 = C*F0
            T2 = C*(P0 - D2*F0)
            BK1 = BK1 + T1
            BK2 = BK2 + T2
            TEMP = DABS(T1/(F1 + BK1))
            TEMP2 = DABS(T2/(F2 + BK2))
         END DO
         D1 = DEXP((-ARG))
         BK1 = (F1 + BK1)/D1
         BK2 = 2.D0*(F2 + BK2)/(ARG*D1)
         DMINF = 24.67D0*EX + 3.57D0
      ELSE
C                                  X .GT. 1.0
         TWOX = ARG + ARG
         ALPHA = 0.D0
         RATIO = 0.D0
         IF (EX <= 4.D0) THEN
C                                  1.0 .LT. X .LE. 4.0
C                                    CALCULATION OF K(ENU+1,X)/K(ENU,X)
            M = 52.0583D0/EX + 5.7607D0
            D2 = M
            D1 = D2 + D2
            D2 = D2 - 0.5D0
            D2 = D2*D2
            DO I = 2, M
               D1 = D1 - 2.D0
               D2 = D2 - D1
               RATIO = (D3 + D2)/(TWOX + D1 - RATIO)
            END DO
C                                  CALCULATION OF I(ABS(ENU),X) AND
C                                    I(ABS(ENU)+1,X) BY BACKWARD
C                                    RECURRENCE AND K(ENU,X) FROM THE
C                                    WRONSKIAN
            M = 2.7782D0*EX + 14.4303D0
            C = DABS(ENU)
            D3 = C + C
            D1 = D3 - 1.D0
            D2 = M
            F1 = DMIN
            F0 = (2.D0*(C + D2)/ARG + 0.5D0*ARG/(C + D2 + 1.D0))*DMIN
            DO I = 3, M
               D2 = D2 - 1.D0
               F2 = (D3 + D2 + D2)*F0
               ALPHA = (1.D0 + D1/D2)*(F2 + ALPHA)
               F2 = F2/ARG + F1
               F1 = F0
               F0 = F2
            END DO
            F1 = (D3 + 2.D0)*F0/ARG + F1
            D1 = 0.D0
            T1 = 1.D0
            DO I = 1, 7
               D1 = C*D1 + P(I)
            END DO
            DO I = 1, 7
               T1 = C*T1 + Q(I)
            END DO
            P0 = DEXP(C*(A + C*(P(8)-C*D1/T1)-DLOG(ARG)))/ARG
            F2 = (C + 0.5D0 - RATIO)*F1/ARG
            BK1 = P0 + (D3*F0 - F2 + F0 + ALPHA)/(F2 + F1 + F0)*P0
            DMINF = 4.263D0*EX + 23.977D0
         ELSE
C                                  X .GT. 4.0
C                                    CALCULATION OF K(ENU,X) AND
C                                    K(ENU+1,X)/K(ENU,X) BY BACKWARD
C                                    RECURRENCE
            M = 185.3004D0/EX + 9.3715D0
            DM = M
            D2 = DM - 0.5D0
            D2 = D2*D2
            D1 = DM + DM
            DO I = 2, M
               DM = DM - 1.D0
               D1 = D1 - 2.D0
               D2 = D2 - D1
               RATIO = (D3 + D2)/(TWOX + D1 - RATIO)
               ALPHA = (RATIO + RATIO*ALPHA)/DM
            END DO
            BK1 = 1.D0/((D + D*ALPHA)*DSQRT(ARG))
            DMINF = 0.94219D0*(EX - DABS(EX - 20.D0)) + 52.3363D0
C
C                                  CALCULATION OF K(ENU+1,X) FROM
C                                    K(ENU,X) AND K(ENU+1,X)/K(ENU,X)
         ENDIF
         BK2 = BK1 + BK1*(ENU + 0.5D0 - RATIO)/ARG
C
C                                  CALCULATION OF  IER , K(ORDER+I,X),
C                                    I = 0, 1, . . ., IER-1, ..
C                                    K(ORDER+I,X)/K(ORDER+I-1,X),
C                                    I = IER, IER+1, . . ., N
      ENDIF
      BK(1) = BK1
      IF (IEND == 0) GO TO 9005
      J = 2 - K
      IF (J > 0) BK(J) = BK2
      IF (IEND == 1) GO TO 9005
      M = DMINF - ENU
      M = MIN0(IEND,M)
      DO I = 2, M
         T1 = BK1
         BK1 = BK2
         TWONU = TWONU + 2.D0
         BK2 = TWONU/ARG*BK1 + T1
         J = J + 1
         IF (J > 0) BK(J) = BK2
      END DO
      IF (M == IEND) GO TO 9005
      RATIO = BK2/BK1
      MPLUS1 = M + 1
      IER = 130
      KK = 1
      DO I = MPLUS1, IEND
         TWONU = TWONU + 2.D0
         RATIO = TWONU/ARG + 1.D0/RATIO
         J = J + 1
         IF (J > 1) THEN
            BK(J) = RATIO
         ELSE
            TEMP = DMAX/RATIO
            IF (BK2 >= TEMP) GO TO 155
            BK2 = RATIO*BK2
         ENDIF
      END DO
      JER = MPLUS1 - K
      IF (JER <= 0) JER = 1
      IF (JER == 1) BK(1) = BK2
      IF (N == 1) GO TO 9005
  140 CONTINUE
      J = JER + 1
      DO I = J, N
         IER = 131 + I
         TEMP = DMAX/BK(I)
         IF (BK(I-1) >= TEMP) GO TO 150
         BK(I) = BK(I-1)*BK(I)
      END DO
      IER = 0
      GO TO 9005
  150 CONTINUE
      KK = IER - 131
  155 CONTINUE
      BK(KK:N) = XINF
 9000 CONTINUE
      CALL UERTST (IER, 6HMMBSKR)
 9005 CONTINUE
      RETURN 
      END SUBROUTINE MMBSKR
C   IMSL ROUTINE NAME   - UERTST
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1982
C
C   PURPOSE             - PRINT A MESSAGE REFLECTING AN ERROR CONDITION
C
C   USAGE               - CALL UERTST (IER,NAME)
C
C   ARGUMENTS    IER    - ERROR PARAMETER. (INPUT)
C                           IER = I+J WHERE
C                             I = 128 IMPLIES TERMINAL ERROR MESSAGE,
C                             I =  64 IMPLIES WARNING WITH FIX MESSAGE,
C                             I =  32 IMPLIES WARNING MESSAGE.
C                             J = ERROR CODE RELEVANT TO CALLING
C                                 ROUTINE.
C                NAME   - A CHARACTER STRING OF LENGTH SIX PROVIDING
C                           THE NAME OF THE CALLING ROUTINE. (INPUT)
C
C   PRECISION/HARDWARE  - SINGLE/ALL
C
C   REQD. IMSL ROUTINES - UGETIO,USPKD
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   REMARKS      THE ERROR MESSAGE PRODUCED BY UERTST IS WRITTEN
C                TO THE STANDARD OUTPUT UNIT. THE OUTPUT UNIT
C                NUMBER CAN BE DETERMINED BY CALLING UGETIO AS
C                FOLLOWS..   CALL UGETIO(1,NIN,NOUT).
C                THE OUTPUT UNIT NUMBER CAN BE CHANGED BY CALLING
C                UGETIO AS FOLLOWS..
C                                NIN = 0
C                                NOUT = NEW OUTPUT UNIT NUMBER
C                                CALL UGETIO(3,NIN,NOUT)
C                SEE THE UGETIO DOCUMENT FOR MORE DETAILS.
C
C   COPYRIGHT           - 1982 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE UERTST(IER, NAME)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IER
      INTEGER, DIMENSION(1) :: NAME
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: I, IEQ, IEQDF, IOUNIT, LEVEL, LEVOLD
      INTEGER, DIMENSION(6) :: NAMEQ, NAMSET, NAMUPK
      INTEGER :: NIN, NMTB
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      REAL , EXTERNAL :: WRITE
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      DATA NAMSET/1HU, 1HE, 1HR, 1HS, 1HE, 1HT/
      DATA NAMEQ/6*1H /
      DATA LEVEL/4/
      DATA IEQDF/0/
      DATA IEQ/1H=/
C                                  UNPACK NAME INTO NAMUPK
C                                  FIRST EXECUTABLE STATEMENT
      CALL USPKD (NAME, 6, NAMUPK, NMTB)
C                                  GET OUTPUT UNIT NUMBER
      CALL UGETIO (1, NIN, IOUNIT)
C                                  CHECK IER
      IF (IER > 999) GO TO 25
      IF (IER < (-32)) GO TO 55
      IF (IER > 128) THEN
         IF (LEVEL < 1) GO TO 30
C                                  PRINT TERMINAL MESSAGE
         IF (IEQDF == 1) WRITE (IOUNIT, 35) IER, NAMEQ, IEQ, NAMUPK
         IF (IEQDF == 0) WRITE (IOUNIT, 35) IER, NAMUPK
         GO TO 30
      ENDIF
      IF (IER > 64) THEN
         IF (LEVEL < 2) GO TO 30
C                                  PRINT WARNING WITH FIX MESSAGE
         IF (IEQDF == 1) WRITE (IOUNIT, 40) IER, NAMEQ, IEQ, NAMUPK
         IF (IEQDF == 0) WRITE (IOUNIT, 40) IER, NAMUPK
         GO TO 30
      ENDIF
      IF (IER > 32) THEN
C                                  PRINT WARNING MESSAGE
         IF (LEVEL < 3) GO TO 30
         IF (IEQDF == 1) WRITE (IOUNIT, 45) IER, NAMEQ, IEQ, NAMUPK
         IF (IEQDF == 0) WRITE (IOUNIT, 45) IER, NAMUPK
         GO TO 30
      ENDIF
C                                  CHECK FOR UERSET CALL
      DO I = 1, 6
         IF (NAMUPK(I) /= NAMSET(I)) GO TO 25
      END DO
      LEVOLD = LEVEL
      LEVEL = IER
      IER = LEVOLD
      IF (LEVEL < 0) LEVEL = 4
      LEVEL = MIN0(4,LEVEL)
      GO TO 30
   25 CONTINUE
      IF (LEVEL >= 4) THEN
C                                  PRINT NON-DEFINED MESSAGE
         IF (IEQDF == 1) WRITE (IOUNIT, 50) IER, NAMEQ, IEQ, NAMUPK
         IF (IEQDF == 0) WRITE (IOUNIT, 50) IER, NAMUPK
      ENDIF
   30 CONTINUE
      IEQDF = 0
      RETURN 
   35 FORMAT(' *** TERMINAL ERROR',10X,'(IER = ',I3,
     1   ') FROM IMSL ROUTINE ',6A1,A1,6A1)
   40 FORMAT(' *** WARNING WITH FIX ERROR',2X,'(IER = ',I3,
     1   ') FROM IMSL ROUTINE ',6A1,A1,6A1)
   45 FORMAT(' *** WARNING ERROR',11X,'(IER = ',I3,
     1   ') FROM IMSL ROUTINE ',6A1,A1,6A1)
   50 FORMAT(' *** UNDEFINED ERROR',9X,'(IER = ',I5,
     1   ') FROM IMSL ROUTINE ',6A1,A1,6A1)
C
C                                  SAVE P FOR P = R CASE
C                                    P IS THE PAGE NAMUPK
C                                    R IS THE ROUTINE NAMUPK
   55 CONTINUE
      IEQDF = 1
      NAMEQ = NAMUPK
      RETURN 
      END SUBROUTINE UERTST
C   IMSL ROUTINE NAME   - UGETIO
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1981
C
C   PURPOSE             - TO RETRIEVE CURRENT VALUES AND TO SET NEW
C                           VALUES FOR INPUT AND OUTPUT UNIT
C                           IDENTIFIERS.
C
C   USAGE               - CALL UGETIO(IOPT,NIN,NOUT)
C
C   ARGUMENTS    IOPT   - OPTION PARAMETER. (INPUT)
C                           IF IOPT=1, THE CURRENT INPUT AND OUTPUT
C                           UNIT IDENTIFIER VALUES ARE RETURNED IN NIN
C                           AND NOUT, RESPECTIVELY.
C                           IF IOPT=2, THE INTERNAL VALUE OF NIN IS
C                           RESET FOR SUBSEQUENT USE.
C                           IF IOPT=3, THE INTERNAL VALUE OF NOUT IS
C                           RESET FOR SUBSEQUENT USE.
C                NIN    - INPUT UNIT IDENTIFIER.
C                           OUTPUT IF IOPT=1, INPUT IF IOPT=2.
C                NOUT   - OUTPUT UNIT IDENTIFIER.
C                           OUTPUT IF IOPT=1, INPUT IF IOPT=3.
C
C   PRECISION/HARDWARE  - SINGLE/ALL
C
C   REQD. IMSL ROUTINES - NONE REQUIRED
C
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP
C
C   REMARKS      EACH IMSL ROUTINE THAT PERFORMS INPUT AND/OR OUTPUT
C                OPERATIONS CALLS UGETIO TO OBTAIN THE CURRENT UNIT
C                IDENTIFIER VALUES. IF UGETIO IS CALLED WITH IOPT=2 OR
C                IOPT=3, NEW UNIT IDENTIFIER VALUES ARE ESTABLISHED.
C                SUBSEQUENT INPUT/OUTPUT IS PERFORMED ON THE NEW UNITS.
C
C   COPYRIGHT           - 1978 BY IMSL, INC. ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
C
      SUBROUTINE UGETIO(IOPT, NIN, NOUT)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:53:12   6/14/01  
C...Switches: -p4 -yb
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER IOPT, NIN, NOUT
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: NIND, NOUTD
C-----------------------------------------------
C                                  SPECIFICATIONS FOR ARGUMENTS
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
      DATA NIND/1/
      DATA NOUTD/2/
C                                  FIRST EXECUTABLE STATEMENT
      IF (IOPT /= 3) THEN
         IF (IOPT /= 2) THEN
            IF (IOPT /= 1) GO TO 9005
            NIN = NIND
            NOUT = NOUTD
            GO TO 9005
         ENDIF
         NIND = NIN
         GO TO 9005
      ENDIF
      NOUTD = NOUT
 9005 CONTINUE
      RETURN 
      END SUBROUTINE UGETIO
C   IMSL ROUTINE NAME   - USPKD
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - VAX/SINGLE
C
C   LATEST REVISION     - NOVEMBER 1, 1984
C
C   PURPOSE             - NUCLEUS CALLED BY IMSL ROUTINES THAT HAVE
C                           CHARACTER STRING ARGUMENTS
C
C   USAGE               - CALL USPKD  (PACKED,NCHARS,UNPAKD,NCHMTB)
C
C   ARGUMENTS    PACKED - CHARACTER STRING TO BE UNPACKED.(INPUT)
C                NCHARS - LENGTH OF PACKED. (INPUT)  SEE REMARKS.
C                UNPAKD - INTEGER ARRAY TO RECEIVE THE UNPACKED
C                         REPRESENTATION OF THE STRING. (OUTPUT)
C                NCHMTB - NCHARS MINUS TRAILING BLANKS. (OUTPUT)
C
C   PRECISION/HARDWARE  - SINGLE/ALL
C
C   REQD. IMSL ROUTINES - NONE
C
C   REMARKS  1.  USPKD UNPACKS A CHARACTER STRING INTO AN INTEGER ARRAY
C                IN (A1) FORMAT.
C            2.  UP TO 129 CHARACTERS MAY BE USED.  ANY IN EXCESS OF
C                THAT ARE IGNORED.
C
C   COPYRIGHT           - 1984 BY IMSL, INC.  ALL RIGHTS RESERVED.
C
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN
C                           APPLIED TO THIS CODE.  NO OTHER WARRANTY,
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.
C
C-----------------------------------------------------------------------
      SUBROUTINE USPKD  (PACKED,NCHARS,UNPAKD,NCHMTB)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER            NC,NCHARS,NCHMTB
C
      INTEGER            UNPAKD(1),IBLANK
      INTEGER            PACKED(1)
      DATA               IBLANK /1H /
C                                  INITIALIZE NCHMTB
      NCHMTB = 0
C                                  RETURN IF NCHARS IS LE ZERO
      IF(NCHARS.LE.0) RETURN
C                                  SET NC=NUMBER OF CHARS TO BE DECODED
      NC = MIN0 (129,NCHARS)
      DECODE (NC,150,PACKED) (UNPAKD(I),I=1,NC)
  150 FORMAT (129A1)
C                                  CHECK UNPAKD ARRAY AND SET NCHMTB
C                                  BASED ON TRAILING BLANKS FOUND
      DO 200 N = 1,NC
         NN = NC - N + 1
         IF(UNPAKD(NN) .NE. IBLANK) GO TO 210
  200 CONTINUE
      NN = 0
  210 NCHMTB = NN
      RETURN
      END
