
C   IMSL ROUTINE NAME   - LEQT2F
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - CDC/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)
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION          A(IA,1),B(IA,1),WKAREA(1)
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 5 L=1,N
         DO 5 I=1,N
            WKAREA(JJ)=A(I,L)
            JJ=JJ+1
    5 CONTINUE
C                                  DECOMPOSE A
      CALL LUDATN (WKAREA,N,N,A,IA,IDGT,D1,D2,WKAREA(J),WKAREA(K),
     *             WA,IER)
      IF (IER.GT.128) GO TO 25
      IF (IDGT .EQ. 0 .OR. IER .NE. 0) KK = 1
      DO 15 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 .NE. 0)
     *   CALL LUREFN (WKAREA,N,N,A,IA,B(1,I),IDGT,WKAREA(J),WKAREA(MM),
     *                WKAREA(K),WKAREA(K),JER)
         DO 10 II=1,N
            B(II,I) = WKAREA(MM1+II)
   10    CONTINUE
         IF (JER.NE.0) GO TO 20
   15 CONTINUE
      GO TO 25
   20 IER = 131
   25 JJ=1
      DO 30 J = 1,N
         DO 30 I = 1,N
            A(I,J)=WKAREA(JJ)
            JJ=JJ+1
   30 CONTINUE
      IF (IER .EQ. 0) GO TO 9005
 9000 CONTINUE
      CALL UERTST (IER,6HLEQT2F)
 9005 RETURN
      END
C   IMSL ROUTINE NAME   - LINV2F
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - CDC/SINGLE
C
C   LATEST REVISION     - JUNE 1, 1982
C
C   PURPOSE             - INVERSION OF A MATRIX - FULL STORAGE MODE -
C                           HIGH ACCURACY SOLUTION
C
C   USAGE               - CALL LINV2F (A,N,IA,AINV,IDGT,WKAREA,IER)
C
C   ARGUMENTS    A      - INPUT MATRIX OF DIMENSION N BY N CONTAINING
C                           THE MATRIX TO BE INVERTED.
C                N      - ORDER OF A. (INPUT)
C                IA     - ROW DIMENSION OF MATRICES A AND AINV EXACTLY
C                           AS SPECIFIED IN THE DIMENSION STATEMENT IN
C                           THE CALLING PROGRAM. (INPUT)
C                AINV   - OUTPUT MATRIX OF DIMENSION N BY N CONTAINING
C                           THE INVERSE OF A. A AND AINV MUST OCCUPY
C                           SEPARATE CORE LOCATIONS.
C                IDGT   - INPUT OPTION.
C                         IF IDGT IS GREATER THAN 0, THE ELEMENTS OF A
C                           ARE ASSUMED TO BE CORRECT TO IDGT DECIMAL
C                           DIGITS AND THE ROUTINE PERFORMS AN ACCURACY
C                           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                         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                         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 CHAPTER L
C                             PRELUDE FOR FURTHER DISCUSSION.
C
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32
C                       - SINGLE/H36,H48,H60
C
C   REQD. IMSL ROUTINES - SINGLE/LEQT2F,LUDATN,LUELMN,LUREFN,UERTST,
C                           UGETIO
C                       - DOUBLE/LEQT2F,LUDATN,LUELMN,LUREFN,UERTST,
C                           UGETIO,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           - 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 LINV2F (A,N,IA,AINV,IDGT,WKAREA,IER)
      IMPLICIT REAL*8(A-H,O-Z)
C
      REAL*8             A(IA,N),AINV(IA,N),WKAREA(1),ZERO,ONE
      DATA               ONE/1.0/,ZERO/0.0/
C                                  FIRST EXECUTABLE STATEMENT
C                                  INITIALIZE IER
      IER=0
C                                  SET AINV TO THE N X N
C                                  IDENTITY MATRIX
      DO 10 I = 1,N
         DO 5 J = 1,N
            AINV(I,J) = ZERO
    5    CONTINUE
         AINV(I,I) = ONE
   10 CONTINUE
C                                  COMPUTE THE INVERSE OF A
      CALL LEQT2F (A,N,N,IA,AINV,IDGT,WKAREA,IER)
      IF (IER.EQ.0) GO TO 9005
 9000 CONTINUE
      CALL UERTST (IER,6HLINV2F)
 9005 RETURN
      END
