c **********************************************************************
c This SOFTWARE  has been authored  by an employee   or employees of the
c University  of  California, operator    of the  Los   Alamos  National
c Laboratory  under Contract No. W-7405-ENG-36  with the U.S. Department
c of  Energy.   The U.S. Government  has  rights to use,  reproduce, and
c distribute this SOFTWARE.   The  public may copy,  prepare  derivative
c works and publicly display this SOFTWARE without charge, provided that
c this  Notice  and any statement  of  authorship are  reproduced on all
c copies.  Neither the Government nor the University makes any warranty,
c express or implied, or assumes any liability or responsibility for the
c use  of this SOFTWARE.  If SOFTWARE  is modified to produce derivative
c works, such  modified SOFTWARE should be clearly  marked, so as not to
c confuse it with the version available from LANL.
c
c It is expressly forbidden to distribute this code, in whole or in part,
c either as is or modified.
c **********************************************************************

      SUBROUTINE RSP(NM,N,NV,A,W,MATZ,Z,FV1,FV2,IERR)
C***BEGIN PROLOGUE  RSP
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  861211   (YYMMDD)
C***CATEGORY NO.  D4A1
C***KEYWORDS  LIBRARY=SLATEC(EISPACK),TYPE=SINGLE PRECISION(RSP-S),
C             EIGENVALUES,EIGENVECTORS
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Compute eigenvalues and, optionally, eigenvectors of
C            real symmetric matrix packed into a one dimensional
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     of a REAL SYMMETRIC PACKED matrix.
C
C     On Input
C
C        NM  must be set to the row dimension of the two-dimensional
C        array parameters as declared in the calling program
C        dimension statement.
C
C        N  is the order of the matrix  A.
C
C        NV  is an integer variable set equal to the
C        dimension of the array  A  as specified for
C        A  in the calling program.  NV  must not be
C        less than  N*(N+1)/2.
C
C        A  contains the lower triangle of the real symmetric
C        packed matrix stored row-wise.
C
C        MATZ  is an integer variable set equal to zero if
C        only eigenvalues are desired.  Otherwise it is set to
C        any non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        W  contains the eigenvalues in ascending order.
C
C        Z  contains the eigenvectors if MATZ is not zero.
C
C        IERR  is an integer output variable set equal to an
C        error completion code described in section 2B OF the
C        documentation.  The normal completion code is zero.
C
C        FV1  and  FV2  are temporary storage arrays.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  TQL2,TQLRAT,TRBAK3,TRED3
C***END PROLOGUE  RSP
C
      implicit real*8(a-h,o-z)
      INTEGER I,J,N,NM,NV,IERR,MATZ
      REAL*8 A(NV),W(N),Z(NM,N),FV1(N),FV2(N)