C   IMSL ROUTINE NAME   - LUDATN
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - CDC/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,IER)
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION          A(IA,1),LU(ILU,1),APVT(1),EQUIL(1)
      REAL*8             LU
      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 10 I=1,N
         BIG = ZERO
         DO 5 J=1,N
            P = A(I,J)
            LU(I,J) = P
            P = ABS(P)
            IF (P .GT. BIG) BIG = P
    5    CONTINUE
         IF (BIG .GT. BIGA) BIGA = BIG
         IF (BIG .EQ. ZERO) GO TO 110
         EQUIL(I) = ONE/BIG
   10 CONTINUE
      DO 105 J=1,N
         JM1 = J-1
         IF (JM1 .LT. 1) GO TO 40
C                                  COMPUTE U(I,J), I=1,...,J-1
         DO 35 I=1,JM1
            SUM = LU(I,J)
            IM1 = I-1
            IF (IDGT .EQ. 0) GO TO 25
C                                  WITH ACCURACY TEST
            AI = ABS(SUM)
            WI = ZERO
            IF (IM1 .LT. 1) GO TO 20
            DO 15 K=1,IM1
               T = LU(I,K)*LU(K,J)
               SUM = SUM-T
               WI = WI+ABS(T)
   15       CONTINUE
            LU(I,J) = SUM
   20       WI = WI+ABS(SUM)
            IF (AI .EQ. ZERO) AI = BIGA
            TEST = WI/AI
            IF (TEST .GT. WREL) WREL = TEST
            GO TO 35
C                                  WITHOUT ACCURACY
   25       IF (IM1 .LT. 1) GO TO 35
            DO 30 K=1,IM1
               SUM = SUM-LU(I,K)*LU(K,J)
   30       CONTINUE
            LU(I,J) = SUM
   35    CONTINUE
   40    P = ZERO
C                                  COMPUTE U(J,J) AND L(I,J), I=J+1,...,
         DO 70 I=J,N
            SUM = LU(I,J)
            IF (IDGT .EQ. 0) GO TO 55
C                                  WITH ACCURACY TEST
            AI = ABS(SUM)
            WI = ZERO
            IF (JM1 .LT. 1) GO TO 50
            DO 45 K=1,JM1
               T = LU(I,K)*LU(K,J)
               SUM = SUM-T
               WI = WI+ABS(T)
   45       CONTINUE
            LU(I,J) = SUM
   50       WI = WI+ABS(SUM)
            IF (AI .EQ. ZERO) AI = BIGA
            TEST = WI/AI
            IF (TEST .GT. WREL) WREL = TEST
            GO TO 65
C                                  WITHOUT ACCURACY TEST
   55       IF (JM1 .LT. 1) GO TO 65
            DO 60 K=1,JM1
               SUM = SUM-LU(I,K)*LU(K,J)
   60       CONTINUE
            LU(I,J) = SUM
   65       Q = EQUIL(I)*ABS(SUM)
            IF (P .GE. Q) GO TO 70
            P = Q
            IMAX = I
   70    CONTINUE
C                                  TEST FOR ALGORITHMIC SINGULARITY
         IF (RN+P .EQ. RN) GO TO 110
         IF (J .EQ. IMAX) GO TO 80
C                                  INTERCHANGE ROWS J AND IMAX
         D1 = -D1
         DO 75 K=1,N
            P = LU(IMAX,K)
            LU(IMAX,K) = LU(J,K)
            LU(J,K) = P
   75    CONTINUE
         EQUIL(IMAX) = EQUIL(J)
   80    APVT(J) = IMAX
         D1 = D1*LU(J,J)
   85    IF (ABS(D1) .LE. ONE) GO TO 90
         D1 = D1*SIXTH
         D2 = D2+FOUR
         GO TO 85
   90    IF (ABS(D1) .GE. SIXTH) GO TO 95
         D1 = D1*SIXTN
         D2 = D2-FOUR
         GO TO 90
   95    CONTINUE
         JP1 = J+1
         IF (JP1 .GT. N) GO TO 105
C                                  DIVIDE BY PIVOT ELEMENT U(J,J)
         P = LU(J,J)
         DO 100 I=JP1,N
            LU(I,J) = LU(I,J)/P
  100    CONTINUE
  105 CONTINUE