C***FIRST EXECUTABLE STATEMENT  RSP
      IF (N .LE. NM) GO TO 5
      IERR = 10 * N
      GO TO 50
    5 IF (NV .GE. (N * (N + 1)) / 2) GO TO 10
      IERR = 20 * N
      GO TO 50

   10 CALL  TRED3(N,NV,A,W,FV1,FV2)
      IF (MATZ .gt. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      if(matz.eq.0) then
        CALL  TQLRAT(N,W,FV2,IERR)
      else if(matz.eq.-1) then
        CALL  TQL2x(NM,N,W,FV1,IERR)
      end if

      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 DO 40 I = 1, N

         DO 30 J = 1, N
            Z(J,I) = 0.0d0
   30    CONTINUE

         Z(I,I) = 1.0d0
   40 CONTINUE

      CALL  TQL2(NM,N,W,FV1,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  TRBAK3(NM,N,NV,A,N,Z)
   50 RETURN
      END
      SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
C***BEGIN PROLOGUE  TQL2
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  861211   (YYMMDD)
C***CATEGORY NO.  D4A5,D4C2A
C***KEYWORDS  LIBRARY=SLATEC(EISPACK),TYPE=SINGLE PRECISION(TQL2-S),
C             EIGENVALUES,EIGENVECTORS
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Compute eigenvalues and eigenvectors of symmetric
C            tridiagonal matrix.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TQL2,
C     NUM. MATH. 11, 293-306(1968) by Bowdler, Martin, Reinsch, and
C     Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
C
C     This subroutine finds the eigenvalues and eigenvectors
C     of a SYMMETRIC TRIDIAGONAL matrix by the QL method.
C     The eigenvectors of a FULL SYMMETRIC matrix can also
C     be found if  TRED2  has been used to reduce this
C     full matrix to tridiagonal form.
C
C     On Input
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        D contains the diagonal elements of the input matrix.
C
C        E contains the subdiagonal elements of the input matrix
C          in its last N-1 positions.  E(1) is arbitrary.
C
C        Z contains the transformation matrix produced in the
C          reduction by  TRED2, if performed.  If the eigenvectors
C          of the tridiagonal matrix are desired, Z must contain
C          the identity matrix.
C
C      On Output
C
C        D contains the eigenvalues in ascending order.  If an
C          error exit is made, the eigenvalues are correct but
C          unordered for indices 1,2,...,IERR-1.
C
C        E has been destroyed.
C
C        Z contains orthonormal eigenvectors of the symmetric
C          tridiagonal (or full) matrix.  If an error exit is made,
C          Z contains the eigenvectors associated with the stored
C          eigenvalues.
C
C        IERR is set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***END PROLOGUE  TQL2
C
      implicit real*8(a-h,o-z)
      INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR
      REAL*8 D(N),E(N),Z(NM,N)
      REAL*8 B,C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2
      REAL*8 PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  TQL2
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      F = 0.0d0
      B = 0.0d0
      E(N) = 0.0d0
C
      DO 240 L = 1, N
         J = 0
         H = ABS(D(L)) + ABS(E(L))
         IF (B .LT. H) B = H
C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
         DO 110 M = L, N
            IF (B + ABS(E(M)) .EQ. B) GO TO 120
C     .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP ..........
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 220
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         L1 = L + 1
         L2 = L1 + 1
         G = D(L)
         P = (D(L1) - G) / (2.0d0 * E(L))
         R = PYTHAG(P,1.0d0)
         D(L) = E(L) / (P + SIGN(R,P))
         D(L1) = E(L) * (P + SIGN(R,P))
         DL1 = D(L1)
         H = G - D(L)
         IF (L2 .GT. N) GO TO 145
C
         DO 140 I = L2, N
  140    D(I) = D(I) - H
C
  145    F = F + H
C     .......... QL TRANSFORMATION ..........
         P = D(M)
         C = 1.0d0
         C2 = C
         EL1 = E(L1)
         S = 0.0d0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            C3 = C2
            C2 = C
            S2 = S
            I = M - II
            G = C * E(I)
            H = C * P
            IF (ABS(P) .LT. ABS(E(I))) GO TO 150
            C = E(I) / P
            R = SQRT(C*C+1.0d0)
            E(I+1) = S * P * R
            S = C / R
            C = 1.0d0 / R
            GO TO 160
  150       C = P / E(I)
            R = SQRT(C*C+1.0d0)
            E(I+1) = S * E(I) * R
            S = 1.0d0 / R
            C = C * S
  160       P = C * D(I) - S * G
            D(I+1) = H + S * (C * G + S * D(I))
C     .......... FORM VECTOR ..........
            DO 180 K = 1, N
               H = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * H
               Z(K,I) = C * Z(K,I) - S * H
  180       CONTINUE
C
  200    CONTINUE
C
         P = -S * S2 * C3 * EL1 * E(L) / DL1
         E(L) = S * P
         D(L) = C * P
         IF (B + ABS(E(L)) .GT. B) GO TO 130
  220    D(L) = D(L) + F
  240 CONTINUE
C     .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
C
  300 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END
      SUBROUTINE TQLRAT(N,D,E2,IERR)
C***BEGIN PROLOGUE  TQLRAT
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  861211   (YYMMDD)
C***CATEGORY NO.  D4A5,D4C2A
C***KEYWORDS  LIBRARY=SLATEC(EISPACK),TYPE=SINGLE PRECISION(TQLRAT-S),
C             EIGENVALUES,EIGENVECTORS
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Computes eigenvalues of symmetric tridiagonal matrix
C            a rational variant of the QL method.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TQLRAT,
C     ALGORITHM 464, COMM. ACM 16, 689(1973) by Reinsch.
C
C     This subroutine finds the eigenvalues of a SYMMETRIC
C     TRIDIAGONAL matrix by the rational QL method.
C
C     On Input
C
C        N is the order of the matrix.
C
C        D contains the diagonal elements of the input matrix.
C
C        E2 contains the squares of the subdiagonal elements of the
C          input matrix in its last N-1 positions.  E2(1) is arbitrary.
C
C      On Output
C
C        D contains the eigenvalues in ascending order.  If an
C          error exit is made, the eigenvalues are correct and
C          ordered for indices 1,2,...IERR-1, but may not be
C          the smallest eigenvalues.
C
C        E2 has been destroyed.
C
C        IERR is set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***END PROLOGUE  TQLRAT
C
      implicit real*8(a-h,o-z)
      INTEGER I,J,L,M,N,II,L1,MML,IERR
      REAL*8 D(N),E2(N)
      REAL*8 B,C,F,G,H,P,R,S,MACHEP
      REAL*8 PYTHAG
C
      SAVE MACHEP
      DATA MACHEP/1.0d0/
C***FIRST EXECUTABLE STATEMENT  TQLRAT
      IF (MACHEP .NE. 1.0d0) GO TO 10
   05 MACHEP = 0.5d0*MACHEP
      IF (1.0d0 + MACHEP .GT. 1.0E0) GO TO 05
      MACHEP = 2.0d0*MACHEP
C
   10 IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E2(I-1) = E2(I)
C
      F = 0.0d0
      B = 0.0d0
      E2(N) = 0.0d0
C
      DO 290 L = 1, N
         J = 0
         H = MACHEP * (ABS(D(L)) + SQRT(E2(L)))
         IF (B .GT. H) GO TO 105
         B = H
         C = B * B
C     .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ..........
  105    DO 110 M = L, N
            IF (E2(M) .LE. C) GO TO 120
C     .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP ..........
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 210
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         L1 = L + 1
         S = SQRT(E2(L))
         G = D(L)
         P = (D(L1) - G) / (2.0d0 * S)
         R = PYTHAG(P,1.0d0)
         D(L) = S / (P + SIGN(R,P))
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     .......... RATIONAL QL TRANSFORMATION ..........
         G = D(M)
         IF (G .EQ. 0.0d0) G = B
         H = G
         S = 0.0d0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            I = M - II
            P = G * H
            R = P + E2(I)
            E2(I+1) = S * R
            S = E2(I) / R
            D(I+1) = H + S * (H + D(I))
            G = D(I) - E2(I) / G
            IF (G .EQ. 0.0d0) G = B
            H = G * P / R
  200    CONTINUE
C
         E2(L) = S * G
         D(L) = H
C     .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ..........
         IF (H .EQ. 0.0d0) GO TO 210
         IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210
         E2(L) = H * E2(L)
         IF (E2(L) .NE. 0.0d0) GO TO 130
  210    P = D(L) + F
C     .......... ORDER EIGENVALUES ..........
         IF (L .EQ. 1) GO TO 250
C     .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. D(I-1)) GO TO 270
            D(I) = D(I-1)
  230    CONTINUE
C
  250    I = 1
  270    D(I) = P
  290 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END
      SUBROUTINE TRBAK3(NM,N,NV,A,M,Z)
C***BEGIN PROLOGUE  TRBAK3
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  861211   (YYMMDD)
C***CATEGORY NO.  D4C4
C***KEYWORDS  LIBRARY=SLATEC(EISPACK),TYPE=SINGLE PRECISION(TRBAK3-S),
C             EIGENVALUES,EIGENVECTORS
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Forms eigenvectors of real symmetric matrix from the
C            eigenvectors of symmetric tridiagonal matrix formed
C            TRED3.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TRBAK3,
C     NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     This subroutine forms the eigenvectors of a REAL SYMMETRIC
C     matrix by back transforming those of the corresponding
C     symmetric tridiagonal matrix determined by  TRED3.
C
C     On Input
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        NV must be set to the dimension of the array parameter A
C          as declared in the calling program dimension statement.
C
C        A contains information about the orthogonal transformations
C          used in the reduction by  TRED3  in its first
C          N*(N+1)/2 positions.
C
C        M is the number of eigenvectors to be back transformed.
C
C        Z contains the eigenvectors to be back transformed
C          in its first M columns.
C
C     On Output
C
C        Z contains the transformed eigenvectors
C          in its first M columns.
C
C     Note that TRBAK3 preserves vector Euclidean norms.
C
C     Questions and comments should be directed to b. s. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  TRBAK3
C
      implicit real*8(a-h,o-z)
      INTEGER I,J,K,L,M,N,IK,IZ,NM,NV
      REAL*8 A(NV),Z(NM,M)
      REAL*8 H,S
C
C***FIRST EXECUTABLE STATEMENT  TRBAK3
      IF (M .EQ. 0) GO TO 200
      IF (N .EQ. 1) GO TO 200
C
      DO 140 I = 2, N
         L = I - 1
         IZ = (I * L) / 2
         IK = IZ + I
         H = A(IK)
         IF (H .EQ. 0.0d0) GO TO 140
C
         DO 130 J = 1, M
            S = 0.0d0
            IK = IZ
C
            DO 110 K = 1, L
               IK = IK + 1
               S = S + A(IK) * Z(K,J)
  110       CONTINUE
C     .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
            S = (S / H) / H
            IK = IZ
C
            DO 120 K = 1, L
               IK = IK + 1
               Z(K,J) = Z(K,J) - S * A(IK)
  120       CONTINUE
C
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE TRED3(N,NV,A,D,E,E2)
C***BEGIN PROLOGUE  TRED3
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  861211   (YYMMDD)
C***CATEGORY NO.  D4C1B1
C***KEYWORDS  LIBRARY=SLATEC(EISPACK),TYPE=SINGLE PRECISION(TRED3-S),
C             EIGENVALUES,EIGENVECTORS
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Reduce real symmetric matrix stored in packed form to
C            symmetric tridiagonal matrix using orthogonal
C            transformations.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TRED3,
C     NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     This subroutine reduces a REAL SYMMETRIC matrix, stored as
C     a one-dimensional array, to a symmetric tridiagonal matrix
C     using orthogonal similarity transformations.
C
C     On Input
C
C        n is the order of the matrix.
C
C        NV must be set to the dimension of the array parameter A
C          as declared in the calling program dimension statement.
C
C        A contains the lower triangle of the real symmetric
C          input matrix, stored row-wise as a one-dimensional
C          array, in its first N*(N+1)/2 positions.
C
C     On Output
C
C        A contains information about the orthogonal
C          transformations used in the reduction.
C
C        D contains the diagonal elements of the tridiagonal matrix.
C
C        E contains the subdiagonal elements of the tridiagonal
C          matrix in its last N-1 positions.  E(1) is set to zero.
C
C        E2 contains the squares of the corresponding elements of E.
C          E2 may coincide with E if the squares are not needed.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  TRED3
C
      implicit real*8(a-h,o-z)
      INTEGER I,J,K,L,N,II,IZ,JK,NV
      REAL*8 A(NV),D(N),E(N),E2(N)
      REAL*8 F,G,H,HH,SCALE
C
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
C***FIRST EXECUTABLE STATEMENT  TRED3
      DO  300 II = 1, N
         I = N + 1 - II
         L = I - 1
         IZ = (I * L) / 2
         H = 0.0d0
         SCALE = 0.0d0
         IF (L .LT. 1) GO TO 130
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........
         DO 120 K = 1, L
            IZ = IZ + 1
            D(K) = A(IZ)
            SCALE = SCALE + ABS(D(K))
  120    CONTINUE
C
         IF (SCALE .NE. 0.0d0) GO TO 140
  130    E(I) = 0.0d0
         E2(I) = 0.0d0
         GO TO 290
C
  140    DO 150 K = 1, L
            D(K) = D(K) / SCALE
            H = H + D(K) * D(K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = D(L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         D(L) = F - G
         A(IZ) = SCALE * D(L)
         IF (L .EQ. 1) GO TO 290
         F = 0.0d0
C
         DO 240 J = 1, L
            G = 0.0d0
            JK = (J * (J-1)) / 2
C     .......... FORM ELEMENT OF A*U ..........
            DO 180 K = 1, L
               JK = JK + 1
               IF (K .GT. J) JK = JK + K - 2
               G = G + A(JK) * D(K)
  180       CONTINUE
C     .......... FORM ELEMENT OF P ..........
            E(J) = G / H
            F = F + E(J) * D(J)
  240    CONTINUE
C
         HH = F / (H + H)
         JK = 0
C     .......... FORM REDUCED A ..........
         DO 260 J = 1, L
            F = D(J)
            G = E(J) - HH * F
            E(J) = G
C
            DO 260 K = 1, J
               JK = JK + 1
               A(JK) = A(JK) - F * E(K) - G * D(K)
  260    CONTINUE
C
  290    D(I) = A(IZ+1)
         A(IZ+1) = SCALE * SQRT(H)
  300 CONTINUE
C
      RETURN
      END
      REAL*8 FUNCTION PYTHAG(A,B)
C***BEGIN PROLOGUE  PYTHAG
C***REFER TO  EISDOC
C
C     Finds sqrt(A**2+B**2) without overflow or destructive underflow
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  PYTHAG
      implicit real*8(a-h,o-z)
      REAL*8 A,B
C
      REAL*8 P,Q,R,S,T
C***FIRST EXECUTABLE STATEMENT  PYTHAG
      P = MAX(ABS(A),ABS(B))
      Q = MIN(ABS(A),ABS(B))
      IF (Q .EQ. 0.0d0) GO TO 20
   10 CONTINUE
         R = (Q/P)**2
         T = 4.0d0 + R
         IF (T .EQ. 4.0d0) GO TO 20
         S = R/T
         P = P + 2.0d0*P*S
         Q = Q*S
      GO TO 10
   20 PYTHAG = P
      RETURN
      END

cc**** beginning here are the nonredundant subroutines necessary for RS ****

      SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR)                       rs     3
C***BEGIN PROLOGUE  RS                                                  rs     4
C***DATE WRITTEN   760101   (YYMMDD)                                    rs     5
C***REVISION DATE  861211   (YYMMDD)                                    rs     6
C***CATEGORY NO.  D4A1                                                  rs     7
C***KEYWORDS  LIBRARY=SLATEC(EISPACK),TYPE=SINGLE PRECISION(RS-S CH-C), rs     8
C             EIGENVALUES,EIGENVECTORS                                  rs     9
C***AUTHOR  SMITH, B. T., ET AL.                                        rs    10
C***PURPOSE  Computes eigenvalues and, optionally, eigenvectors of      rs    11
C            real symmetric matrix.                                     rs    12
C***DESCRIPTION                                                         rs    13
C                                                                       rs    14
C     This subroutine calls the recommended sequence of                 rs    15
C     subroutines from the eigensystem subroutine package (EISPACK)     rs    16
C     to find the eigenvalues and eigenvectors (if desired)             rs    17
C     of a REAL SYMMETRIC matrix.                                       rs    18
C                                                                       rs    19
C     On Input                                                          rs    20
C                                                                       rs    21
C        NM  must be set to the row dimension of the two-dimensional    rs    22
C        array parameters as declared in the calling program            rs    23
C        dimension statement.                                           rs    24
C                                                                       rs    25
C        N  is the order of the matrix  A.                              rs    26
C                                                                       rs    27
C        A  contains the real symmetric matrix.                         rs    28
C                                                                       rs    29
C        MATZ  is an integer variable set equal to zero if              rs    30
C        only eigenvalues are desired.  Otherwise it is set to          rs    31
C        any non-zero integer for both eigenvalues and eigenvectors.    rs    32
C                                                                       rs    33
C     On Output                                                         rs    34
C                                                                       rs    35
C        W  contains the eigenvalues in ascending order.                rs    36
C                                                                       rs    37
C        Z  contains the eigenvectors if MATZ is not zero.              rs    38
C                                                                       rs    39
C        IERR  is an integer output variable set equal to an            rs    40
C        error completion code described in section 2B of the           rs    41
C        documentation.  The normal completion code is zero.            rs    42
C                                                                       rs    43
C        FV1  and  FV2  are temporary storage arrays.                   rs    44
C                                                                       rs    45
C     Questions and comments should be directed to B. S. Garbow,        rs    46
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY         rs    47
C     ------------------------------------------------------------------rs    48
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW, rs    49
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-    rs    50
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,    rs    51
C                 1976.                                                 rs    52
C***ROUTINES CALLED  TQL2,TQLRAT,TRED1,TRED2                            rs    53
C***END PROLOGUE  RS                                                    rs    54
C     implicit real*8(a-h,o-z)                                                                  rs    55
      INTEGER N,NM,IERR,MATZ                                            rs    56
      REAL*8 A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)                         rs    57
C                                                                       rs    58
C***FIRST EXECUTABLE STATEMENT  RS                                      rs    59
      IF (N .LE. NM) GO TO 10                                           rs    60
      IERR = 10 * N                                                     rs    61
      GO TO 50                                                          rs    62
C                                                                       rs    63
   10 IF (MATZ .NE. 0) GO TO 20                                         rs    64
C     .......... FIND EIGENVALUES ONLY ..........                       rs    65
      CALL  TRED1(NM,N,A,W,FV1,FV2)                                     rs    66
      CALL  TQLRAT(N,W,FV2,IERR)                                        rs    67
      GO TO 50                                                          rs    68
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........      rs    69
   20 CALL  TRED2(NM,N,A,W,FV1,Z)                                       rs    70
      CALL  TQL2(NM,N,W,FV1,Z,IERR)                                     rs    71
   50 RETURN                                                            rs    72
      END                                                               rs    73
      SUBROUTINE TRED1(NM,N,A,D,E,E2)                                   tred1  3
C***BEGIN PROLOGUE  TRED1                                               tred1  4
C***DATE WRITTEN   760101   (YYMMDD)                                    tred1  5
C***REVISION DATE  861211   (YYMMDD)                                    tred1  6
C***CATEGORY NO.  D4C1B1                                                tred1  7
C***KEYWORDS  LIBRARY=SLATEC(EISPACK),TYPE=SINGLE PRECISION(TRED1-S),   tred1  8
C             EIGENVALUES,EIGENVECTORS                                  tred1  9
C***AUTHOR  SMITH, B. T., ET AL.                                        tred1 10
C***PURPOSE  Reduce real symmetric matrix to symmetric tridiagonal      tred1 11
C            matrix using orthogonal similarity transformations.        tred1 12
C***DESCRIPTION                                                         tred1 13
C                                                                       tred1 14
C     This subroutine is a translation of the ALGOL procedure TRED1,    tred1 15
C     NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.   tred1 16
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).   tred1 17
C                                                                       tred1 18
C     This subroutine reduces a REAL SYMMETRIC matrix                   tred1 19
C     to a symmetric tridiagonal matrix using                           tred1 20
C     orthogonal similarity transformations.                            tred1 21
C                                                                       tred1 22
C     On Input                                                          tred1 23
C                                                                       tred1 24
C        NM must be set to the row dimension of two-dimensional         tred1 25
C          array parameters as declared in the calling program          tred1 26
C          dimension statement.                                         tred1 27
C                                                                       tred1 28
C        N is the order of the matrix.                                  tred1 29
C                                                                       tred1 30
C        A contains the real symmetric input matrix.  Only the          tred1 31
C          lower triangle of the matrix need be supplied.               tred1 32
C                                                                       tred1 33
C     On Output                                                         tred1 34
C                                                                       tred1 35
C        A contains information about the orthogonal trans-             tred1 36
C          formations used in the reduction in its strict lower         tred1 37
C          triangle.  The full upper triangle of A is unaltered.        tred1 38
C                                                                       tred1 39
C        D contains the diagonal elements of the tridiagonal matrix.    tred1 40
C                                                                       tred1 41
C        E contains the subdiagonal elements of the tridiagonal         tred1 42
C          matrix in its last N-1 positions.  E(1) is set to zero.      tred1 43
C                                                                       tred1 44
C        E2 contains the squares of the corresponding elements of E.    tred1 45
C          E2 may coincide with E if the squares are not needed.        tred1 46
C                                                                       tred1 47
C     Questions and comments should be directed to B. S. Garbow,        tred1 48
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY         tred1 49
C     ------------------------------------------------------------------tred1 50
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW, tred1 51
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-    tred1 52
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,    tred1 53
C                 1976.                                                 tred1 54
C***ROUTINES CALLED  (NONE)                                             tred1 55
C***END PROLOGUE  TRED1                                                 tred1 56
C                                                                       tred1 57
      implicit real*8 (a-h,o-z)
      INTEGER I,J,K,L,N,II,NM,JP1                                       tred1 58
      REAL*8 A(NM,N),D(N),E(N),E2(N)                                      tred1 59
      REAL*8 F,G,H,SCALE                                                  tred1 60