C                                  PERFORM ACCURACY TEST
      IF (IDGT .EQ. 0) GO TO 9005
      P = 3*N+3
      WA = P*WREL
      IF (WA+10.0**(-IDGT) .NE. WA) GO TO 9005
      IER = 34
      GO TO 9000
C                                  ALGORITHMIC SINGULARITY
  110 IER = 129
      D1 = ZERO
      D2 = ZERO
 9000 CONTINUE
C                                  PRINT ERROR
      CALL UERTST(IER,6HLUDATN)
 9005 RETURN
      END
C   IMSL ROUTINE NAME   - LUELMN
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - CDC/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)
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION          A(IA,1),B(1),APVT(1),X(1)
C                                  FIRST EXECUTABLE STATEMENT
C                                  SOLVE LY = B FOR Y
      DO 5 I=1,N
    5 X(I) = B(I)
      IW = 0
      DO 20 I=1,N
         IP = APVT(I)
         SUM = X(IP)
         X(IP) = X(I)
         IF (IW .EQ. 0) GO TO 15
         IM1 = I-1
         DO 10 J=IW,IM1
            SUM = SUM-A(I,J)*X(J)
   10    CONTINUE
         GO TO 20
   15    IF (SUM .NE. 0.) IW = I
   20 X(I) = SUM
C                                  SOLVE UX = Y FOR X
      DO 30 IB=1,N
         I = N+1-IB
         IP1 = I+1
         SUM = X(I)
         IF (IP1 .GT. N) GO TO 30
         DO 25 J=IP1,N
            SUM = SUM-A(I,J)*X(J)
   25   CONTINUE
   30 X(I) = SUM/A(I,I)
      RETURN
      END
C   IMSL ROUTINE NAME   - LUREFN
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - CDC/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,IER)
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION          A(IA,1),UL(IUL,1),B(1),X(1),RES(1),DX(1)
      DIMENSION          APVT(1)
      DOUBLE PRECISION   SUM
      DATA               ITMAX/50/,ZERO/0.0/
C                                  FIRST EXECUTABLE STATEMENT
      IER=0
      XNORM = ZERO
      DO 10 I=1,N
         XNORM = DMAX1(XNORM,ABS(X(I)))
   10 CONTINUE
      IF (XNORM .NE. ZERO) GO TO 20
      IDGT = 50
      GO TO 9005
   20 DO 45 ITER=1,ITMAX
         DO 30 I=1,N
            SUM = DBLE(B(I))
            DO 25 J=1,N
               SUM = SUM - DBLE(A(I,J)) * DBLE(X(J))
   25       CONTINUE
            RES(I) = SUM
   30    CONTINUE
         CALL LUELMN (UL,IUL,N,RES,APVT,DX)
         DXNORM = ZERO
         XNORM = ZERO
         DO 35 I=1,N
            X(I) = X(I) + DX(I)
            DXNORM = DMAX1(DXNORM,ABS(DX(I)))
            XNORM = DMAX1(XNORM,ABS(X(I)))
   35    CONTINUE
         IF (ITER .NE. 1) GO TO 40
         IDGT = 50
         IF (DXNORM .NE. ZERO) IDGT = -DLOG10(DXNORM/XNORM)
   40    IF (XNORM+DXNORM .EQ. XNORM) GO TO 9005
   45 CONTINUE
C                                  ITERATION DID NOT CONVERGE
      IER = 129
 9000 CONTINUE
      CALL UERTST(IER,6HLUREFN)
 9005 RETURN
      END
C   IMSL ROUTINE NAME   - UERTST
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - CDC/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)
      IMPLICIT REAL*8(A-H,O-Z)
C                                  SPECIFICATIONS FOR ARGUMENTS
      INTEGER            IER
      CHARACTER*1        NAME(6),NAMSET(6),NAMEQ(6)
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
C     INTEGER            I,IEQ,IEQDF,IOUNIT,LEVEL,LEVOLD,NAMEQ(6),
      INTEGER            I,IEQ,IEQDF,IOUNIT,LEVEL,LEVOLD,
     *                   NIN,NMTB
      DATA               NAMSET/1HU,1HE,1HR,1HS,1HE,1HT/
      DATA               NAMEQ/6*1H /
      DATA               LEVEL/4/,IEQDF/0/,IEQ/1H=/