C                                                                       tred1 61
C***FIRST EXECUTABLE STATEMENT  TRED1                                   tred1 62
      write(6,*) 'hello from tred1'
      DO 100 I = 1, N                                                   tred1 63
  100 D(I) = A(I,I)                                                     tred1 64
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........               tred1 65
      DO 300 II = 1, N                                                  tred1 66
         I = N + 1 - II                                                 tred1 67
         L = I - 1                                                      tred1 68
         H = 0.0D0                                                      tred1 69
         SCALE = 0.0D0                                                  tred1 70
         IF (L .LT. 1) GO TO 130                                        tred1 71
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........       tred1 72
         DO 120 K = 1, L                                                tred1 73
  120    SCALE = SCALE + ABS(A(I,K))                                    tred1 74
C                                                                       tred1 75
         IF (SCALE .NE. 0.0D0) GO TO 140                                tred1 76
  130    E(I) = 0.0D0                                                   tred1 77
         E2(I) = 0.0D0                                                  tred1 78
         GO TO 290                                                      tred1 79
C                                                                       tred1 80
  140    DO 150 K = 1, L                                                tred1 81
            A(I,K) = A(I,K) / SCALE                                     tred1 82
            H = H + A(I,K) * A(I,K)                                     tred1 83
  150    CONTINUE                                                       tred1 84
C                                                                       tred1 85
         E2(I) = SCALE * SCALE * H                                      tred1 86
         F = A(I,L)                                                     tred1 87
         G = -SIGN(SQRT(H),F)                                           tred1 88
         E(I) = SCALE * G                                               tred1 89
         H = H - F * G                                                  tred1 90
         A(I,L) = F - G                                                 tred1 91
         IF (L .EQ. 1) GO TO 270                                        tred1 92
         F = 0.0D0                                                      tred1 93
C                                                                       tred1 94
         DO 240 J = 1, L                                                tred1 95
            G = 0.0D0                                                   tred1 96
C     .......... FORM ELEMENT OF A*U ..........                         tred1 97
            DO 180 K = 1, J                                             tred1 98
  180       G = G + A(J,K) * A(I,K)                                     tred1 99
C                                                                       tred1100
            JP1 = J + 1                                                 tred1101
            IF (L .LT. JP1) GO TO 220                                   tred1102
C                                                                       tred1103
            DO 200 K = JP1, L                                           tred1104
  200       G = G + A(K,J) * A(I,K)                                     tred1105
C     .......... FORM ELEMENT OF P ..........                           tred1106
  220       E(J) = G / H                                                tred1107
            F = F + E(J) * A(I,J)                                       tred1108
  240    CONTINUE                                                       tred1109
C                                                                       tred1110
         H = F / (H + H)                                                tred1111
C     .......... FORM REDUCED A ..........                              tred1112
         DO 260 J = 1, L                                                tred1113
            F = A(I,J)                                                  tred1114
            G = E(J) - H * F                                            tred1115
            E(J) = G                                                    tred1116
C                                                                       tred1117
            DO 260 K = 1, J                                             tred1118
               A(J,K) = A(J,K) - F * E(K) - G * A(I,K)                  tred1119
  260    CONTINUE                                                       tred1120
C                                                                       tred1121
  270    DO 280 K = 1, L                                                tred1122
  280    A(I,K) = SCALE * A(I,K)                                        tred1123
C                                                                       tred1124
  290    H = D(I)                                                       tred1125
         D(I) = A(I,I)                                                  tred1126
         A(I,I) = H                                                     tred1127
  300 CONTINUE                                                          tred1128
C                                                                       tred1129
      RETURN                                                            tred1130
      END                                                               tred1131
      SUBROUTINE TRED2(NM,N,A,D,E,Z)                                    tred2  3
C***BEGIN PROLOGUE  TRED2                                               tred2  4
C***DATE WRITTEN   760101   (YYMMDD)                                    tred2  5
C***REVISION DATE  861211   (YYMMDD)                                    tred2  6
C***CATEGORY NO.  D4C1B1                                                tred2  7
C***KEYWORDS  LIBRARY=SLATEC(EISPACK),TYPE=SINGLE PRECISION(TRED2-S),   tred2  8
C             EIGENVALUES,EIGENVECTORS                                  tred2  9
C***AUTHOR  SMITH, B. T., ET AL.                                        tred2 10
C***PURPOSE  Reduce real symmetric matrix to symmetric tridiagonal      tred2 11
C            matrix using and accumulating orthogonal transformation    tred2 12
C***DESCRIPTION                                                         tred2 13
C                                                                       tred2 14
C     This subroutine is a translation of the ALGOL procedure TRED2,    tred2 15
C     NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.   tred2 16
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).   tred2 17
C                                                                       tred2 18
C     This subroutine reduces a REAL SYMMETRIC matrix to a              tred2 19
C     symmetric tridiagonal matrix using and accumulating               tred2 20
C     orthogonal similarity transformations.                            tred2 21
C                                                                       tred2 22
C     On Input                                                          tred2 23
C                                                                       tred2 24
C        NM must be set to the row dimension of two-dimensional         tred2 25
C          array parameters as declared in the calling program          tred2 26
C          dimension statement.                                         tred2 27
C                                                                       tred2 28
C        N is the order of the matrix.                                  tred2 29
C                                                                       tred2 30
C        A contains the real symmetric input matrix.  Only the          tred2 31
C          lower triangle of the matrix need be supplied.               tred2 32
C                                                                       tred2 33
C     On Output                                                         tred2 34
C                                                                       tred2 35
C        D contains the diagonal elements of the tridiagonal matrix.    tred2 36
C                                                                       tred2 37
C        E contains the subdiagonal elements of the tridiagonal         tred2 38
C          matrix in its last N-1 positions.  E(1) is set to zero.      tred2 39
C                                                                       tred2 40
C        Z contains the orthogonal transformation matrix                tred2 41
C          produced in the reduction.                                   tred2 42
C                                                                       tred2 43
C        A and Z may coincide.  If distinct, A is unaltered.            tred2 44
C                                                                       tred2 45
C     Questions and comments should be directed to B. S. Garbow,        tred2 46
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY         tred2 47
C     ------------------------------------------------------------------tred2 48
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW, tred2 49
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-    tred2 50
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,    tred2 51
C                 1976.                                                 tred2 52
C***ROUTINES CALLED  (NONE)                                             tred2 53
C***END PROLOGUE  TRED2                                                 tred2 54
C                                                                       tred2 55
      implicit real*8(a-h,o-z)
      INTEGER I,J,K,L,N,II,NM,JP1                                       tred2 56
      REAL*8 A(NM,N),D(N),E(N),Z(NM,N)                                  tred2 57
      REAL*8 F,G,H,HH,SCALE                                             tred2 58
C                                                                       tred2 59
C***FIRST EXECUTABLE STATEMENT  TRED2                                   tred2 60
      DO 100 I = 1, N                                                   tred2 61
C                                                                       tred2 62
         DO 100 J = 1, I                                                tred2 63
            Z(I,J) = A(I,J)                                             tred2 64
  100 CONTINUE                                                          tred2 65
C                                                                       tred2 66
      IF (N .EQ. 1) GO TO 320                                           tred2 67
C     .......... FOR I=N STEP -1 UNTIL 2 DO -- ..........               tred2 68
      DO 300 II = 2, N                                                  tred2 69
         I = N + 2 - II                                                 tred2 70
         L = I - 1                                                      tred2 71
         H = 0.0D0                                                      tred2 72
         SCALE = 0.0D0                                                  tred2 73
         IF (L .LT. 2) GO TO 130                                        tred2 74
C     .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) ..........       tred2 75
         DO 120 K = 1, L                                                tred2 76
  120    SCALE = SCALE + ABS(Z(I,K))                                    tred2 77
C                                                                       tred2 78
         IF (SCALE .NE. 0.0D0) GO TO 140                                tred2 79
  130    E(I) = Z(I,L)                                                  tred2 80
         GO TO 290                                                      tred2 81
C                                                                       tred2 82
  140    DO 150 K = 1, L                                                tred2 83
            Z(I,K) = Z(I,K) / SCALE                                     tred2 84
            H = H + Z(I,K) * Z(I,K)                                     tred2 85
  150    CONTINUE                                                       tred2 86
C                                                                       tred2 87
         F = Z(I,L)                                                     tred2 88
         G = -SIGN(SQRT(H),F)                                           tred2 89
         E(I) = SCALE * G                                               tred2 90
         H = H - F * G                                                  tred2 91
         Z(I,L) = F - G                                                 tred2 92
         F = 0.0D0                                                      tred2 93
C                                                                       tred2 94
         DO 240 J = 1, L                                                tred2 95
            Z(J,I) = Z(I,J) / H                                         tred2 96
            G = 0.0D0                                                   tred2 97
C     .......... FORM ELEMENT OF A*U ..........                         tred2 98
            DO 180 K = 1, J                                             tred2 99
  180       G = G + Z(J,K) * Z(I,K)                                     tred2100
C                                                                       tred2101
            JP1 = J + 1                                                 tred2102
            IF (L .LT. JP1) GO TO 220                                   tred2103
C                                                                       tred2104
            DO 200 K = JP1, L                                           tred2105
  200       G = G + Z(K,J) * Z(I,K)                                     tred2106
C     .......... FORM ELEMENT OF P ..........                           tred2107
  220       E(J) = G / H                                                tred2108
            F = F + E(J) * Z(I,J)                                       tred2109
  240    CONTINUE                                                       tred2110
C                                                                       tred2111
         HH = F / (H + H)                                               tred2112
C     .......... FORM REDUCED A ..........                              tred2113
         DO 260 J = 1, L                                                tred2114
            F = Z(I,J)                                                  tred2115
            G = E(J) - HH * F                                           tred2116
            E(J) = G                                                    tred2117
C                                                                       tred2118
            DO 260 K = 1, J                                             tred2119
               Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)                  tred2120
  260    CONTINUE                                                       tred2121
C                                                                       tred2122
  290    D(I) = H                                                       tred2123
  300 CONTINUE                                                          tred2124
C                                                                       tred2125
  320 D(1) = 0.0D0                                                      tred2126
      E(1) = 0.0D0                                                      tred2127
C     .......... ACCUMULATION OF TRANSFORMATION MATRICES ..........     tred2128
      DO 500 I = 1, N                                                   tred2129
         L = I - 1                                                      tred2130
         IF (D(I) .EQ. 0.0D0) GO TO 380                                 tred2131
C                                                                       tred2132
         DO 360 J = 1, L                                                tred2133
            G = 0.0D0                                                   tred2134
C                                                                       tred2135
            DO 340 K = 1, L                                             tred2136
  340       G = G + Z(I,K) * Z(K,J)                                     tred2137
C                                                                       tred2138
            DO 360 K = 1, L                                             tred2139
               Z(K,J) = Z(K,J) - G * Z(K,I)                             tred2140
  360    CONTINUE                                                       tred2141
C                                                                       tred2142
  380    D(I) = Z(I,I)                                                  tred2143
         Z(I,I) = 1.0D0                                                 tred2144
         IF (L .LT. 1) GO TO 500                                        tred2145
C                                                                       tred2146
         DO 400 J = 1, L                                                tred2147
            Z(I,J) = 0.0D0                                              tred2148
            Z(J,I) = 0.0D0                                              tred2149
  400    CONTINUE                                                       tred2150
C                                                                       tred2151
  500 CONTINUE                                                          tred2152
C                                                                       tred2153
      RETURN                                                            tred2154
      END                                                               tred2155

      SUBROUTINE TQL2x(NM,N,D,E,IERR)