C                                  GET OUTPUT UNIT NUMBER
C     CALL UGETIO(1,NIN,IOUNIT)
C                                  CHECK IER
      IF (IER.GT.999) GO TO 25
      IF (IER.LT.-32) GO TO 55
      IF (IER.LE.128) GO TO 5
      IF (LEVEL.LT.1) GO TO 30
C                                  PRINT TERMINAL MESSAGE
      IF (IEQDF.EQ.1) WRITE(8,35) IER,NAMEQ,IEQ,NAME
      IF (IEQDF.EQ.0) WRITE(8,35) IER,NAME
      GO TO 30
    5 IF (IER.LE.64) GO TO 10
      IF (LEVEL.LT.2) GO TO 30
C                                  PRINT WARNING WITH FIX MESSAGE
      IF (IEQDF.EQ.1) WRITE(8,40) IER,NAMEQ,IEQ,NAME
      IF (IEQDF.EQ.0) WRITE(8,40) IER,NAME
      GO TO 30
   10 IF (IER.LE.32) GO TO 15
C                                  PRINT WARNING MESSAGE
      IF (LEVEL.LT.3) GO TO 30
      IF (IEQDF.EQ.1) WRITE(8,45) IER,NAMEQ,IEQ,NAME
      IF (IEQDF.EQ.0) WRITE(8,45) IER,NAME
      GO TO 30
   15 CONTINUE
C                                  CHECK FOR UERSET CALL
      DO 20 I=1,6
         IF (NAME(I).NE.NAMSET(I)) GO TO 25
   20 CONTINUE
      LEVOLD = LEVEL
      LEVEL = IER
      IER = LEVOLD
      IF (LEVEL.LT.0) LEVEL = 4
      IF (LEVEL.GT.4) LEVEL = 4
      GO TO 30
   25 CONTINUE
      IF (LEVEL.LT.4) GO TO 30
C                                  PRINT NON-DEFINED MESSAGE
      IF (IEQDF.EQ.1) WRITE(8,50) IER,NAMEQ,IEQ,NAME
      IF (IEQDF.EQ.0) WRITE(8,50) IER,NAME
   30 IEQDF = 0
      RETURN
   35 FORMAT(19H *** TERMINAL ERROR,10X,7H(IER = ,I3,
     1       20H) FROM IMSL ROUTINE ,6A1,A1,6A1)
   40 FORMAT(27H *** WARNING WITH FIX ERROR,2X,7H(IER = ,I3,
     1       20H) FROM IMSL ROUTINE ,6A1,A1,6A1)
   45 FORMAT(18H *** WARNING ERROR,11X,7H(IER = ,I3,
     1       20H) FROM IMSL ROUTINE ,6A1,A1,6A1)
   50 FORMAT(20H *** UNDEFINED ERROR,9X,7H(IER = ,I5,
     1       20H) FROM IMSL ROUTINE ,6A1,A1,6A1)
C
C                                  SAVE P FOR P = R CASE
C                                    P IS THE PAGE NAME
C                                    R IS THE ROUTINE NAME
   55 IEQDF = 1
      DO 60 I=1,6
   60 NAMEQ(I) = NAME(I)
   65 RETURN
      END
C   IMSL ROUTINE NAME   - UGETIO
C
C-----------------------------------------------------------------------
C
C   COMPUTER            - CDC/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
C     SUBROUTINE UGETIO(IOPT,NIN,NOUT)
C     IMPLICIT REAL*8(A-H,O-Z)
C                                  SPECIFICATIONS FOR ARGUMENTS
C     INTEGER            IOPT,NIN,NOUT
C                                  SPECIFICATIONS FOR LOCAL VARIABLES
C     INTEGER            NIND,NOUTD
C     DATA               NIND/5HINPUT/
C     DATA               NOUTD/6HOUTPUT/
C                                  FIRST EXECUTABLE STATEMENT
C     IF (IOPT.EQ.3) GO TO 10
C     IF (IOPT.EQ.2) GO TO 5
C     IF (IOPT.NE.1) GO TO 9005
C     NIN = NIND
C     NOUT = NOUTD
C     GO TO 9005
C   5 NIND = NIN
C     GO TO 9005
C  10 NOUTD = NOUT
C9005 RETURN
C     END