c  this is tql2 with the Z stuff pulled out -- i.e., it finds values, but not vectors
C***BEGIN PROLOGUE  TQL2
C***DATE WRITTEN   760101   (YYMMDD)
C***REVISION DATE  861211   (YYMMDD)
C***CATEGORY NO.  D4A5,D4C2A
C***KEYWORDS  LIBRARY=SLATEC(EISPACK),TYPE=SINGLE PRECISION(TQL2-S),
C             EIGENVALUES,EIGENVECTORS
C***AUTHOR  SMITH, B. T., ET AL.
C***PURPOSE  Compute eigenvalues and eigenvectors of symmetric
C            tridiagonal matrix.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TQL2,
C     NUM. MATH. 11, 293-306(1968) by Bowdler, Martin, Reinsch, and
C     Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
C
C     This subroutine finds the eigenvalues and eigenvectors
C     of a SYMMETRIC TRIDIAGONAL matrix by the QL method.
C     The eigenvectors of a FULL SYMMETRIC matrix can also
C     be found if  TRED2  has been used to reduce this
C     full matrix to tridiagonal form.
C
C     On Input
C
C        NM must be set to the row dimension of two-dimensional
C          array parameters as declared in the calling program
C          dimension statement.
C
C        N is the order of the matrix.
C
C        D contains the diagonal elements of the input matrix.
C
C        E contains the subdiagonal elements of the input matrix
C          in its last N-1 positions.  E(1) is arbitrary.
C
c  pulled:
C        Z contains the transformation matrix produced in the
C          reduction by  TRED2, if performed.  If the eigenvectors
C          of the tridiagonal matrix are desired, Z must contain
C          the identity matrix.
C
C      On Output
C
C        D contains the eigenvalues in ascending order.  If an
C          error exit is made, the eigenvalues are correct but
C          unordered for indices 1,2,...,IERR-1.
C
C        E has been destroyed.
C
c  pulled:
C        Z contains orthonormal eigenvectors of the symmetric
C          tridiagonal (or full) matrix.  If an error exit is made,
C          Z contains the eigenvectors associated with the stored
C          eigenvalues.
C
C        IERR is set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C***REFERENCES  B. T. SMITH, J. M. BOYLE, J. J. DONGARRA, B. S. GARBOW,
C                 Y. IKEBE, V. C. KLEMA, C. B. MOLER, *MATRIX EIGEN-
C                 SYSTEM ROUTINES - EISPACK GUIDE*, SPRINGER-VERLAG,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***END PROLOGUE  TQL2
C
      implicit real*8(a-h,o-z)
      INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR
      REAL*8 D(N),E(N)
      REAL*8 B,C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2
      REAL*8 PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  TQL2
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      F = 0.0d0
      B = 0.0d0
      E(N) = 0.0d0
C
      DO 240 L = 1, N
         J = 0
         H = ABS(D(L)) + ABS(E(L))
         IF (B .LT. H) B = H
C     .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
         DO 110 M = L, N
            IF (B + ABS(E(M)) .EQ. B) GO TO 120
C     .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP ..........
  110    CONTINUE
C
  120    IF (M .EQ. L) GO TO 220
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     .......... FORM SHIFT ..........
         L1 = L + 1
         L2 = L1 + 1
         G = D(L)
         P = (D(L1) - G) / (2.0d0 * E(L))
         R = PYTHAG(P,1.0d0)
         D(L) = E(L) / (P + SIGN(R,P))
         D(L1) = E(L) * (P + SIGN(R,P))
         DL1 = D(L1)
         H = G - D(L)
         IF (L2 .GT. N) GO TO 145
C
         DO 140 I = L2, N
  140    D(I) = D(I) - H
C
  145    F = F + H
C     .......... QL TRANSFORMATION ..........
         P = D(M)
         C = 1.0d0
         C2 = C
         EL1 = E(L1)
         S = 0.0d0
         MML = M - L
C     .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
         DO 200 II = 1, MML
            C3 = C2
            C2 = C
            S2 = S
            I = M - II
            G = C * E(I)
            H = C * P
            IF (ABS(P) .LT. ABS(E(I))) GO TO 150
            C = E(I) / P
            R = SQRT(C*C+1.0d0)
            E(I+1) = S * P * R
            S = C / R
            C = 1.0d0 / R
            GO TO 160
  150       C = P / E(I)
            R = SQRT(C*C+1.0d0)
            E(I+1) = S * E(I) * R
            S = 1.0d0 / R
            C = C * S
  160       P = C * D(I) - S * G
            D(I+1) = H + S * (C * G + S * D(I))
ccC     .......... FORM VECTOR ..........
cc            DO 180 K = 1, N
cc               H = Z(K,I+1)
cc               Z(K,I+1) = S * Z(K,I) + C * H
cc               Z(K,I) = C * Z(K,I) - S * H
cc  180       CONTINUE
C
  200    CONTINUE
C
         P = -S * S2 * C3 * EL1 * E(L) / DL1
         E(L) = S * P
         D(L) = C * P
         IF (B + ABS(E(L)) .GT. B) GO TO 130
  220    D(L) = D(L) + F
  240 CONTINUE
C     .......... ORDER EIGENVALUES AND EIGENVECTORS ..........
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
C
cc         DO 280 J = 1, N
cc            P = Z(J,I)
cc            Z(J,I) = Z(J,K)
cc            Z(J,K) = P
cc  280    CONTINUE
C
  300 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = L
 1001 RETURN
      END


! { dg-do run }
! { dg-require-effective-target fortran_large_int }
! Program to test the eoshift intrinsic for kind=16_k integers
!
program intrinsic_eoshift
  integer, parameter :: k=16
  integer(kind=k), dimension(3_k, 3_k) :: a
   integer(kind=k), dimension(3_k, 3_k, 2_k) :: b
   integer(kind=k), dimension(3_k) :: bo, sh

   ! Scalar shift and scalar bound.
   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, 1_k, 99_k, 1_k)
   if (any (a .ne. reshape ((/2_k, 3_k, 99_k, 5_k, 6_k, 99_k, 8_k, 9_k, 99_k/), (/3_k, 3_k/)))) &
      STOP 1

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, 9999_k, 99_k, 1_k)
   if (any (a .ne. 99_k)) STOP 2

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, -2_k, dim = 2_k)
   if (any (a .ne. reshape ((/0_k, 0_k, 0_k, 0_k, 0_k, 0_k, 1_k, 2_k, 3_k/), (/3_k, 3_k/)))) &
      STOP 3

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, -9999_k, 99_k, 1_k)
   if (any (a .ne. 99_k)) STOP 4

   ! Array shift and scalar bound.
   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, (/1_k, 0_k, -1_k/), 99_k, 1_k)
   if (any (a .ne. reshape ((/2_k, 3_k, 99_k, 4_k, 5_k, 6_k, 99_k, 7_k, 8_k/), (/3_k, 3_k/)))) &
      STOP 5

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, (/9999_k, 0_k, -9999_k/), 99_k, 1_k)
   if (any (a .ne. reshape ((/99_k, 99_k, 99_k, 4_k, 5_k, 6_k, 99_k, 99_k, 99_k/), (/3_k, 3_k/)))) &
      STOP 6

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, (/2_k, -2_k, 0_k/), dim = 2_k)
   if (any (a .ne. reshape ((/7_k, 0_k, 3_k, 0_k, 0_k, 6_k, 0_k, 2_k, 9_k/), (/3_k, 3_k/)))) &
      STOP 7

   ! Scalar shift and array bound.
   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, 1_k, (/99_k, -1_k, 42_k/), 1_k)
   if (any (a .ne. reshape ((/2_k, 3_k, 99_k, 5_k, 6_k, -1_k, 8_k, 9_k, 42_k/), (/3_k, 3_k/)))) &
      STOP 8

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, 9999_k, (/99_k, -1_k, 42_k/), 1_k)
   if (any (a .ne. reshape ((/99_k, 99_k, 99_k, -1_k, -1_k, -1_k, 42_k, 42_k, 42_k/), &
       (/3_k, 3_k/)))) STOP 9

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, -9999_k, (/99_k, -1_k, 42_k/), 1_k)
   if (any (a .ne. reshape ((/99_k, 99_k, 99_k, -1_k, -1_k, -1_k, 42_k, 42_k, 42_k/), &
       (/3_k, 3_k/)))) STOP 10

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, -2_k, (/99_k, -1_k, 42_k/), 2_k)
   if (any (a .ne. reshape ((/99_k, -1_k, 42_k, 99_k, -1_k, 42_k, 1_k, 2_k, 3_k/), (/3_k, 3_k/)))) &
      STOP 11

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   bo = (/99_k, -1_k, 42_k/)
   a = eoshift (a, -2_k, bo, 2_k)
   if (any (a .ne. reshape ((/99_k, -1_k, 42_k, 99_k, -1_k, 42_k, 1_k, 2_k, 3_k/), (/3_k, 3_k/)))) &
      STOP 12

   ! Array shift and array bound.
   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, (/1_k, 0_k, -1_k/), (/99_k, -1_k, 42_k/), 1_k)
   if (any (a .ne. reshape ((/2_k, 3_k, 99_k, 4_k, 5_k, 6_k, 42_k, 7_k, 8_k/), (/3_k, 3_k/)))) &
      STOP 13

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, (/2_k, -2_k, 0_k/), (/99_k, -1_k, 42_k/), 2_k)
   if (any (a .ne. reshape ((/7_k, -1_k, 3_k, 99_k, -1_k, 6_k, 99_k, 2_k, 9_k/), (/3_k, 3_k/)))) &
      STOP 14

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   sh = (/ 3_k, -1_k, -3_k /)
   bo = (/-999_k, -99_k, -9_k /)
   a = eoshift(a, shift=sh, boundary=bo)
   if (any (a .ne. reshape ((/ -999_k, -999_k, -999_k, -99_k, 4_k, 5_k, -9_k, -9_k, -9_k /), &
        shape(a)))) STOP 15

   a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   a = eoshift (a, (/9999_k, -9999_k, 0_k/), (/99_k, -1_k, 42_k/), 2_k)
   if (any (a .ne. reshape ((/99_k, -1_k, 3_k, 99_k, -1_k, 6_k, 99_k, -1_k, 9_k/), (/3_k, 3_k/)))) &
      STOP 16

   ! Test arrays > rank 2
   b(:, :, 1_k) = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   b(:, :, 2_k) = 10_k + reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/))
   b = eoshift (b, 1_k, 99_k, 1_k)
   if (any (b(:, :, 1_k) .ne. reshape ((/2_k, 3_k, 99_k, 5_k, 6_k, 99_k, 8_k, 9_k, 99_k/), (/3_k, 3_k/)))) &
      STOP 17
   if (any (b(:, :, 2_k) .ne. reshape ((/12_k, 13_k, 99_k, 15_k, 16_k, 99_k, 18_k, 19_k, 99_k/), (/3_k, 3_k/)))) &
      STOP 18

   ! TODO: Test array sections
end program


c
c
c
c     =================================================
      function fdisc(x,y)
c     =================================================

      implicit double precision (a-h,o-z)

c
c     # for computing cell averages for initial data that has a
c     # discontinuity along some curve.  fdisc should be negative to the
c     # left of the curve and positive to the right

c     # half wedge
      if (x .gt. 0.d0 .and. (y.lt.(0.55d0*x))) then
          fdisc = 1.d0
	else
	  fdisc = -1.d0
	endif
c
      return
      end


! { dg-do run }
! PR48351 - automatic (re)allocation of allocatable components of class objects
!
! Contributed by Nasser M. Abbasi on comp.lang.fortran
!
module foo
  implicit none
  type :: foo_t
    private
    real, allocatable :: u(:)
  contains
    procedure :: make
    procedure :: disp
  end type foo_t
contains
  subroutine make(this,u)
    implicit none
    class(foo_t) :: this
    real, intent(in) :: u(:)
    this%u = u(int (u))       ! The failure to allocate occurred here.
    if (.not.allocated (this%u)) call abort
  end subroutine make
  function disp(this)
    implicit none
    class(foo_t) :: this
    real, allocatable :: disp (:)
    if (allocated (this%u)) disp = this%u
  end function
end module foo

program main2
  use foo
  implicit none
  type(foo_t) :: o
  real, allocatable :: u(:)
  u=real ([3,2,1,4])
  call o%make(u)
  if (any (int (o%disp()) .ne. [1,2,3,4])) call abort
  u=real ([2,1])
  call o%make(u)
  if (any (int (o%disp()) .ne. [1,2])) call abort
end program main2


program unum_type_conversion_test
  use ISO_FORTRAN_ENV, only : REAL64
  use unum_env_mod
  use unum_to_float_mod
  use real_to_unum_mod
  use display_unum_as_real_mod
  use display_masks_mod
  use unum_t_mod
  use display_env_mod, only : Display_unum => Display_env,&
                              Display_posinfu,&
                              Display_neginfu

  implicit none
  real (REAL64) :: real_temp
  real (REAL64) :: temp_result
  type (unum_t) :: unum_temp

  !integer (INT64) :: unum_pi     = b'011001001000011111101111' !(1,4) env

  call Set_unum_env (4,5)

  !print *, 'esize mask'
  !call Display_esizemask ()

  !print *, 'fsize mask'
  !call Display_fsizemask ()

  !print *, 'efsize mask'
  !call Display_efsizemask ()

  !print *, 'ubit mask'
  !call Display_ubitmask ()

  !print *, 'utag mask'
  !call Display_utagmask ()

  print *, 'Max ubits = ', Get_maxubits ()
  print *, 'Maxreal = ', Get_maxreal ()

  print *, 'smallnormal'
  print *, U2f (Get_smallnormalu ())

  !print *, 'Approximate Pi'
  !print *, '(', u2f (unum_pi), ',', u2f (unum_pi + Get_ulpu ()), ')'

  print *, 'Positive infinity'
  call Display_posinfu ()
  print *, U2f (Get_posinfu ())

  !print *, 'Signbigu'
  !call Display_unum (Get_signbigu ())

  print *, 'Negative infinity'
  call Display_neginfu ()
  print *, U2f (Get_neginfu ())

  real_temp = 16.12
  print *, 'Value in double precision is: ', real_temp
  print *, 'Convert to unum'
  unum_temp = X2u (real_temp)
  call Display_unum (unum_temp)

  print *, 'Convert back to real'
  call Display_unum_as_real (unum_temp)

end program unum_type_conversion_test


      SUBROUTINE MB02DD( JOB, TYPET, K, M, N, TA, LDTA, T, LDT, G,
     $                   LDG, R, LDR, L, LDL, CS, LCS, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To update the Cholesky factor and the generator and/or the
C     Cholesky factor of the inverse of a symmetric positive definite
C     (s.p.d.) block Toeplitz matrix T, given the information from
C     a previous factorization and additional blocks in TA of its first
C     block row, or its first block column, depending on the routine
C     parameter TYPET. Transformation information is stored.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the output of the routine, as follows:
C             = 'R':  updates the generator G of the inverse and
C                     computes the new columns / rows for the Cholesky
C                     factor R of T;
C             = 'A':  updates the generator G, computes the new
C                     columns / rows for the Cholesky factor R of T and
C                     the new rows / columns for the Cholesky factor L
C                     of the inverse;
C             = 'O':  only computes the new columns / rows for the
C                     Cholesky factor R of T.
C
C     TYPET   CHARACTER*1
C             Specifies the type of T, as follows:
C             = 'R':  the first block row of an s.p.d. block Toeplitz
C                     matrix was/is defined; if demanded, the Cholesky
C                     factors R and L are upper and lower triangular,
C                     respectively, and G contains the transposed
C                     generator of the inverse;
C             = 'C':  the first block column of an s.p.d. block Toeplitz
C                     matrix was/is defined; if demanded, the Cholesky
C                     factors R and L are lower and upper triangular,
C                     respectively, and G contains the generator of the
C                     inverse. This choice results in a column oriented
C                     algorithm which is usually faster.
C             Note:   in this routine, the notation x / y means that
C                     x corresponds to TYPET = 'R' and y corresponds to
C                     TYPET = 'C'.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of rows / columns in T, which should be equal
C             to the blocksize.  K >= 0.
C
C     M       (input)  INTEGER
C             The number of blocks in TA.  M >= 0.
C
C     N       (input)  INTEGER
C             The number of blocks in T.  N >= 0.
C
C     TA      (input/output)  DOUBLE PRECISION array, dimension
C             (LDTA,M*K) / (LDTA,K)
C             On entry, the leading K-by-M*K / M*K-by-K part of this
C             array must contain the (N+1)-th to (N+M)-th blocks in the
C             first block row / column of an s.p.d. block Toeplitz
C             matrix.
C             On exit, if INFO = 0, the leading K-by-M*K / M*K-by-K part
C             of this array contains information on the Householder
C             transformations used, such that the array
C
C                        [ T  TA ]    /    [ T  ]
C                                          [ TA ]
C
C             serves as the new transformation matrix T for further
C             applications of this routine.
C
C     LDTA    INTEGER
C             The leading dimension of the array TA.
C             LDTA >= MAX(1,K),   if TYPET = 'R';
C             LDTA >= MAX(1,M*K), if TYPET = 'C'.
C
C     T       (input)  DOUBLE PRECISION array, dimension (LDT,N*K) /
C             (LDT,K)
C             The leading K-by-N*K / N*K-by-K part of this array must
C             contain transformation information generated by the SLICOT
C             Library routine MB02CD, i.e., in the first K-by-K block,
C             the upper / lower Cholesky factor of T(1:K,1:K), and in
C             the remaining part, the Householder transformations
C             applied during the initial factorization process.
C
C     LDT     INTEGER
C             The leading dimension of the array T.
C             LDT >= MAX(1,K),    if TYPET = 'R';
C             LDT >= MAX(1,N*K),  if TYPET = 'C'.
C
C     G       (input/output)  DOUBLE PRECISION array, dimension
C             (LDG,( N + M )*K) / (LDG,2*K)
C             On entry, if JOB = 'R', or 'A', then the leading
C             2*K-by-N*K / N*K-by-2*K part of this array must contain,
C             in the first K-by-K block of the second block row /
C             column, the lower right block of the Cholesky factor of
C             the inverse of T, and in the remaining part, the generator
C             of the inverse of T.
C             On exit, if INFO = 0 and JOB = 'R', or 'A', then the
C             leading 2*K-by-( N + M )*K / ( N + M )*K-by-2*K part of
C             this array contains the same information as on entry, now
C             for the updated Toeplitz matrix. Actually, to obtain a
C             generator of the inverse one has to set
C               G(K+1:2*K, 1:K) = 0,    if TYPET = 'R';
C               G(1:K, K+1:2*K) = 0,    if TYPET = 'C'.
C
C     LDG     INTEGER
C             The leading dimension of the array G.
C             LDG >= MAX(1,2*K),  if TYPET = 'R' and JOB = 'R', or 'A';
C             LDG >= MAX(1,( N + M )*K),
C                                 if TYPET = 'C' and JOB = 'R', or 'A';
C             LDG >= 1,           if JOB = 'O'.
C
C     R       (input/output)  DOUBLE PRECISION array, dimension
C             (LDR,M*K) / (LDR,( N + M )*K)
C             On input, the leading N*K-by-K part of R(K+1,1) /
C             K-by-N*K part of R(1,K+1) contains the last block column /
C             row of the previous Cholesky factor R.
C             On exit, if INFO = 0, then the leading
C             ( N + M )*K-by-M*K / M*K-by-( N + M )*K part of this
C             array contains the last M*K columns / rows of the upper /
C             lower Cholesky factor of T. The elements in the strictly
C             lower / upper triangular part are not referenced.
C
C     LDR     INTEGER
C             The leading dimension of the array R.
C             LDR >= MAX(1, ( N + M )*K), if TYPET = 'R';
C             LDR >= MAX(1, M*K),         if TYPET = 'C'.
C
C     L       (output)  DOUBLE PRECISION array, dimension
C             (LDL,( N + M )*K) / (LDL,M*K)
C             If INFO = 0 and JOB = 'A', then the leading
C             M*K-by-( N + M )*K / ( N + M )*K-by-M*K part of this
C             array contains the last M*K rows / columns of the lower /
C             upper Cholesky factor of the inverse of T. The elements
C             in the strictly upper / lower triangular part are not
C             referenced.
C
C     LDL     INTEGER
C             The leading dimension of the array L.
C             LDL >= MAX(1, M*K),         if TYPET = 'R' and JOB = 'A';
C             LDL >= MAX(1, ( N + M )*K), if TYPET = 'C' and JOB = 'A';
C             LDL >= 1,                   if JOB = 'R', or 'O'.
C
C     CS      (input/output)  DOUBLE PRECISION array, dimension (LCS)
C             On input, the leading 3*(N-1)*K part of this array must
C             contain the necessary information about the hyperbolic
C             rotations and Householder transformations applied
C             previously by SLICOT Library routine MB02CD.
C             On exit, if INFO = 0, then the leading 3*(N+M-1)*K part of
C             this array contains information about all the hyperbolic
C             rotations and Householder transformations applied during
C             the whole process.
C
C     LCS     INTEGER
C             The length of the array CS.  LCS >= 3*(N+M-1)*K.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -19,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,(N+M-1)*K).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction algorithm failed. The block Toeplitz
C                   matrix associated with [ T  TA ] / [ T'  TA' ]' is
C                   not (numerically) positive definite.
C
C     METHOD
C
C     Householder transformations and modified hyperbolic rotations
C     are used in the Schur algorithm [1], [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C                               3         2
C     The algorithm requires 0(K ( N M + M ) ) floating point
C     operations.
C
C     FURTHER COMMENTS
C
C     For min(K,N,M) = 0, the routine sets DWORK(1) = 1 and returns.
C     Although the calculations could still be performed when N = 0,
C     but min(K,M) > 0, this case is not considered as an "update".
C     SLICOT Library routine MB02CD should be called with the argument
C     M instead of N.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Chemnitz, Germany, December 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000,
C     Feb. 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB, TYPET
      INTEGER           INFO, K, LCS, LDG, LDL, LDR, LDT, LDTA, LDWORK,
     $                  M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*),
     $                  T(LDT,*), TA(LDTA,*)
C     .. Local Scalars ..
      INTEGER           I, IERR, J, MAXWRK, STARTI, STARTR, STARTT
      LOGICAL           COMPG, COMPL, ISROW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLACPY, DLASET, DTRSM, MB02CX, MB02CY,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      COMPL = LSAME( JOB, 'A' )
      COMPG = LSAME( JOB, 'R' ) .OR. COMPL
      ISROW = LSAME( TYPET, 'R' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( COMPG .OR. LSAME( JOB, 'O' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN
         INFO = -2
      ELSE IF ( K.LT.0 ) THEN
         INFO = -3
      ELSE IF ( M.LT.0 ) THEN
         INFO = -4
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( LDTA.LT.1 .OR. ( ISROW .AND. LDTA.LT.K ) .OR.
     $                    ( .NOT.ISROW .AND. LDTA.LT.M*K ) ) THEN
         INFO = -7
      ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR.
     $                   ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN
         INFO = -9
      ELSE IF ( ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K )
     $                .OR. ( .NOT.ISROW .AND. LDG.LT.( N + M )*K ) ) )
     $          .OR. LDG.LT.1 ) THEN
         INFO = -11
      ELSE IF ( ( (      ISROW .AND. LDR.LT.( N + M )*K ) .OR.
     $            ( .NOT.ISROW .AND. LDR.LT.M*K ) ) .OR.
     $          LDR.LT.1 ) THEN
         INFO = -13
      ELSE IF ( ( COMPL .AND. ( ( ISROW .AND. LDL.LT.M*K )
     $                .OR. ( .NOT.ISROW .AND. LDL.LT.( N + M )*K ) ) )
     $          .OR. LDL.LT.1 ) THEN
         INFO = -15
      ELSE IF ( LCS.LT.3*( N + M - 1 )*K ) THEN
         INFO = -17
      ELSE IF ( LDWORK.LT.MAX( 1, ( N + M - 1 )*K ) ) THEN
         DWORK(1) = MAX( 1, ( N + M - 1 )*K )
         INFO = -19
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02DD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( K, N, M ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      MAXWRK = 1
      IF ( ISROW ) THEN
C
C        Apply Cholesky factor of T(1:K, 1:K) on TA.
C
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, M*K,
     $               ONE, T, LDT, TA, LDTA )
C
C        Initialize the output matrices.
C
         IF ( COMPG ) THEN
            CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(1,N*K+1), LDG )
            IF ( M.GE.N-1 .AND. N.GT.1 ) THEN
               CALL DLACPY( 'All', K, (N-1)*K, G(K+1,K+1), LDG,
     $                      G(K+1,K*(M+1)+1), LDG )
            ELSE
               DO 10  I = N*K, K + 1, -1
                  CALL DCOPY( K, G(K+1,I), 1, G(K+1,M*K+I), 1 )
   10          CONTINUE
            END IF
            CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(K+1,K+1), LDG )
         END IF
C
         CALL DLACPY( 'All', K, M*K, TA, LDTA, R, LDR )
C
C        Apply the stored transformations on the new columns.
C
         DO 20  I = 2, N
C
C           Copy the last M-1 blocks of the positive generator together;
C           the last M blocks of the negative generator are contained
C           in TA.
C
            STARTR =   ( I - 1 )*K + 1
            STARTT = 3*( I - 2 )*K + 1
            CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR,
     $                   R(STARTR,K+1), LDR )
C
C           Apply the transformations stored in T on the generator.
C
            CALL MB02CY( 'Row', 'NoStructure', K, K, M*K, K,
     $                   R(STARTR,1), LDR, TA, LDTA, T(1,STARTR), LDT,
     $                   CS(STARTT), 3*K, DWORK, LDWORK, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
   20    CONTINUE
C
C        Now, we have "normality" and can apply further M Schur steps.
C
         DO 30  I = 1, M
C
C           Copy the first M-I+1 blocks of the positive generator
C           together; the first M-I+1 blocks of the negative generator
C           are contained in TA.
C
            STARTT = 3*( N + I - 2 )*K + 1
            STARTI = ( M - I + 1 )*K + 1
            STARTR = ( N + I - 1 )*K + 1
            IF ( I.EQ.1 ) THEN
               CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR,
     $                      R(STARTR,K+1), LDR )
            ELSE
               CALL DLACPY( 'Upper', K, (M-I+1)*K,
     $                      R(STARTR-K,(I-2)*K+1), LDR,
     $                      R(STARTR,(I-1)*K+1), LDR )
            END IF
C
C           Reduce the generator to proper form.
C
            CALL MB02CX( 'Row', K, K, K, R(STARTR,(I-1)*K+1), LDR,
     $                   TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, DWORK,
     $                   LDWORK, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            IF ( M.GT.I ) THEN
               CALL MB02CY( 'Row', 'NoStructure', K, K, (M-I)*K, K,
     $                      R(STARTR,I*K+1), LDR, TA(1,I*K+1), LDTA,
     $                      TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K,
     $                      DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            END IF
C
            IF ( COMPG ) THEN
C
C              Transformations acting on the inverse generator:
C
               CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1),
     $                      LDG, G(1,STARTR), LDG, TA(1,(I-1)*K+1),
     $                      LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               CALL MB02CY( 'Row', 'NoStructure', K, K, (N+I-1)*K, K,
     $                      G(K+1,STARTI), LDG, G, LDG, TA(1,(I-1)*K+1),
     $                      LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               IF ( COMPL ) THEN
                  CALL DLACPY( 'All', K, (N+I-1)*K, G(K+1,STARTI), LDG,
     $                         L((I-1)*K+1,1), LDL )
                  CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG,
     $                         L((I-1)*K+1,STARTR), LDL )
               END IF
C
            END IF
   30    CONTINUE
C
      ELSE
C
C        Apply Cholesky factor of T(1:K, 1:K) on TA.
C
         CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M*K, K,
     $               ONE, T, LDT, TA, LDTA )
C
C        Initialize the output matrices.
C
         IF ( COMPG ) THEN
            CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(N*K+1,1), LDG )
            IF ( M.GE.N-1 .AND. N.GT.1 ) THEN
               CALL DLACPY( 'All', (N-1)*K, K, G(K+1,K+1), LDG,
     $                      G(K*(M+1)+1,K+1), LDG )
            ELSE
               DO 40  I = 1, K
                  DO 35  J = N*K, K + 1, -1
                     G(J+M*K,K+I) = G(J,K+I)
   35             CONTINUE
   40          CONTINUE
            END IF
            CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(K+1,K+1), LDG )
         END IF
C
         CALL DLACPY( 'All', M*K, K, TA, LDTA, R, LDR )
C
C        Apply the stored transformations on the new rows.
C
         DO 50  I = 2, N
C
C           Copy the last M-1 blocks of the positive generator together;
C           the last M blocks of the negative generator are contained
C           in TA.
C
            STARTR =   ( I - 1 )*K + 1
            STARTT = 3*( I - 2 )*K + 1
            CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR,
     $                   R(K+1,STARTR), LDR )
C
C           Apply the transformations stored in T on the generator.
C
            CALL MB02CY( 'Column', 'NoStructure', K, K, M*K, K,
     $                   R(1,STARTR), LDR, TA, LDTA, T(STARTR,1), LDT,
     $                   CS(STARTT), 3*K, DWORK, LDWORK, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
   50    CONTINUE
C
C        Now, we have "normality" and can apply further M Schur steps.
C
         DO 60  I = 1, M
C
C           Copy the first M-I+1 blocks of the positive generator
C           together; the first M-I+1 blocks of the negative generator
C           are contained in TA.
C
            STARTT = 3*( N + I - 2 )*K + 1
            STARTI = ( M - I + 1 )*K + 1
            STARTR = ( N + I - 1 )*K + 1
            IF ( I.EQ.1 ) THEN
               CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR,
     $                      R(K+1,STARTR), LDR )
            ELSE
               CALL DLACPY( 'Lower', (M-I+1)*K, K,
     $                      R((I-2)*K+1,STARTR-K), LDR,
     $                      R((I-1)*K+1,STARTR), LDR )
            END IF
C
C           Reduce the generator to proper form.
C
            CALL MB02CX( 'Column', K, K, K, R((I-1)*K+1,STARTR), LDR,
     $                   TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, DWORK,
     $                   LDWORK, IERR )
            IF ( IERR.NE.0 )  THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            IF ( M.GT.I ) THEN
               CALL MB02CY( 'Column', 'NoStructure', K, K, (M-I)*K, K,
     $                      R(I*K+1,STARTR), LDR, TA(I*K+1,1), LDTA,
     $                      TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K,
     $                      DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
            END IF
C
            IF ( COMPG ) THEN
C
C              Transformations acting on the inverse generator:
C
               CALL MB02CY( 'Column', 'Triangular', K, K, K, K,
     $                      G(1,K+1), LDG, G(STARTR,1), LDG,
     $                      TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K,
     $                      DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               CALL MB02CY( 'Column', 'NoStructure', K, K, (N+I-1)*K, K,
     $                      G(STARTI,K+1), LDG, G, LDG, TA((I-1)*K+1,1),
     $                      LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
               IF ( COMPL ) THEN
                  CALL DLACPY( 'All', (N+I-1)*K, K, G(STARTI,K+1), LDG,
     $                         L(1,(I-1)*K+1), LDL )
                  CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG,
     $                         L(STARTR,(I-1)*K+1), LDL )
               END IF
C
            END IF
   60    CONTINUE
C
      END IF
C
      DWORK(1) = MAXWRK
C
      RETURN
C
C *** Last line of MB02DD ***
      END


C SUBROUTINE ZMUT             (NEXT)
      SUBROUTINE ZMUT (ZSUM)
C
C     ZMUT - CALCULATES THE SELF-IMPEDANCE AND MUTUAL-IMPEDANCE
C        BETWEEN LINEAR PARALLEL DIPOLE ELEMENTS OF EQUAL LENGTHS.
C     SEE THE REFERENCES IN SUBROUTINE GAIN.
C
      COMPLEX CSU1, CSUZP, CSV1, CSZ1, ZSUM
C
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RO, VOFL
C
      COMMON /CUR /DIJ, EIL, HIJ, KODE
C
C.......................................................................
      D2 = DIJ * * 2
      EL2 = EIL * * 2
      T = SQRT (D2 + 4.0 * EL2)
      UZ = PI2 * (T - 2.0 * EIL)
      VZ = PI2 * (T + 2.0 * EIL)
      UZP = PI2 * DIJ
      T = SQRT (D2 + EL2)
      U1 = PI2 * (T - EIL)
      V1 = PI2 * (T + EIL)
      W1 = 2.0 * PI2 * EIL
      CW1 = COS (W1)
      SW1 = SIN (W1)
      CSU1 = CSZ1 (U1)
      CSV1 = CSZ1 (V1)
      CSUZP = CSZ1 (UZP)
      ZSUM = (CSZ1 (UZ) - 2.0 * CSU1) * CMPLX (CW1, - SW1) + (CSZ1 (VZ)
     1- 2.0 * CSV1) * CMPLX (CW1, SW1) + 2.0 * (CSUZP - CSU1 - CSV1) + 2
     2.0 * CSUZP * (CW1 + 1.0)
      IF (KODE .GT. 0) GO TO 100
      ZSUM = ZSUM * 30.0
      GO TO 105
 100  ZSUM = ZSUM * 60.0 / (1.0 - CW1)
 105  RETURN
      END


      double complex function ttbqqbqqpp(k1,k2,k3,k4,k5,k6,k7)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_com.f'
      include 'masses.f'
      integer k1,k2,k3,k4,k5,k6,k7
      double precision s129,mtsq
      s129=s(k1,k2)+s(k1,k3)+s(k2,k3)
      mtsq=mt**2
      ttbqqbqqpp =  + xn**(-1)*s129**(-1) * (  - 1/(za(k1,k3))/(za(k5,
     &    k3))*za(k1,k5)**2*za(k6,k7)*zb(k2,k6)*zb(k4,k5) + 1/(za(k2,k3
     &    ))*za(k1,k5)*za(k6,k7)*zb(k4,k5)*zb(k6,k3) + 1/(za(k2,k3))/(
     &    za(k5,k3))*za(k1,k5)*za(k2,k5)*za(k6,k7)*zb(k2,k6)*zb(k4,k5)
     &     )
      ttbqqbqqpp = ttbqqbqqpp + xn**(-1)*mtsq*s129**(-1) * ( 1/(za(k1,
     &    k3))/(za(k5,k3))*za(k1,k5)*za(k1,k7)*zb(k2,k4) - 1/(za(k2,k3)
     &    )*za(k1,k7)*zb(k4,k3) - 1/(za(k2,k3))/(za(k5,k3))*za(k1,k7)*
     &    za(k2,k5)*zb(k2,k4) )

      return
      end


! { dg-do run }
! PR32928 DATA statement with array element as initializer is rejected
! Test case by Jerry DeLisle  <jvdelisle @gcc.gnu.org>
program chkdata
    integer, parameter,dimension(4) :: myint = [ 4,3,2,1 ]
    character(3), parameter, dimension(3) :: mychar = [ "abc", "def", "ghi" ]
    character(50) :: buffer
    integer :: a(5)
    character(5) :: c(5)
    data a(1:2) / myint(4), myint(2) /
    data a(3:5) / myint(1), myint(3), myint(1) /
    data c / mychar(1), mychar(2), mychar(3), mychar(1), mychar(2) /
    buffer = ""
    if (any(a.ne.[1,3,4,2,4])) STOP 1
    write(buffer,'(5(a))')c
    if (buffer.ne."abc  def  ghi  abc  def  ") STOP 2
end program chkdata


\\ Prints out the first 20 Fib numbers

: fib_disp ( -- )
    0 1 20 0 do
               dup . tuck +
             loop
     2drop
;


subroutine abinitializer(neq, nsteps, t, archive)
  implicit none
  integer, intent(in) :: neq
  integer :: i, k, nrich, nsteps
  double precision, intent(in) :: t(0:nsteps)
  double precision :: bot, tin, tout, yin(neq), yout(neq), archive(neq,0:steps)

  do i = 0, neq
    tin = t(i)
    yin = archive(:,i)
    tout = t(i+1)
    call extrapolate(neq, tin, tout, yin, yout)
    archive(:,i+1) = yout
  end do

  return
end


! { dg-do run }
! { dg-options "-O2" }

  integer, save :: g
  integer :: i
  !$omp parallel
  !$omp single
    if (f1 (74) .ne. 63 + 4) call abort
    g = 77
    call f2
    !$omp taskwait
    if (g .ne. 63 + 9) call abort
    if (f3 (7_8, 11_8, 2_8) .ne. 11 * 7 + 13) call abort
    if (f4 (0_8, 31_8, 16_8, 46_8, 1_8, 2_8, 73) .ne. 32 + 5 * 48 &
&       + 11 * 31 + 17 * 46) call abort
  !$omp end single
  !$omp end parallel
contains
  function f1 (y)
    integer, intent(in) :: y
    integer :: i, f1, x
    x = y
    !$omp taskloop firstprivate(x)lastprivate(x)
    do i = 0, 63
      if (x .ne. 74) call abort
      if (i .eq. 63) then
        x = i + 4
      end if
    end do
    f1 = x
  end function f1
  subroutine f2 ()
    integer :: i
    !$omp taskloop firstprivate(g)lastprivate(g)nogroup
    do i = 0, 63
      if (g .ne. 77) call abort
      if (i .eq. 63) then
        g = i + 9
      end if
    end do
  end subroutine f2
  function f3 (a, b, c)
    integer(kind=8), intent(in) :: a, b, c
    integer(kind=8) :: i, f3
    integer :: l
    !$omp taskloop default(none) lastprivate (i, l)
    do i = a, b, c
      l = i
    end do
    !$omp end taskloop
    f3 = l * 7 + i
  end function f3
  function f4 (a, b, c, d, e, f, m)
    integer(kind=8), intent(in) :: a, b, c, d, e, f
    integer(kind=8) :: i, j, f4
    integer, intent(in) :: m
    integer :: l, k
    k = m
    !$omp taskloop default (none) collapse (2) firstprivate (k) &
    !$omp & lastprivate (i, j, k, l)
    do i = a, b, e
      do j = c, d, f
        if (k .ne. 73) call abort
        if (i .eq. 31 .and. j .eq. 46) then
          k = i
        end if
        l = j
      end do
    end do
    f4 = i + 5 * j + 11 * k + 17 * l
  end function f4
end