      SUBROUTINE SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C,
     $                   LDC, SCALE, SEP, FERR, WR, WI, IWORK, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for X either the real continuous-time Lyapunov equation
C
C        op(A)'*X + X*op(A) = scale*C                             (1)
C
C     or the real discrete-time Lyapunov equation
C
C        op(A)'*X*op(A) - X = scale*C                             (2)
C
C     and/or estimate an associated condition number, called separation,
C     where op(A) = A or A' (A**T) and C is symmetric (C = C').
C     (A' denotes the transpose of the matrix A.) A is N-by-N, the right
C     hand side C and the solution X are N-by-N, and scale is an output
C     scale factor, set less than or equal to 1 to avoid overflow in X.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the equation from which X is to be determined
C             as follows:
C             = 'C':  Equation (1), continuous-time case;
C             = 'D':  Equation (2), discrete-time case.
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'X':  Compute the solution only;
C             = 'S':  Compute the separation only;
C             = 'B':  Compute both the solution and the separation.
C
C     FACT    CHARACTER*1
C             Specifies whether or not the real Schur factorization
C             of the matrix A is supplied on entry, as follows:
C             = 'F':  On entry, A and U contain the factors from the
C                     real Schur factorization of the matrix A;
C             = 'N':  The Schur factorization of A will be computed
C                     and the factors will be stored in A and U.
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, X, and C.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A. If FACT = 'F', then A contains
C             an upper quasi-triangular matrix in Schur canonical form;
C             the elements below the upper Hessenberg part of the
C             array A are not referenced.
C             On exit, if INFO = 0 or INFO = N+1, the leading N-by-N
C             upper Hessenberg part of this array contains the upper
C             quasi-triangular matrix in Schur canonical form from the
C             Schur factorization of A. The contents of array A is not
C             modified if FACT = 'F'.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     U       (input or output) DOUBLE PRECISION array, dimension
C             (LDU,N)
C             If FACT = 'F', then U is an input argument and on entry
C             the leading N-by-N part of this array must contain the
C             orthogonal matrix U of the real Schur factorization of A.
C             If FACT = 'N', then U is an output argument and on exit,
C             if INFO = 0 or INFO = N+1, it contains the orthogonal
C             N-by-N matrix from the real Schur factorization of A.
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry with JOB = 'X' or 'B', the leading N-by-N part of
C             this array must contain the symmetric matrix C.
C             On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1,
C             the leading N-by-N part of C has been overwritten by the
C             symmetric solution matrix X.
C             If JOB = 'S', C is not referenced.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= 1,        if JOB = 'S';
C             LDC >= MAX(1,N), otherwise.
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor, scale, set less than or equal to 1 to
C             prevent the solution overflowing.
C
C     SEP     (output) DOUBLE PRECISION
C             If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP
C             contains the estimated separation of the matrices op(A)
C             and -op(A)', if DICO = 'C' or of op(A) and op(A)', if
C             DICO = 'D'.
C             If JOB = 'X', SEP is not referenced.
C
C     FERR    (output) DOUBLE PRECISION
C             If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains an
C             estimated forward error bound for the solution X.
C             If XTRUE is the true solution, FERR bounds the relative
C             error in the computed solution, measured in the Frobenius
C             norm:  norm(X - XTRUE)/norm(XTRUE).
C             If JOB = 'X' or JOB = 'S', FERR is not referenced.
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI
C             contain the real and imaginary parts, respectively, of
C             the eigenvalues of A.
C             If FACT = 'F', WR and WI are not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N*N)
C             This array is not referenced if JOB = 'X'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
C             optimal value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 1, and
C             If JOB = 'X' then
C                If FACT = 'F', LDWORK >= N*N,           for DICO = 'C';
C                               LDWORK >= MAX(N*N, 2*N), for DICO = 'D';
C                If FACT = 'N', LDWORK >= MAX(N*N, 3*N).
C             If JOB = 'S' or JOB = 'B' then
C                If FACT = 'F', LDWORK >= 2*N*N,       for DICO = 'C';
C                               LDWORK >= 2*N*N + 2*N, for DICO = 'D'.
C                If FACT = 'N', LDWORK >= MAX(2*N*N, 3*N), DICO = 'C';
C                               LDWORK >= 2*N*N + 2*N, for DICO = 'D'.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
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             > 0:  if INFO = i, the QR algorithm failed to compute all
C                   the eigenvalues (see LAPACK Library routine DGEES);
C                   elements i+1:n of WR and WI contain eigenvalues
C                   which have converged, and A contains the partially
C                   converged Schur form;
C             = N+1:  if DICO = 'C', and the matrices A and -A' have
C                   common or very close eigenvalues, or
C                   if DICO = 'D', and matrix A has almost reciprocal
C                   eigenvalues (that is, lambda(i) = 1/lambda(j) for
C                   some i and j, where lambda(i) and lambda(j) are
C                   eigenvalues of A and i <> j); perturbed values were
C                   used to solve the equation (but the matrix A is
C                   unchanged).
C
C     METHOD
C
C     The Schur factorization of a square matrix  A  is given by
C
C        A = U*S*U'
C
C     where U is orthogonal and S is block upper triangular with 1-by-1
C     and 2-by-2 blocks on its diagonal, these blocks corresponding to
C     the eigenvalues of A, the 2-by-2 blocks being complex conjugate
C     pairs. This factorization is obtained by numerically stable
C     methods: first A is reduced to upper Hessenberg form (if FACT =
C     'N') by means of Householder transformations and then the
C     QR Algorithm is applied to reduce the Hessenberg form to S, the
C     transformation matrices being accumulated at each step to give U.
C     If A has already been factorized prior to calling the routine
C     however, then the factors U and S may be supplied and the initial
C     factorization omitted.
C                   _            _
C     If we now put C = U'CU and X = UXU' equations (1) and (2) (see
C     PURPOSE) become (for TRANS = 'N')
C          _   _    _
C        S'X + XS = C,                                               (3)
C     and
C          _    _   _
C        S'XS - X = C,                                               (4)
C
C     respectively. Partition S, C and X as
C                            _   _         _   _
C            (s    s')      (c   c')      (x   x')
C            ( 11    )  _   ( 11   )  _   ( 11   )
C        S = (       ), C = (      ), X = (      )
C            (       )      ( _    )      ( _    )
C            ( 0   S )      ( c  C )      ( x  X )
C                   1             1             1
C                _      _
C     where s  , c  and x  are either scalars or 2-by-2 matrices and s,
C            11   11     11
C     _     _
C     c and x are either (N-1) element vectors or matrices with two
C     columns. Equations (3) and (4) can then be re-written as
C           _     _        _
C        s' x   + x  s   = c                                       (3.1)
C         11 11    11 11    11
C
C          _   _           _    _
C        S'x + xs        = c - sx                                  (3.2)
C         1      11              11
C
C                                _    _
C        S'X + X S       = C - (sx' + xs')                         (3.3)
C         1 1   1 1         1
C     and
C           _       _       _
C        s' x  s  - x     = c                                      (4.1)
C         11 11 11   11      11
C
C          _     _          _    _
C        S'xs  - x        = c - sx  s                              (4.2)
C         1  11                   11 11
C
C                                _            _        _
C        S'X S - X        = C - sx  s' - [s(S'x)' + (S'x)s']       (4.3)
C         1 1 1   1          1    11         1        1
C                                                  _
C     respectively. If DICO = 'C' ['D'], then once x   has been
C                                                   11
C     found from equation (3.1) [(4.1)], equation (3.2) [(4.2)] can be
C                                        _
C     solved by forward substitution for x and then equation (3.3)
C     [(4.3)] is of the same form as (3) [(4)] but of the order (N-1) or
C     (N-2) depending upon whether s   is 1-by-1 or 2-by-2.
C                                   11
C                             _      _
C     When s   is 2-by-2 then x  and c   will be 1-by-2 matrices and s,
C           11                 11     11
C     _     _
C     x and c are matrices with two columns. In this case, equation
C     (3.1) [(4.1)] defines the three equations in the unknown elements
C        _
C     of x   and equation (3.2) [(4.2)] can then be solved by forward
C         11                 _
C     substitution, a row of x being found at each step.
C
C     REFERENCES
C
C     [1] Barraud, A.Y.                   T
C         A numerical algorithm to solve A XA - X = Q.
C         IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977.
C
C     [2] Bartels, R.H. and Stewart, G.W.  T
C         Solution of the matrix equation A X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [3] Hammarling, S.J.
C         Numerical solution of the stable, non-negative definite
C         Lyapunov equation.
C         IMA J. Num. Anal., 2, pp. 303-325, 1982.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations and is backward stable.
C
C     FURTHER COMMENTS
C
C     If DICO = 'C', SEP is defined as the separation of op(A) and
C     -op(A)':
C
C            sep( op(A), -op(A)' ) = sigma_min( T )
C
C     and if DICO = 'D', SEP is defined as
C
C            sep( op(A), op(A)' ) = sigma_min( T )
C
C     where sigma_min(T) is the smallest singular value of the
C     N*N-by-N*N matrix
C
C       T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) )  (DICO = 'C'),
C
C       T = kprod( op(A)', op(A)' ) - I(N**2)              (DICO = 'D').
C
C     I(x) is an x-by-x identity matrix, and kprod denotes the Kronecker
C     product. The program estimates sigma_min(T) by the reciprocal of
C     an estimate of the 1-norm of inverse(T). The true reciprocal
C     1-norm of inverse(T) cannot differ from sigma_min(T) by more
C     than a factor of N.
C
C     When SEP is small, small changes in A, C can cause large changes
C     in the solution of the equation. An approximate bound on the
C     maximum relative error in the computed solution is
C
C                      EPS * norm(A) / SEP      (DICO = 'C'),
C
C                      EPS * norm(A)**2 / SEP   (DICO = 'D'),
C
C     where EPS is the machine precision.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, July 1997.
C     Supersedes Release 2.0 routine SB03AD by Control Systems Research
C     Group, Kingston Polytechnic, United Kingdom.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, May 1999.
C     V. Sima, Research Institute for Informatics, Bucharest, July 2011,
C     Dec. 2016, May 2020.
C
C     KEYWORDS
C
C     Lyapunov equation, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, FACT, JOB, TRANA
      INTEGER           INFO, LDA, LDC, LDU, LDWORK, N
      DOUBLE PRECISION  FERR, SCALE, SEP
C     .. Array Arguments ..
      INTEGER           IWORK( * )
      DOUBLE PRECISION  A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                  U( LDU, * ), WI( * ), WR( * )
C     .. Local Scalars ..
      LOGICAL           CONT, LQUERY, NOFACT, NOTA, WANTBH, WANTSP,
     $                  WANTX
      CHARACTER         NOTRA, NTRNST, TRANST, UPLO
      INTEGER           I, IERR, KASE, LWA, MINWRK, NN, NN2, SDIM
      DOUBLE PRECISION  EPS, EST, SCALEF
C     .. Local Arrays ..
      LOGICAL           BWORK( 1 )
      INTEGER           ISAVE( 3 )
C     .. External Functions ..
      LOGICAL           LSAME, SELECT
      DOUBLE PRECISION  DLAMCH, DLANHS
      EXTERNAL          DLAMCH, DLANHS, LSAME, SELECT
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEES, DLACN2, MB01RD, SB03MX, SB03MY,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      CONT   = LSAME( DICO,  'C' )
      WANTX  = LSAME( JOB,   'X' )
      WANTSP = LSAME( JOB,   'S' )
      WANTBH = LSAME( JOB,   'B' )
      NOFACT = LSAME( FACT,  'N' )
      NOTA   = LSAME( TRANA, 'N' )
      LQUERY = LDWORK.EQ.-1
      NN  = N*N
      NN2 = 2*NN
C
      INFO = 0
      IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN
         INFO = -2
      ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND.
     $                         .NOT.LSAME( TRANA, 'C' ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDU.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( WANTSP .AND. LDC.LT.1 .OR.
     $    .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE
         IF ( WANTX ) THEN
            IF ( NOFACT ) THEN
               MINWRK = MAX( NN, 3*N )
            ELSE IF ( CONT ) THEN
               MINWRK = NN
            ELSE
               MINWRK = MAX( NN, 2*N )
            END IF
         ELSE
            IF ( CONT ) THEN
               IF ( NOFACT ) THEN
                  MINWRK = MAX( NN2, 3*N )
               ELSE
                  MINWRK = NN2
               END IF
            ELSE
               MINWRK = NN2 + 2*N
            END IF
         END IF
         MINWRK = MAX( 1, MINWRK )
         IF( LQUERY ) THEN
            IF( NOFACT ) THEN
               CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA,
     $                     SDIM, WR, WI, U, LDU, DWORK, -1, BWORK,
     $                     INFO )
               LWA = MAX( MINWRK, INT( DWORK( 1 ) ) )
            ELSE
               LWA = MINWRK
            END IF
         ELSE IF( LDWORK.LT.MINWRK ) THEN
            INFO = -19
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB03MD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = LWA
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         SCALE = ONE
         IF( .NOT.WANTX )
     $      SEP   = ZERO
         IF( WANTBH )
     $      FERR  = ZERO
         DWORK(1) = ONE
         RETURN
      END IF
C
      LWA = 0
C
      IF( NOFACT ) THEN
C
C        Compute the Schur factorization of A.
C        Workspace:  need   3*N;
C                    prefer larger.
C        (Note: Comments in the code beginning "Workspace:" describe the
C        minimal amount of real workspace needed at that point in the
C        code, as well as the preferred amount for good performance.
C        NB refers to the optimal block size for the immediately
C        following subroutine, as returned by ILAENV.)
C
         CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM,
     $               WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO )
         IF( INFO.GT.0 )
     $      RETURN
         LWA = INT( DWORK( 1 ) )
      END IF
C
      IF( .NOT.WANTSP ) THEN
C
C        Transform the right-hand side.
C        Workspace:  N*N.
C
         NTRNST = 'N'
         TRANST = 'T'
         UPLO   = 'U'
         CALL MB01RD( UPLO, TRANST, N, N, ZERO, ONE, C, LDC, U, LDU, C,
     $                LDC, DWORK, LDWORK, INFO )
C
         DO 10 I = 2, N
            CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC )
   10    CONTINUE
C
         LWA = MAX( LWA, NN )
C
C        Solve the transformed equation.
C        Workspace for DICO = 'D':  2*N.
C
         IF ( CONT ) THEN
            CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO )
         ELSE
            CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO )
         END IF
         IF( INFO.GT.0 )
     $      INFO = N + 1
C
C        Transform back the solution.
C        Workspace:  N*N.
C
         CALL MB01RD( UPLO, NTRNST, N, N, ZERO, ONE, C, LDC, U, LDU, C,
     $                LDC, DWORK, LDWORK, IERR )
C
         DO 20 I = 2, N
            CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC )
   20    CONTINUE
C
      END IF
C
      IF( .NOT.WANTX ) THEN
C
C        Estimate the separation.
C        Workspace:  2*N*N       for DICO = 'C';
C                    2*N*N + 2*N for DICO = 'D'.
C
         IF( NOTA ) THEN
            NOTRA = 'T'
         ELSE
            NOTRA = 'N'
         END IF
C
         EST = ZERO
         KASE = 0
C        REPEAT
   30    CONTINUE
         CALL DLACN2( NN, DWORK(NN+1), DWORK, IWORK, EST, KASE, ISAVE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
               IF( CONT ) THEN
                  CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF,
     $                         IERR )
               ELSE
                  CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF,
     $                         DWORK(NN2+1), IERR )
               END IF
            ELSE
               IF( CONT ) THEN
                  CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF,
     $                         IERR )
               ELSE
                  CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF,
     $                         DWORK(NN2+1), IERR )
               END IF
            END IF
            GO TO 30
         END IF
C        UNTIL KASE = 0
C
         SEP = SCALEF / EST
C
         IF( WANTBH ) THEN
C
C           Get the machine precision.
C
            EPS = DLAMCH( 'P' )
C
C           Compute the estimate of the relative error.
C
            IF ( CONT ) THEN
               FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )/SEP
            ELSE
               FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )**2/SEP
            END IF
         END IF
      END IF
C
      DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) )
      RETURN
C *** Last line of SB03MD ***
      END


      SUBROUTINE SB03SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A,
     $                   LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD,
     $                   RCOND, FERR, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To estimate the conditioning and compute an error bound on the
C     solution of the real discrete-time Lyapunov matrix equation
C
C         op(A)'*X*op(A) - X = scale*C
C
C     where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The
C     matrix A is N-by-N, the right hand side C and the solution X are
C     N-by-N symmetric matrices, and scale is a given scale factor.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'C':  Compute the reciprocal condition number only;
C             = 'E':  Compute the error bound only;
C             = 'B':  Compute both the reciprocal condition number and
C                     the error bound.
C
C     FACT    CHARACTER*1
C             Specifies whether or not the real Schur factorization
C             of the matrix A is supplied on entry, as follows:
C             = 'F':  On entry, T and U (if LYAPUN = 'O') contain the
C                     factors from the real Schur factorization of the
C                     matrix A;
C             = 'N':  The Schur factorization of A will be computed
C                     and the factors will be stored in T and U (if
C                     LYAPUN = 'O').
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     UPLO    CHARACTER*1
C             Specifies which part of the symmetric matrix C is to be
C             used, as follows:
C             = 'U':  Upper triangular part;
C             = 'L':  Lower triangular part.
C
C     LYAPUN  CHARACTER*1
C             Specifies whether or not the original Lyapunov equations
C             should be solved in the iterative estimation process,
C             as follows:
C             = 'O':  Solve the original Lyapunov equations, updating
C                     the right-hand sides and solutions with the
C                     matrix U, e.g., X <-- U'*X*U;
C             = 'R':  Solve reduced Lyapunov equations only, without
C                     updating the right-hand sides and solutions.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, X and C.  N >= 0.
C
C     SCALE   (input) DOUBLE PRECISION
C             The scale factor, scale, set by a Lyapunov solver.
C             0 <= SCALE <= 1.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of
C             this array must contain the original matrix A.
C             If FACT = 'F' and LYAPUN = 'R', A is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= MAX(1,N), if FACT = 'N' or  LYAPUN = 'O';
C             LDA >= 1,        if FACT = 'F' and LYAPUN = 'R'.
C
C     T       (input/output) DOUBLE PRECISION array, dimension
C             (LDT,N)
C             If FACT = 'F', then on entry the leading N-by-N upper
C             Hessenberg part of this array must contain the upper
C             quasi-triangular matrix T in Schur canonical form from a
C             Schur factorization of A.
C             If FACT = 'N', then this array need not be set on input.
C             On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the
C             leading N-by-N upper Hessenberg part of this array
C             contains the upper quasi-triangular matrix T in Schur
C             canonical form from a Schur factorization of A.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= MAX(1,N).
C
C     U       (input or output) DOUBLE PRECISION array, dimension
C             (LDU,N)
C             If LYAPUN = 'O' and FACT = 'F', then U is an input
C             argument and on entry, the leading N-by-N part of this
C             array must contain the orthogonal matrix U from a real
C             Schur factorization of A.
C             If LYAPUN = 'O' and FACT = 'N', then U is an output
C             argument and on exit, if INFO = 0 or INFO = N+1, it
C             contains the orthogonal N-by-N matrix from a real Schur
C             factorization of A.
C             If LYAPUN = 'R', the array U is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= 1,        if LYAPUN = 'R';
C             LDU >= MAX(1,N), if LYAPUN = 'O'.
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             If UPLO = 'U', the leading N-by-N upper triangular part of
C             this array must contain the upper triangular part of the
C             matrix C of the original Lyapunov equation (with
C             matrix A), if LYAPUN = 'O', or of the reduced Lyapunov
C             equation (with matrix T), if LYAPUN = 'R'.
C             If UPLO = 'L', the leading N-by-N lower triangular part of
C             this array must contain the lower triangular part of the
C             matrix C of the original Lyapunov equation (with
C             matrix A), if LYAPUN = 'O', or of the reduced Lyapunov
C             equation (with matrix T), if LYAPUN = 'R'.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,N).
C
C     X       (input) DOUBLE PRECISION array, dimension (LDX,N)
C             The leading N-by-N part of this array must contain the
C             symmetric solution matrix X of the original Lyapunov
C             equation (with matrix A), if LYAPUN = 'O', or of the
C             reduced Lyapunov equation (with matrix T), if
C             LYAPUN = 'R'.
C             The array X is modified internally, but restored on exit.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= MAX(1,N).
C
C     SEPD    (output) DOUBLE PRECISION
C             If JOB = 'C' or JOB = 'B', the estimated quantity
C             sepd(op(A),op(A)').
C             If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced.
C
C     RCOND   (output) DOUBLE PRECISION
C             If JOB = 'C' or JOB = 'B', an estimate of the reciprocal
C             condition number of the discrete-time Lyapunov equation.
C             If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
C             If JOB = 'E', RCOND is not referenced.
C
C     FERR    (output) DOUBLE PRECISION
C             If JOB = 'E' or JOB = 'B', an estimated forward error
C             bound for the solution X. If XTRUE is the true solution,
C             FERR bounds the magnitude of the largest entry in
C             (X - XTRUE) divided by the magnitude of the largest entry
C             in X.
C             If N = 0 or X = 0, FERR is set to 0.
C             If JOB = 'C', FERR is not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
C             optimal value of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 1,                            if N = 0; else,
C             LDWORK >= MAX(3,2*N*N) + N*N,           if JOB  = 'C',
C                                                        FACT = 'F';
C             LDWORK >= MAX(MAX(3,2*N*N) + N*N, 5*N), if JOB  = 'C',
C                                                        FACT = 'N';
C             LDWORK >= MAX(3,2*N*N) + N*N + 2*N,     if JOB  = 'E', or
C                                                        JOB  = 'B'.
C             For optimum performance LDWORK should sometimes be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
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             > 0:  if INFO = i, i <= N, the QR algorithm failed to
C                   complete the reduction to Schur canonical form (see
C                   LAPACK Library routine DGEES); on exit, the matrix
C                   T(i+1:N,i+1:N) contains the partially converged
C                   Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N)
C                   contain the real and imaginary parts, respectively,
C                   of the converged eigenvalues; this error is unlikely
C                   to appear;
C             = N+1:  if the matrix T has almost reciprocal eigenvalues;
C                   perturbed values were used to solve Lyapunov
C                   equations, but the matrix T, if given (for
C                   FACT = 'F'), is unchanged.
C
C     METHOD
C
C     The condition number of the discrete-time Lyapunov equation is
C     estimated as
C
C     cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X),
C
C     where Omega and Theta are linear operators defined by
C
C     Omega(W) = op(A)'*W*op(A) - W,
C     Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))).
C
C     The routine estimates the quantities
C
C     sepd(op(A),op(A)') = 1 / norm(inv(Omega))
C
C     and norm(Theta) using 1-norm condition estimators.
C
C     The forward error bound is estimated using a practical error bound
C     similar to the one proposed in [1].
C
C     REFERENCES
C
C     [1] Higham, N.J.
C         Perturbation theory and backward error for AX-XB=C.
C         BIT, vol. 33, pp. 124-136, 1993.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C     The accuracy of the estimates obtained depends on the solution
C     accuracy and on the properties of the 1-norm estimator.
C
C     FURTHER COMMENTS
C
C     The option LYAPUN = 'R' may occasionally produce slightly worse
C     or better estimates, and it is much faster than the option 'O'.
C     When SEPD is computed and it is zero, the routine returns
C     immediately, with RCOND and FERR (if requested) set to 0 and 1,
C     respectively. In this case, the equation is singular.
C
C     CONTRIBUTORS
C
C     P. Petkov, Tech. University of Sofia, December 1998.
C     V. Sima, Katholieke Univ. Leuven, Belgium, February 1999.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, March 2003, July 2012.
C
C     KEYWORDS
C
C     Lyapunov equation, orthogonal transformation, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, THREE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, THREE = 3.0D0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND, SCALE, SEPD
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), DWORK( * ),
     $                   T( LDT, * ), U( LDU, * ), X( LDX, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            JOBB, JOBC, JOBE, LOWER, LQUERY, NOFACT,
     $                   NOTRNA, UPDATE
      CHARACTER          SJOB, TRANAT
      INTEGER            I, IABS, IRES, IWRK, IXMA, J, LDW, NN, SDIM,
     $                   WRKOPT
      DOUBLE PRECISION   ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM,
     $                   TMAX, XANORM, XNORM
C     ..
C     .. Local Arrays ..
      LOGICAL            BWORK( 1 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME, SELECT
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANHS, DLANSY
      EXTERNAL           DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEES, DGEMM, DLACPY, DLASET,
     $                   MA02ED, MB01RU, MB01RX, MB01RY, MB01UD, SB03SX,
     $                   SB03SY, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      JOBC   = LSAME( JOB,    'C' )
      JOBE   = LSAME( JOB,    'E' )
      JOBB   = LSAME( JOB,    'B' )
      NOFACT = LSAME( FACT,   'N' )
      NOTRNA = LSAME( TRANA,  'N' )
      LOWER  = LSAME( UPLO,   'L' )
      UPDATE = LSAME( LYAPUN, 'O' )
C
      NN  = N*N
      LDW = MAX( 3, 2*NN ) + NN
C
      INFO = 0
      IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA,  'T' ) .OR.
     $                            LSAME( TRANA,  'C' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( LOWER  .OR. LSAME( UPLO,   'U' ) ) ) THEN
         INFO = -4
      ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN
         INFO = -7
      ELSE IF( LDA.LT.1 .OR.
     $       ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN
         INFO = -9
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE
         IF( JOBC ) THEN
            IF( NOFACT ) THEN
               IWRK = MAX( LDW, 5*N )
            ELSE
               IWRK = LDW
            END IF
         ELSE
            IWRK = LDW + 2*N
         END IF
         IWRK = MAX( 1, IWRK )
         LQUERY = LDWORK.EQ.-1
         IF( NOFACT ) THEN
            IF( UPDATE ) THEN
               SJOB = 'V'
            ELSE
               SJOB = 'N'
            END IF
         END IF
         IF( LQUERY ) THEN
            IF( NOFACT ) THEN
               CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM,
     $                     DWORK, DWORK, U, LDU, DWORK, -1, BWORK,
     $                     INFO )
               WRKOPT = MAX( IWRK, INT( DWORK( 1 ) ) + 2*N )
            ELSE
               WRKOPT = IWRK
            END IF
         END IF
         IF( LDWORK.LT.IWRK .AND. .NOT. LQUERY )
     $      INFO = -23
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB03SD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK( 1 ) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         IF( .NOT.JOBE )
     $      RCOND = ONE
         IF( .NOT.JOBC )
     $      FERR  = ZERO
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Compute the 1-norm of the matrix X.
C
      XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK )
      IF( XNORM.EQ.ZERO ) THEN
C
C        The solution is zero.
C
         IF( .NOT.JOBE )
     $      RCOND = ZERO
         IF( .NOT.JOBC )
     $      FERR  = ZERO
         DWORK( 1 ) = DBLE( N )
         RETURN
      END IF
C
C     Compute the 1-norm of A or T.
C
      IF( NOFACT .OR. UPDATE ) THEN
         ANORM  = DLANGE( '1-norm', N, N, A, LDA, DWORK )
      ELSE
         ANORM  = DLANHS( '1-norm', N, T, LDT, DWORK )
      END IF
C
C     For the special case A = I, set SEPD and RCOND to 0.
C     For the special case A = 0, set SEPD and RCOND to 1.
C     A quick test is used in general.
C
      IF( ANORM.EQ.ONE ) THEN
         IF( NOFACT .OR. UPDATE ) THEN
            CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N )
         ELSE
            CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N )
            IF( N.GT.2 )
     $         CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ),
     $                      N )
         END IF
         DWORK( NN+1 ) = ONE
         CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 )
         IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN
            IF( .NOT.JOBE ) THEN
               SEPD  = ZERO
               RCOND = ZERO
            END IF
            IF( .NOT.JOBC )
     $         FERR = ONE
            DWORK( 1 ) = DBLE( NN + 1 )
            RETURN
         END IF
C
      ELSE IF( ANORM.EQ.ZERO ) THEN
         IF( .NOT.JOBE ) THEN
            SEPD  = ONE
            RCOND = ONE
         END IF
         IF( JOBC ) THEN
            DWORK( 1 ) = DBLE( N )
            RETURN
         ELSE
C
C           Set FERR for the special case A = 0.
C
            CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N )
C
            IF( LOWER ) THEN
               DO 10 J = 1, N
                  CALL DAXPY( N-J+1, SCALE, C( J, J ), 1,
     $                        DWORK( (J-1)*N+J ), 1 )
   10          CONTINUE
            ELSE
               DO 20 J = 1, N
                  CALL DAXPY( J, SCALE, C( 1, J ), 1,
     $                        DWORK( (J-1)*N+1 ), 1 )
   20          CONTINUE
            END IF
C
            FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N,
     $                               DWORK( NN+1 ) ) / XNORM )
            DWORK( 1 ) = DBLE( NN + N )
            RETURN
         END IF
      END IF
C
C     General case.
C
      CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK )
C
C     Workspace usage.
C
      IABS = NN
      IXMA = MAX( 3, 2*NN )
      IRES = IXMA
      IWRK = IXMA + NN
      WRKOPT = 0
C
      IF( NOFACT ) THEN
C
C        Compute the Schur factorization of A, A = U*T*U'.
C        Workspace:  need   5*N;
C                    prefer larger.
C        (Note: Comments in the code beginning "Workspace:" describe the
C        minimal amount of real workspace needed at that point in the
C        code, as well as the preferred amount for good performance.)
C
         CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
         CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM,
     $               DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ),
     $               LDWORK-2*N, BWORK, INFO )
         IF( INFO.GT.0 )
     $      RETURN
         WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N
      END IF
C
C     Compute X*op(A) or X*op(T).
C
      IF( UPDATE ) THEN
         CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, A, LDA,
     $               ZERO, DWORK( IXMA+1 ), N )
      ELSE
         CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX,
     $                DWORK( IXMA+1 ), N, INFO )
      END IF
C
      IF( .NOT.JOBE ) THEN
C
C        Estimate sepd(op(A),op(A)') = sepd(op(T),op(T)') and
C        norm(Theta).
C        Workspace max(3,2*N*N) + N*N.
C
         CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU,
     $                DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK,
     $                IXMA, INFO )
C
         WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN )
C
C        Return if the equation is singular.
C
         IF( SEPD.EQ.ZERO ) THEN
            RCOND = ZERO
            IF( JOBB )
     $         FERR  = ONE
            DWORK( 1 ) = DBLE( WRKOPT )
            RETURN
         END IF
C
C        Estimate the reciprocal condition number.
C
         TMAX = MAX( SEPD, XNORM, ANORM )
         IF( TMAX.LE.ONE ) THEN
            TEMP  =    SEPD*XNORM
            DENOM = ( SCALE*CNORM ) + ( SEPD*ANORM )*THNORM
         ELSE
            TEMP  =   (  SEPD / TMAX )*( XNORM / TMAX )
            DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) +
     $              ( (  SEPD / TMAX )*( ANORM / TMAX ) )*THNORM
         END IF
         IF( TEMP.GE.DENOM ) THEN
            RCOND = ONE
         ELSE
            RCOND = TEMP / DENOM
         END IF
      END IF
C
      IF( .NOT.JOBC ) THEN
C
C        Form a triangle of the residual matrix
C        R = scale*C + X - op(A)'*X*op(A), or
C        R = scale*C + X - op(T)'*X*op(T),
C        exploiting the symmetry. For memory savings, R is formed in the
C        leading N-by-N upper/lower triangular part of DWORK, and it is
C        finally moved in the location where X*op(A) or X*op(T) was
C        stored, freeing workspace for the SB03SX call.
C
         IF( NOTRNA ) THEN
            TRANAT = 'T'
         ELSE
            TRANAT = 'N'
         END IF
C
         CALL DLACPY( UPLO, N, N, C, LDC, DWORK, N )
C
         IF( UPDATE ) THEN
            CALL MB01RX( 'Left', UPLO, TRANAT, N, N, SCALE, -ONE, DWORK,
     $                   N, A, LDA, DWORK( IXMA+1 ), N, INFO )
         ELSE
            CALL MB01RY( 'Left', UPLO, TRANAT, N, SCALE, -ONE, DWORK, N,
     $                   T, LDT, DWORK( IXMA+1 ), N, DWORK( IWRK+1 ),
     $                   INFO )
         END IF
C
         IF( LOWER ) THEN
            DO 30 J = 1, N
               CALL DAXPY( N-J+1, ONE, X( J, J ), 1, DWORK( (J-1)*N+J ),
     $                     1 )
   30       CONTINUE
         ELSE
            DO 40 J = 1, N
               CALL DAXPY( J, ONE, X( 1, J ), 1, DWORK( (J-1)*N+1 ), 1 )
   40       CONTINUE
         END IF
C
         CALL DLACPY( UPLO, N, N, DWORK, N, DWORK( IRES+1 ), N )
C
C        Get the machine precision.
C
         EPS  = DLAMCH( 'Epsilon' )
         EPSN = EPS*DBLE( 2*N + 2 )
C
C        Add to abs(R) a term that takes account of rounding errors in
C        forming R:
C          abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) +
C                    2*(n+1)*abs(op(A))'*abs(X)*abs(op(A))), or
C          abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) +
C                    2*(n+1)*abs(op(T))'*abs(X)*abs(op(T))),
C        where EPS is the machine precision.
C        Workspace max(3,2*N*N) + N*N + 2*N.
C        Note that the lower or upper triangular part of X specified by
C        UPLO is used as workspace, but it is finally restored.
C
         IF( UPDATE ) THEN
            DO 60 J = 1, N
               DO 50 I = 1, N
                  DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) )
   50          CONTINUE
   60       CONTINUE
         ELSE
            DO 80 J = 1, N
               DO 70 I = 1, MIN( J+1, N )
                  DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) )
   70          CONTINUE
   80       CONTINUE
         END IF
C
         CALL DCOPY( N, X, LDX+1, DWORK( IWRK+1 ), 1 )
C
         IF( LOWER ) THEN
            DO 100 J = 1, N
               DO 90 I = J, N
                  TEMP = ABS( X( I, J ) )
                  X( I, J ) = TEMP
                  DWORK( IRES+(J-1)*N+I ) =
     $                   ABS( DWORK( IRES+(J-1)*N+I ) ) +
     $                   EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP )
   90          CONTINUE
  100       CONTINUE
         ELSE
            DO 120 J = 1, N
               DO 110 I = 1, J
                  TEMP = ABS( X( I, J ) )
                  X( I, J ) = TEMP
                  DWORK( IRES+(J-1)*N+I ) =
     $                   ABS( DWORK( IRES+(J-1)*N+I ) ) +
     $                   EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP )
  110          CONTINUE
  120       CONTINUE
         END IF
C
         IF( UPDATE ) THEN
            CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPSN, DWORK( IRES+1 ),
     $                   N, DWORK( IABS+1 ), N, X, LDX, DWORK, NN,
     $                   INFO )
         ELSE
C
C           Compute W = abs(X)*abs(op(T)), and then premultiply by
C           abs(T)' and add in the result.
C
            CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N,
     $                   X, LDX, DWORK, N, INFO )
            CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN,
     $                   DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, DWORK,
     $                   N, DWORK( IWRK+N+1 ), INFO )
         END IF
C
         WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN + 2*N )
C
C        Restore X.
C
         CALL DCOPY( N, DWORK( IWRK+1 ), 1, X, LDX+1 )
         IF( LOWER ) THEN
            CALL MA02ED( 'Upper', N, X, LDX )
         ELSE
            CALL MA02ED( 'Lower', N, X, LDX )
         END IF
C
C        Compute forward error bound, using matrix norm estimator.
C        Workspace max(3,2*N*N) + N*N.
C
         XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK )
C
         CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU,
     $                DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES,
     $                INFO )
      END IF
C
      DWORK( 1 ) = DBLE( WRKOPT )
      RETURN
C
C *** Last line of SB03SD ***
      END


      FUNCTION rtnewt(funcd,x1,x2,xacc)
      INTEGER JMAX
      REAL rtnewt,x1,x2,xacc
      EXTERNAL funcd
      PARAMETER (JMAX=20)
      INTEGER j
      REAL df,dx,f
      rtnewt=.5*(x1+x2)
      do 11 j=1,JMAX
        call funcd(rtnewt,f,df)
        dx=f/df
        rtnewt=rtnewt-dx
        if((x1-rtnewt)*(rtnewt-x2).lt.0.)pause
     *'rtnewt jumped out of brackets'
        if(abs(dx).lt.xacc) return
11    continue
      pause 'rtnewt exceeded maximum iterations'
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rtnewt.for


! Program to test the UNPACK intrinsic
program intrinsic_unpack
   integer, dimension(3, 3) :: a, b
   logical, dimension(3, 3) :: mask;
   character(len=50) line1, line2
   integer i

   mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,&
                    &.false.,.false.,.true./), (/3, 3/));
   a = reshape ((/1, 0, 0, 0, 1, 0, 0, 0, 1/), (/3, 3/));
   b = unpack ((/2, 3, 4/), mask, a)
   if (any (b .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) &
      call abort
   write (line1,'(10I4)') b
   write (line2,'(10I4)') unpack((/2, 3, 4/), mask, a)
   if (line1 .ne. line2) call abort
   b = -1
   b = unpack ((/2, 3, 4/), mask, 0)
   if (any (b .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) &
      call abort
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 or coefficients that
c     # have a discontinuity along some curve.

c     # fdisc should be negative to the "left" of the curve and
c     # positive to the "right".

c     # The cellave routine can then be used to compute the fraction wl of
c     # a grid cell that lies to the "left" of the curve.

c     # Sample code for the case where the curve is the unit circle:

      fdisc = x**2 + y**2 - 1.d0
c
      return
      end


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    integer, parameter :: XX = 16            ! maximum age of individuals
    integer, parameter :: TT = XX - 1        ! maximum number of periods
    integer, parameter :: KK = 100000        ! number of mortality path simulations
    integer, parameter :: NN = 5             ! number of insurance contracts

    real*8, parameter  :: sigma_eps = 2.0d0  ! variance of the innovation to the random walk
    real*8, parameter  :: c = -1.0d0         ! drift of random walk

    real*8, parameter  :: r = 0.16d0         ! interest rate
    real*8, parameter  :: xi_1 = 0.05d0      ! loading factor for premium calculation (annuity)
    real*8, parameter  :: xi_2 = 0.05d0      ! discount factor for premium calculation (life insurance)
    real*8, parameter  :: gamma = 10.0d0     ! risk aversion

    real*8 :: q(XX, 0:TT, 0:KK), alpha(XX), beta(XX), kappa(0:TT), eps(TT)
    real*8 :: PP(XX, 0:TT, 0:KK), LE(XX, 0:KK)
    real*8 :: p_m(NN), omega(NN), n_new(NN)
    real*8 :: l(NN, KK), l_p(KK)
    real*8 :: mu(NN), sig(NN, NN), mu_p, sig_p, sum_premia
    real*8 :: VaR, CVaR, IID(NN), x_in(2*NN+1)
    real*8 :: age(0:TT+1), PP_av(0:TT+1), PP_min(0:TT+1), PP_max(0:TT+1)
    integer :: ix, ik, it, ik_max, ik_min, ii, im, id, ij, ii_VaR
    logical :: check

    ! define an insurance type
    type :: insurance_type
        character(len=2) :: itype
        integer :: ix, im, id
        real*8 :: BB, n_ins
    end type

    ! declare the insurance variable
    type(insurance_type) :: ins(NN)

contains

    ! first order condition of the insurer
    function focs(x_in)

        implicit none
        real*8, intent(in) :: x_in(:)
        real*8 :: focs(size(x_in, 1))
        real*8 :: omega(NN), eta(NN), lamda

        ! copy portfolio weights
        omega = x_in(1:NN)

        ! copy lagrangean multipliers
        lamda = x_in(NN+1)
        eta   = x_in(NN+2:2*NN+1)

        ! set up first order conditions
        focs(1:NN) = - mu - gamma*matmul(sig, omega) - lamda + eta
        focs(NN+1) = sum(omega) - 1d0
        focs(NN+2:2*NN+1) = omega + eta - sqrt(omega**2 + eta**2)

    end function focs

end module globals


module myinvert
 contains
   subroutine invert (matrix,size)
    implicit none
    integer, parameter:: b8 = selected_real_kind(14)
    integer, parameter :: nmax=5000
    integer switch,k, jj, kp1, i, j, l, krow, irow,size
    dimension switch(nmax,2)
    real(b8) matrix(size,size)
    real(b8) pivot, temp
    do 100 k = 1,size
    jj = k
        if (k .ne. size) then
        kp1 = k + 1
        pivot = (matrix(k, k))
        do 1 i = kp1,size
        temp = (matrix(i, k))
        if (abs(pivot) .lt. abs(temp)) then
        pivot = temp
        jj = i
        endif
 1  continue
        endif
    switch(k, 1) = k
    switch(k, 2) = jj
    if (jj .ne. k) then
        do 2  j = 1 ,size
    temp = matrix(jj, j)
    matrix(jj, j) = matrix(k, j)
    matrix(k, j) = temp
 2  continue
    endif
    do 3 j = 1,size
    if (j .ne. k)matrix(k, j) = matrix(k, j) / matrix(k, k)
 3  continue
    matrix(k, k) = 1.0 / matrix(k, k)
    do 4 i = 1,size
    if (i.ne.k) then
    do 40 j = 1,size
    if(j.ne.k)matrix(i,j)=matrix(i,j)-matrix(k,j)*matrix(i,k)
 40 continue
    endif
 4  continue
    do 5 i = 1, size
    if (i .ne. k)matrix(i, k) = -matrix(i, k) * matrix(k, k)
 5  continue
 100    continue
    do 6 l = 1,size
    k = size - l + 1
    krow = switch(k, 1)
    irow = switch(k, 2)
    if (krow .ne. irow) then
    do 60 i = 1,size
    temp = matrix(i, krow)
    matrix(i, krow) = matrix(i, irow)
    matrix(i, irow) = temp
 60 continue
    endif
 6  continue
    return
    end
	subroutine dGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
	implicit none
	integer, parameter:: b8 = selected_real_kind(14)
	real(b8) A(:,:),B(:,:)
	integer :: IPIV(:)
	integer n,nrhs,lda,ldb,info
	real(b8), allocatable :: x(:)
	allocate(x(n))
	call invert(a,n)
	x=matmul(a,b(:,1))
	b(:,1)=x
	deallocate(x)
	info=0
	end subroutine
end module


	module sub1
	contains
	subroutine cg(A,b,x,N,e)
c	variable	meaning
c	A		a matrix,from main program,is coefficient matrix of Ax=b
c	b		a vector,from main program,is righthand of Ax=b
c	x		a vector,the answer of Ax=b,is what we need,our goal
c	r		a vector,minus grads of 0.5xAx-bx at x point,says b-Ax
c	p		a vector,the direction of iteration better than r
c	w		a vector,value is A*p,is useful to simplify the process
c	q0		a number,value is r0*r0,is standard of loop times
c	q1		a number,value is rk-1*rk-1
c	q2		a number, value is rk*rk
c	ba,ar		a number,named by their pronounciation
c	e		a number,standard of loop times,input by client
c	test		a number,value is matmul(r,w)
c	pw		a number,value is matmul(p,w)
c	i		a number,count variable
c	N		a number,the degree of A
	real*8 A(N,N)
	real*8 b(N),x(N),r(N),p(N),w(N)
c	real*8 A(2,2),b(2),x(2),r(2),p(2),w(2)
	real*8 q0,q1,q2,ba,ar,e,test,pw
	integer i,N
c	write(*,*)"you want the x_error less than?"
c	read(*,*)e
	x=0.0d0
	r=b
	call onedimenmul(r,r,N,q0)
	q2=q0
	p=r

c	w=matmul(A,p)
c	call onedimenmul(r,w,2,test)
c	ar=q2/test
c	x=x+ar*p
c	r=r-ar*w
c	q1=q2;call onedimenmul(r,r,2,q2)
c	r=r-a*w
	i=1
	do while(q2>=q0*e)
	q1=q2
c	ba=q2/q1
c	p=r+ba*p

	w=matmul(A,p)
	call onedimenmul(p,w,N,pw)
c	pw is p*w
	ar=q1/pw
	x=x+ar*p
	r=r-ar*w
	call onedimenmul(r,r,N,q2)
c	r=r-a*w
	ba=q2/q1
	i=i+1
	p=r+ba*p
	end do
	end subroutine cg

c	This subroutine is to solve one dimention's multiplication
	subroutine onedimenmul(m1,m2,n,ans)
	integer n
	real*8 m1(n),m2(n),ans
	ans=0
	do i=1,n
	ans=m1(i)*m2(i)+ans
	end do

	end subroutine onedimenmul

	end module sub1


module m_line

   use m_kind_parameters

   implicit none

   private
   public :: line

   type :: line

      real(kind=rel_kind) :: origin(n_dim)              ! origin of line
      real(kind=rel_kind) :: terminus(n_dim)            ! terminus of line
      real(kind=rel_kind) :: direction(n_dim)           ! direction unit vector
      real(kind=rel_kind) :: inv_direction(n_dim)       ! 1/direction
      real(kind=rel_kind) :: length                     ! length of line

      contains

      procedure,non_overridable :: initialise

   end type

   contains

   pure subroutine initialise(self,origin,direction,length)

      ! argument declarations
      class(line),intent(inout) :: self                 ! line object
      real(kind=rel_kind),intent(in) :: origin(n_dim)   ! origin of line
      real(kind=rel_kind),intent(in) :: direction(n_dim)! direction of line
      real(kind=rel_kind),intent(in) :: length          ! length of line

      ! set variables
      self%origin=origin
      self%direction=direction/norm2(direction)
      self%length=length
      self%inv_direction=1._rel_kind/self%direction
      self%terminus=self%origin+self%length*self%direction

      return

   end subroutine

end module


!--------------------------------------------------
!PHY1038 Assignment 4 Matrix Geometry
!URN: 6408056
!MAY 2017
!--------------------------------------------------

PROGRAM Matrix_Geometry

IMPLICIT NONE

REAL, DIMENSION(1:3,1:1)::Array, Rot, Tran, Arrayone, Arraytwo, Arraythree, OArrayone, OArraytwo
REAL, DIMENSION(1:3,1:1)::OArraythree
CHARACTER::Mainloop, Intro, Main, Correction
INTEGER:: I, N, Itwo
REAL:: Inputangle, Xtranslation, Ytranslation

Mainloop='Y'!Allows main do loop to play intially
Intro='Y'!Allows intro to play on first run

DO WHILE (Mainloop=='Y' .OR. Mainloop=='y')

  IF(Intro=='Y') THEN
    WRITE(6,*) 'This program allows you to enter x and y coordinates and have them translated'
    WRITE(6,*) 'or rotated, it also allows you to rotate a triangle about its centre of mass.'
    WRITE(6,*) 'The program lets you enter your own rotation angle/translations.'
    WRITE(6,*) 'It then prints the translated/rotated coordinates to the screen as well as'
    WRITE(6,*) 'a file, named translate.dat, rotate.dat, or triangle.dat'
    WRITE(6,*) 'It writes the orginal coordinates in lines one and two, and the altered'
    WRITE(6,*) 'coordinates in lines three and four'
    WRITE(6,*) 'When using program please enter your coordiantes x first e.g.: x, y, x, y'
    Intro='N' !Prevents the intro being played too many times
  END IF

  WRITE(6,*)'If you would like to rotate a vector by a paticular angle type, R, for a translation'
  WRITE(6,*)'type T, to rotate a triangle about its centre of mass type, C'

  DO !replays if an invalid choice is entered
    READ(5,*) Main

    IF(Main=='r' .or. Main=='R' .or. Main=='t' .or. Main=='T' .or. Main=='c' .or. Main== 'C')THEN
      EXIT !If loop allows the exit from do loop only when a valid choice is entered
    END IF

    WRITE(6,*) 'Please enter a valid option'
    WRITE(6,*) 'Enter, R, for rotation, T, for translation, or C to rotate a triangle about its'
    WRITE(6,*) 'centre of mass.'

  END DO

  IF (Main=='r' .or. Main=='R') THEN !Main if command seperates the main components of the program

    DO !Do loop will replay if user says they entered the 'wrong coordinates'

      WRITE(6,*) 'How many points would you like to rotate?'
      READ(5,*) N
      WRITE(6,*) 'By what angle, in radians, would you like to rotate them by?'
      READ(5,*) Inputangle
      WRITE(6,*) 'You entered',N,' as the amount of points you want to rotate, and'
      WRITE(6,*) Inputangle, 'As the amount you want to rotate them by, is this correct?'
      DO !Do loop will replay if user enters an 'invalid choice'
        WRITE(6,*) 'Type Y for yes, or N for no.'
        READ(5,*) Correction

        IF (Correction=='n' .or. Correction=='y' .or. Correction=='N' .or. Correction=='Y') THEN
          EXIT !Exits 'invalid choice' do loop when they enter valid choice
        END IF
        WRITE(6,*) 'Please enter a valid choice.'
      END DO

      IF (Correction=='Y' .or. Correction=='y')THEN
        EXIT !Exits 'wrong coordinates' do loop when they say they entered the right coordinates
      END IF

    END DO

    OPEN(unit=20,file='rotate.dat')

    DO I=1,N !Plays once for every coordinate that they wanted to enter

      WRITE(6,*) 'Please enter Array number',i,' that you want to rotate, x then y.'
      READ(5,*) Array(1,1), Array(2,1)

      Array(3,1)=1  !Setting z coordinate to 1 for rotation matrix to work

      Rot = Rotation(Array,Inputangle) !Calls on rotation function, and stores it as a different
                                       !Array allowing program call on just the x and y coordinates
      WRITE(6,*)'Your number',I,' rotated array is:'
      WRITE(6,*) Rot(1,1), Rot(2,1)
      WRITE(20,*) Array(1,1), Array(2,1), Rot(1,1), Rot(2,1) !Prints orginal, and altered
                                                             !coordinates to file

      IF (I==1) THEN
        Arrayone=Array; Arraytwo=Rot !This stores the first set of coordinates to later print
      ELSE IF (I==N) THEN
        WRITE(20,*) Arrayone(1,1), Arrayone(2,1), Arraytwo(1,1), Arraytwo(2,1)
      END IF !Prints coordinates to file, to allow for conjoined shape when plotting

    END DO

    CLOSE(20)

  ELSE IF (Main=='t' .or. Main=='T') THEN

    DO !Do loop will replay if user says they entered the 'wrong coordinates'

      WRITE(6,*) 'How many points would you like to translate?'
      READ(5,*) N
      WRITE(6,*) 'Please enter the amount you want to translate x by.'
      READ(5,*) Xtranslation
      WRITE(6,*) 'Please enter the amount you want to translate y by.'
      READ(5,*) Ytranslation
      WRITE(6,*) 'You entered',N,' as the amount of points you want to translate, and', Xtranslation
      WRITE(6,*) Ytranslation, 'as the amount to translate x, then y by.'

      DO !Do loop will replay if user enters an 'invalid choice'
        WRITE(6,*) 'Type Y for yes, or N for no.'
        READ(5,*) Correction
        IF (Correction=='n' .or. Correction=='y' .or. Correction=='N' .or. Correction=='Y') THEN
          EXIT!Exits 'invalid choice' do loop when they enter valid choice
        END IF
        WRITE(6,*) 'Please enter a valid choice.'
      END DO

      IF (Correction=='Y' .or. Correction=='y')THEN
        EXIT !Exits 'wrong coordinates' do loop when they say they entered the right coordinates
      END IF

    END DO

    OPEN(unit=20,file='translate.dat')

    DO Itwo=1,N !Plays once for each coordinate

      WRITE(6,*) 'Please enter Array number',Itwo,' that you want to translate, x then y.'
      READ(5,*) Array(1,1), Array(2,1)

      Array(3,1)=1  !Setting Z coordinate to one so translation equation will work

      Tran = Translation(Array, Xtranslation, Ytranslation)!calls on translation function and
      !stores altered coordinates in a different array, allowing program to call on it x and y only

      WRITE(6,*)'Your number',Itwo,' translated array is:'
      WRITE(6,*) Tran(1,1), Tran(2,1) !prints altered coordinates to screen
      WRITE(20,*) Array(1,1), Array(2,1), Tran(1,1), Tran(2,1)!writes both orginal and altered
                                                              !altered coordinates to file
      IF (Itwo==1) THEN
        Arrayone=Array; Arraytwo=Tran !stores first set of coordinates as seperate arrays
      ELSE IF (Itwo==N) THEN
        WRITE(20,*) Arrayone(1,1), Arrayone(2,1), Arraytwo(1,1), Arraytwo(2,1)
      END IF !Prints first set of coordinates to file again, for conjoined shape

    END DO

    CLOSE(20)

  ELSE IF (Main=='c' .or. Main=='C') THEN

    Arrayone(3,1)=1; Arraytwo(3,1)=1; Arraythree(3,1)=1 !Setting all three z coordinates to 1
                                                        !So equations in functions work
    DO!Do loop will replay if user says they entered the 'wrong coordinates'

      WRITE(6,*) 'Please enter the three x,y coordinates of the vertices of your triangle.'
      READ(5,*) Arrayone(1,1), Arrayone(2,1), Arraytwo(1,1), Arraytwo(2,1), Arraythree(1,1)
      READ(5,*) Arraythree(2,1)
      WRITE(6,*) 'Please enter the angle you want to rotate the triangle by in radians.'
      READ(5,*) Inputangle
      WRITE(6,*) 'You entered', Arrayone(1,1), Arrayone(2,1),'as one vertice', Arraytwo(1,1)
      WRITE(6,*) Arraytwo(2,1), 'as another and', Arraythree(1,1), Arraythree(2,1), 'as the third.'
      WRITE(6,*) 'You entered the angle of rotation to be', Inputangle
      WRITE(6,*) 'Is that correct? Type Y for yes, or N for no.'

      DO !Do loop will replay if user enters an 'invalid choice'
        WRITE(6,*) 'Type Y for yes, or N for no.'
        READ(5,*) Correction
        IF (Correction=='n' .or. Correction=='y' .or. Correction=='N' .or. Correction=='Y') THEN
          EXIT !Exits 'invalid choice' do loop when they enter valid choice
        END IF
        WRITE(6,*) 'Please enter a valid choice.'
      END DO

      IF (Correction=='Y' .or. Correction=='y')THEN
        EXIT !Exits 'wrong coordinates' do loop when they say they entered the right coordinates
      END IF

    END DO

    OArrayone=Arrayone; OArraytwo=Arraytwo; OArraythree=Arraythree
    !Stores orginal arrays with 'o' prefix, so they can later be written to a file
    OPEN(unit=20,file='triangle.dat')

    Xtranslation=(Arrayone(1,1)+Arraytwo(1,1)+Arraythree(1,1))/3
    Ytranslation=(Arrayone(2,1)+Arraytwo(2,1)+Arraythree(2,1))/3
    !^Calculates COM

    WRITE(6,*) 'Centre of mass of the triangle is', Xtranslation, Ytranslation

    Xtranslation=-Xtranslation; Ytranslation=-Ytranslation
    !^Turns COM in negative translations, so program can set it to the origin

    Array = Arrayone; Arrayone = Translation(Array, Xtranslation, Ytranslation)
    Array = Arraytwo; Arraytwo = Translation(Array, Xtranslation, Ytranslation)
    Array = Arraythree; Arraythree = Translation(Array, Xtranslation, Ytranslation)
    !^Translates all coorinates so that COM is at origin

    Array = Arrayone; Arrayone = Rotation(Array,Inputangle)
    Array = Arraytwo; Arraytwo = Rotation(Array,Inputangle)
    Array = Arraythree; Arraythree = Rotation(Array,Inputangle)
    !^Rotates coordinates, so that triangle is rotates

    Xtranslation=-Xtranslation; Ytranslation=-Ytranslation
    !^Again reverses coordinates so that COM can be returned to original postion

    Array = Arrayone; Arrayone = Translation(Array, Xtranslation, Ytranslation)
    Array = Arraytwo; Arraytwo = Translation(Array, Xtranslation, Ytranslation)
    Array = Arraythree; Arraythree = Translation(Array, Xtranslation, Ytranslation)
    !^Places COM in original postions

    WRITE(6,*) 'The three vertices of your rotated triangle, (x,y), are:'

    WRITE(6,*) Arrayone(1,1), Arrayone(2,1)
    WRITE(20,*) OArrayone(1,1), OArrayone(2,1), Arrayone(1,1), Arrayone(2,1)

    WRITE(6,*) Arraytwo(1,1), Arraytwo(2,1)
    WRITE(20,*) OArraytwo(1,1), OArraytwo(2,1), Arraytwo(1,1), Arraytwo(2,1)

    WRITE(6,*) Arraythree(1,1), Arraythree(2,1)
    WRITE(20,*) OArraythree(1,1), OArraythree(2,1), Arraythree(1,1), Arraythree(2,1)
    !^Prints all three rotated coordiantes to screen, as well as printing orginal and altered
    !to file

    WRITE(20,*) OArrayone(1,1), OArrayone(2,1), Arrayone(1,1), Arrayone(2,1)
    !^Prints 1st coordinates again to produce conjoined shape

    CLOSE(20)

  END IF

  WRITE(6,*) 'Would you like to run the program again?'!Allows user to choose between main parts of
                                                       !program again
  WRITE(6,*) 'Type Y for Yes, or N for No.'
  DO !Plays loop again if valid choice is not entered
    READ(5,*) Mainloop
    IF (Mainloop=='n' .or. Mainloop=='y' .or. Mainloop=='N' .or. Mainloop=='Y') THEN
      EXIT!Exits loop when valid choice is chosen
    END IF
    WRITE(6,*) 'Please enter a valid choice; Y for Yes, or N for No.'
  END DO

END DO !Main do loop, will play if Y is selected

WRITE(6,*) 'Thank you for using the program.'!Will play on exit

CONTAINS

FUNCTION Rotation(Array,Inputangle)
  REAL, DIMENSION(1:3,1:1):: Rotation, Array
  REAL, DIMENSION(1:3,1:3):: RotArray
  REAL:: Inputangle, Sinput, Cinput

  Cinput = cos(Inputangle)!storing cos and sine of input angle for rotation matrix
  Sinput = sin(Inputangle)
  RotArray(1,1)=Cinput; RotArray(1,2)=-Sinput; RotArray(1,3)=0
  RotArray(2,1)=Sinput; RotArray(2,2)=Cinput;  RotArray(2,3)=0
  RotArray(3,1)=0;      RotArray(3,2)=0;       RotArray(3,3)=1 !Records rotation matrix

  Rotation = Matmul(Rotarray,Array) !Multiplies the rotation matrix with the users array

END FUNCTION

FUNCTION Translation(Array, Xtranslation, Ytranslation)
  REAL, DIMENSION(1:3,1:1):: Translation, Array
  REAL, DIMENSION(1:3,1:3):: TranArray
  REAL::  Xtranslation, Ytranslation

  TranArray(1,1)=1; TranArray(1,2)=0; TranArray(1,3)=Xtranslation
  TranArray(2,1)=0; TranArray(2,2)=1; TranArray(2,3)=Ytranslation
  TranArray(3,1)=0; TranArray(3,2)=0; TranArray(3,3)=1            !Records translation array

  Translation = Matmul(TranArray,Array) !Multiples the translation matrix with users array

END FUNCTION

END PROGRAM


c \BeginDoc
c
c \Name: dsband
c
c \Description:
c
c  This subroutine returns the converged approximations to eigenvalues
c  of A*z = lambda*B*z and (optionally):
c
c      (1) The corresponding approximate eigenvectors;
c
c      (2) An orthonormal (Lanczos) basis for the associated approximate
c          invariant subspace;
c
c      (3) Both.
c
c  Matrices A and B are stored in LAPACK-style band form.
c
c  There is negligible additional cost to obtain eigenvectors.  An orthonormal
c  (Lanczos) basis is always computed.  There is an additional storage cost
c  of n*nev if both are requested (in this case a separate array Z must be
c  supplied).
c
c  The approximate eigenvalues and eigenvectors of  A*z = lambda*B*z
c  are called Ritz values and Ritz vectors respectively.  They are referred
c  to as such in the comments that follow.  The computed orthonormal basis
c  for the invariant subspace corresponding to these Ritz values is referred
c  to as a Lanczos basis.
c
c  dsband can be called with one of the following modes:
c
c  Mode 1:  A*x = lambda*x, A symmetric
c           ===> OP = A  and  B = I.
c
c  Mode 2:  A*x = lambda*M*x, A symmetric, M symmetric positive definite
c           ===> OP = inv[M]*A  and  B = M.
c           ===> (If M can be factored see remark 3 in DSAUPD)
c
c  Mode 3:  K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite
c           ===> OP = (inv[K - sigma*M])*M  and  B = M.
c           ===> Shift-and-Invert mode
c
c  Mode 4:  K*x = lambda*KG*x, K symmetric positive semi-definite,
c           KG symmetric indefinite
c           ===> OP = (inv[K - sigma*KG])*K  and  B = K.
c           ===> Buckling mode
c
c  Mode 5:  A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite
c           ===> OP = inv[A - sigma*M]*[A + sigma*M]  and  B = M.
c           ===> Cayley transformed mode
c
c  The choice of mode must be specified in IPARAM(7) defined below.
c
c \Usage
c   call dsband
c      ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, N, AB, MB, LDA,
c        RFAC, KL, KU, WHICH, BMAT, NEV, TOL, RESID, NCV, V,
c        LDV, IPARAM, WORKD, WORKL, LWORKL, IWORK, INFO )
c
c \Arguments
c
c  RVEC    Logical (INPUT)
c          Specifies whether Ritz vectors corresponding to the Ritz value
c          approximations to the eigenproblem A*z = lambda*B*z are computed.
c
c             RVEC = .FALSE.     Compute Ritz values only.
c
c             RVEC = .TRUE.      Compute the associated Ritz vectors.
c
c  HOWMNY  Character*1  (INPUT)
c          Specifies how many Ritz vectors are wanted and the form of Z
c          the matrix of Ritz vectors. See remark 1 below.
c          = 'A': compute all Ritz vectors;
c          = 'S': compute some of the Ritz vectors, specified
c                 by the logical array SELECT.
c
c  SELECT  Logical array of dimension NCV.  (INPUT)
c          If HOWMNY = 'S', SELECT specifies the Ritz vectors to be
c          computed. To select the Ritz vector corresponding to a
c          Ritz value D(j), SELECT(j) must be set to .TRUE..
c          If HOWMNY = 'A' , SELECT is not referenced.
c
c  D       Double precision array of dimension NEV.  (OUTPUT)
c          On exit, D contains the Ritz value approximations to the
c          eigenvalues of A*z = lambda*B*z. The values are returned
c          in ascending order. If IPARAM(7) = 3,4,5 then D represents
c          the Ritz values of OP computed by dsaupd transformed to
c          those of the original eigensystem A*z = lambda*B*z. If
c          IPARAM(7) = 1,2 then the Ritz values of OP are the same
c          as the those of A*z = lambda*B*z.
c
c  Z       Double precision N by NEV array if HOWMNY = 'A'.  (OUTPUT)
c          On exit, Z contains the B-orthonormal Ritz vectors of the
c          eigensystem A*z = lambda*B*z corresponding to the Ritz
c          value approximations.
c
c          If  RVEC = .FALSE. then Z is not referenced.
c          NOTE: The array Z may be set equal to first NEV columns of the
c          Lanczos basis array V computed by DSAUPD.
c
c  LDZ     Integer.  (INPUT)
c          The leading dimension of the array Z.  If Ritz vectors are
c          desired, then  LDZ .ge.  max( 1, N ).  In any case,  LDZ .ge. 1.
c
c  SIGMA   Double precision  (INPUT)
c          If IPARAM(7) = 3,4,5 represents the shift. Not referenced if
c          IPARAM(7) = 1 or 2.
c
c  N       Integer.  (INPUT)
c          Dimension of the eigenproblem.
c
c  AB      Double precision array of dimension LDA by N. (INPUT)
c          The matrix A in band storage, in rows KL+1 to
c          2*KL+KU+1; rows 1 to KL of the array need not be set.
c          The j-th column of A is stored in the j-th column of the
c          array AB as follows:
c          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
c
c  MB      Double precision array of dimension LDA by N. (INPUT)
c          The matrix M in band storage, in rows KL+1 to
c          2*KL+KU+1; rows 1 to KL of the array need not be set.
c          The j-th column of M is stored in the j-th column of the
c          array AB as follows:
c          MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
c          Not referenced if IPARAM(7) = 1
c
c  LDA     Integer. (INPUT)
c          Leading dimension of AB, MB, RFAC.
c
c  RFAC    Double precision array of LDA by N. (WORKSPACE/OUTPUT)
c          RFAC is used to store the LU factors of MB when IPARAM(7) = 2
c          is invoked.  It is used to store the LU factors of
c          (A-sigma*M) when IPARAM(7) = 3,4,5 is invoked.
c          It is not referenced when IPARAM(7) = 1.
c
c  KL      Integer. (INPUT)
c          Max(number of subdiagonals of A, number of subdiagonals of M)
c
c  KU      Integer. (OUTPUT)
c          Max(number of superdiagonals of A, number of superdiagonals of M)
c
c  WHICH   Character*2.  (INPUT)
c          When IPARAM(7)= 1 or 2,  WHICH can be set to any one of
c          the following.
c
c            'LM' -> want the NEV eigenvalues of largest magnitude.
c            'SM' -> want the NEV eigenvalues of smallest magnitude.
c            'LA' -> want the NEV eigenvalues of largest REAL part.
c            'SA' -> want the NEV eigenvalues of smallest REAL part.
c            'BE' -> Compute NEV eigenvalues, half from each end of the
c                    spectrum.  When NEV is odd, compute one more from
c                    the high end than from the low end.
c
c          When IPARAM(7) = 3, 4, or 5,  WHICH should be set to 'LM' only.
c
c  BMAT    Character*1.  (INPUT)
c          BMAT specifies the type of the matrix B that defines the
c          semi-inner product for the operator OP.
c          BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x
c          BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x

c  NEV     Integer. (INPUT)
c          Number of eigenvalues of OP to be computed.
c
c  TOL     Double precision scalar.  (INPUT)
c          Stopping criterion: the relative accuracy of the Ritz value
c          is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)).
c          If TOL .LE. 0. is passed a default is set:
c          DEFAULT = DLAMCH('EPS')  (machine precision as computed
c                    by the LAPACK auxiliary subroutine DLAMCH).
c
c  RESID   Double precision array of length N.  (INPUT/OUTPUT)
c          On INPUT:
c          If INFO .EQ. 0, a random initial residual vector is used.
c          If INFO .NE. 0, RESID contains the initial residual vector,
c                          possibly from a previous run.
c          On OUTPUT:
c          RESID contains the final residual vector.
c
c  NCV     Integer.  (INPUT)
c          Number of columns of the matrix V (less than or equal to N).
c          Represents the dimension of the Lanczos basis constructed
c          by dsaupd for OP.
c
c  V       Double precision array N by NCV.  (OUTPUT)
c          Upon INPUT: the NCV columns of V contain the Lanczos basis
c                      vectors as constructed by dsaupd for OP.
c          Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns
c                       represent the Ritz vectors that span the desired
c                       invariant subspace.
c          NOTE: The array Z may be set equal to first NEV columns of the
c          Lanczos basis vector array V computed by dsaupd. In this case
c          if RVEC=.TRUE., the first NCONV=IPARAM(5) columns of V contain
c          the desired Ritz vectors.
c
c  LDV     Integer.  (INPUT)
c          Leading dimension of V exactly as declared in the calling
c          program.
c
c  IPARAM  Integer array of length 11.  (INPUT/OUTPUT)
c          IPARAM(1) = ISHIFT:
c          The shifts selected at each iteration are used to restart
c          the Arnoldi iteration in an implicit fashion.
c          It is set to 1 in this subroutine.  The user do not need
c          to set this parameter.
c          ------------------------------------------------------------
c          ISHIFT = 1: exact shifts with respect to the reduced
c                      tridiagonal matrix T.  This is equivalent to
c                      restarting the iteration with a starting vector
c                      that is a linear combination of Ritz vectors
c                      associated with the "wanted" Ritz values.
c          -------------------------------------------------------------
c
c          IPARAM(2) = No longer referenced.
c
c          IPARAM(3) = MXITER
c          On INPUT:  max number of Arnoldi update iterations allowed.
c          On OUTPUT: actual number of Arnoldi update iterations taken.
c
c          IPARAM(4) = NB: blocksize to be used in the recurrence.
c          The code currently works only for NB = 1.
c
c          IPARAM(5) = NCONV: number of "converged" eigenvalues.
c          This represents the number of Ritz values that satisfy
c          the convergence criterion.
c
c          IPARAM(6) = IUPD
c          No longer referenced. Implicit restarting is ALWAYS used.
c
c          IPARAM(7) = MODE
c          On INPUT determines what type of eigenproblem is being solved.
c          Must be 1,2,3,4,5; See under \Description of dsband for the
c          five modes available.
c
c          IPARAM(8) = NP
c          Not referenced.
c
c          IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO,
c          OUTPUT: NUMOP  = total number of OP*x operations,
c                  NUMOPB = total number of B*x operations if BMAT='G',
c                  NUMREO = total number of steps of re-orthogonalization.
c
c WORKD    Double precision work array of length at least 3*n. (WORKSPACE)
c
c WORKL    Double precision work array of length LWORKL.  (WORKSPACE)
c
c LWORKL   Integer.  (INPUT)
c          LWORKL must be at least NCV**2 + 8*NCV.
c
c IWORK    Integer array of dimension at least N. (WORKSPACE)
c          Used when IPARAM(7)=2,3,4,5 to store the pivot information in the
c          factorization of M or (A-SIGMA*M).
c
c INFO     Integer.  (INPUT/OUTPUT)
c          Error flag on output.
c          =  0: Normal exit.
c          =  1: Maximum number of iterations taken.
c                All possible eigenvalues of OP has been found. IPARAM(5)
c                returns the number of wanted converged Ritz values.
c          =  3: No shifts could be applied during a cycle of the
c                Implicitly restarted Arnoldi iteration. One possibility
c                is to increase the size of NCV relative to NEV.
c                See remark 4 in DSAUPD.
c
c          = -1: N must be positive.
c          = -2: NEV must be positive.
c          = -3: NCV-NEV >= 2 and less than or equal to N.
c          = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI'
c          = -6: BMAT must be one of 'I' or 'G'.
c          = -7: Length of private work WORKL array is not sufficient.
c          = -8: Error return from trid. eigenvalue calculation;
c                Informational error from LAPACK routine dsteqr.
c          = -9: Starting vector is zero.
c          = -10: IPARAM(7) must be 1,2,3,4,5.
c          = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible.
c          = -12: NEV and WHICH = 'BE' are incompatible.
c          = -13: HOWMNY must be one of 'A' or 'P'
c          = -14: DSAUPD did not find any eigenvalues to sufficient
c                 accuracy.
c          = -9999: Could not build an Arnoldi factorization.
c                   IPARAM(5) returns the size of the current
c                   Arnoldi factorization.
c
c \EndDoc
c
c------------------------------------------------------------------------
c
c\BeginLib
c
c\References:
c  1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c     a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c     pp 357-385.
c
c  2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c     Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ,
c     May 1995.
c
c\Routines called:
c     dsaupd  ARPACK reverse communication interface routine.
c     dseupd  ARPACK routine that returns Ritz values and (optionally)
c             Ritz vectors.
c     dgbtrf  LAPACK band matrix factorization routine.
c     dgbtrs  LAPACK band linear system solve routine.
c     dlacpy  LAPACK matrix copy routine.
c     dlapy2  LAPACK routine to compute sqrt(x**2+y**2) carefully.
c     dcopy   Level 1 BLAS that copies one vector to another.
c     ddot    Level 1 BLAS that computes the dot product of two vectors.
c     dnrm2   Level 1 BLAS that computes the norm of a vector.
c     dgbmv   Level 2 BLAS that computes the band matrix vector product.
c
c\Remarks
c  1. The converged Ritz values are always returned in increasing
c     (algebraic) order.
c
c  2. Currently only HOWMNY = 'A' is implemented. It is included at this
c     stage for the user who wants to incorporate it.
c
c\Author
c     Danny Sorensen
c     Richard Lehoucq
c     Chao Yang
c     Dept. of Computational &
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\SCCS Information: @(#)
c FILE: sband.F   SID: 2.3   DATE OF SID: 10/17/00   RELEASE: 2
c
c\EndLib
c
c---------------------------------------------------------------------
c
      subroutine dsband( rvec, howmny, select, d, z, ldz, sigma,
     &           n, ab, mb, lda, rfac, kl, ku, which, bmat, nev,
     &           tol, resid, ncv, v, ldv, iparam, workd, workl,
     &           lworkl, iwork, info)
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c
      character        which*2, bmat, howmny
      integer          n, lda, kl, ku, nev, ncv, ldv,
     &                 ldz, lworkl, info
      Double precision
     &                 tol, sigma
      logical          rvec
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      integer          iparam(*), iwork(*)
      logical          select(*)
      Double precision
     &                 d(*), resid(*), v(ldv,*), z(ldz,*),
     &                 ab(lda,*), mb(lda,*), rfac(lda,*),
     &                 workd(*), workl(*)
c
c     %--------------%
c     | Local Arrays |
c     %--------------%
c
      integer          ipntr(14)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      integer          ido, i, j, type, imid, itop, ibot, ierr
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Double precision
     &                  one, zero
      parameter        (one = 1.0, zero = 0.0)
c
c
c     %-----------------------------%
c     | LAPACK & BLAS routines used |
c     %-----------------------------%
c
      Double precision
     &                 ddot, dnrm2, dlapy2
      external         ddot, dcopy, dgbmv, dgbtrf,
     &                 dgbtrs, dnrm2, dlapy2, dlacpy
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
c     %----------------------------------------------------------------%
c     | Set type of the problem to be solved. Check consistency        |
c     | between BMAT and IPARAM(7).                                    |
c     | type = 1 --> Solving standard problem in regular mode.         |
c     | type = 2 --> Solving standard problem in shift-invert mode.    |
c     | type = 3 --> Solving generalized problem in regular mode.      |
c     | type = 4 --> Solving generalized problem in shift-invert mode. |
c     | type = 5 --> Solving generalized problem in Buckling mode.     |
c     | type = 6 --> Solving generalized problem in Cayley mode.       |
c     %----------------------------------------------------------------%
c
      if ( iparam(7) .eq. 1 ) then
         type = 1
      else if ( iparam(7) .eq. 3 .and. bmat .eq. 'I') then
         type = 2
      else if ( iparam(7) .eq. 2 ) then
         type = 3
      else if ( iparam(7) .eq. 3 .and. bmat .eq. 'G') then
         type = 4
      else if ( iparam(7) .eq. 4 ) then
         type = 5
      else if ( iparam(7) .eq. 5 ) then
         type = 6
      else
         print*, ' '
         print*, 'BMAT is inconsistent with IPARAM(7).'
         print*, ' '
         go to 9000
      end if
c
c     %------------------------%
c     | Initialize the reverse |
c     | communication flag.    |
c     %------------------------%
c
      ido   = 0
c
c     %----------------%
c     | Exact shift is |
c     | used.          |
c     %----------------%
c
      iparam(1) = 1
c
c     %-----------------------------------%
c     | Both matrices A and M are stored  |
c     | between rows itop and ibot.  Imid |
c     | is the index of the row that      |
c     | stores the diagonal elements.     |
c     %-----------------------------------%
c
      itop = kl + 1
      imid = kl + ku + 1
      ibot = 2*kl + ku + 1
c
      if ( type .eq. 2 .or. type .eq. 6 .and. bmat .eq. 'I' ) then
c
c         %----------------------------------%
c         | Solving a standard eigenvalue    |
c         | problem in shift-invert or       |
c         | Cayley mode. Factor (A-sigma*I). |
c         %----------------------------------%
c
          call dlacpy ('A', ibot, n, ab, lda, rfac, lda )
          do 10 j = 1, n
             rfac(imid,j) =  ab(imid,j) - sigma
  10      continue
          call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr )
          if (ierr .ne. 0) then
             print*, ' '
             print*, ' _SBAND: Error with _gbtrf. '
             print*, ' '
             go to  9000
          end if
c
      else if ( type .eq. 3 ) then
c
c        %----------------------------------------------%
c        | Solving generalized eigenvalue problem in    |
c        | regular mode. Copy M to rfac and Call LAPACK |
c        | routine dgbtrf to factor M.                  |
c        %----------------------------------------------%
c
         call dlacpy ('A', ibot, n, mb, lda, rfac, lda )
         call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr)
         if (ierr .ne. 0) then
             print*, ' '
             print*,'_SBAND:  Error with _gbtrf.'
             print*, ' '
             go to 9000
         end if
c
      else if ( type .eq. 4 .or. type .eq. 5 .or. type .eq. 6
     &         .and. bmat .eq. 'G' ) then
c
c        %-------------------------------------------%
c        | Solving generalized eigenvalue problem in |
c        | shift-invert, Buckling, or Cayley mode.   |
c        %-------------------------------------------%
c
c        %-------------------------------------%
c        | Construct and factor (A - sigma*M). |
c        %-------------------------------------%
c
         do 60 j = 1,n
            do 50 i = itop, ibot
               rfac(i,j) = ab(i,j) - sigma*mb(i,j)
  50        continue
  60     continue
c
         call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr)
         if ( ierr .ne. 0 )  then
             print*, ' '
             print*, '_SBAND: Error with _gbtrf.'
             print*, ' '
             go to 9000
         end if
c
      end if
c
c     %--------------------------------------------%
c     |  M A I N   L O O P (reverse communication) |
c     %--------------------------------------------%
c
  90  continue
c
      call dsaupd ( ido, bmat, n, which, nev, tol, resid, ncv,
     &              v, ldv, iparam, ipntr, workd, workl, lworkl,
     &              info )
c
      if (ido .eq. -1) then
c
         if ( type .eq. 1) then
c
c           %----------------------------%
c           | Perform  y <--- OP*x = A*x |
c           %----------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
c
         else if ( type .eq. 2 ) then
c
c           %----------------------------------%
c           |             Perform              |
c           | y <--- OP*x = inv[A-sigma*I]*x   |
c           | to force the starting vector     |
c           | into the range of OP.            |
c           %----------------------------------%
c
            call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1)
            call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                    iwork, workd(ipntr(2)), n, ierr)
            if ( ierr .ne. 0 ) then
               print*, ' '
               print*, ' _SBAND: Error with _bgtrs. '
               print*, ' '
               go to 9000
            end if
c
         else if ( type .eq. 3 ) then
c
c           %-----------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x |
c           | to force the starting vector into |
c           | the range of OP.                  |
c           %-----------------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                  lda, workd(ipntr(1)), 1, zero,
     &                  workd(ipntr(2)), 1)
            call dcopy(n, workd(ipntr(2)), 1, workd(ipntr(1)), 1)
            call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                    iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_SBAND: Error with sbgtrs.'
               print*, ' '
               go to 9000
            end if
c
         else if ( type .eq. 4 ) then
c
c           %-----------------------------------------%
c           | Perform y <-- OP*x                      |
c           |           = inv[A-SIGMA*M]*M            |
c           | to force the starting vector into the   |
c           | range of OP.                            |
c           %-----------------------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
            call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                   iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_SBAND: Error with _gbtrs.'
               print*, ' '
               go to 9000
            end if
c
         else if ( type .eq. 5) then
c
c           %---------------------------------------%
c           | Perform y <-- OP*x                    |
c           |    = inv[A-SIGMA*M]*A                 |
c           | to force the starting vector into the |
c           | range of OP.                          |
c           %---------------------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
            call dgbtrs('Notranspose', n, kl, ku, 1, rfac, lda,
     &                   iwork, workd(ipntr(2)), n, ierr)
c
            if ( ierr .ne. 0 ) then
               print*, ' '
               print*, ' _SBAND: Error with _gbtrs. '
               print*, ' '
               go to 9000
            end if
c
         else if ( type .eq. 6 ) then
c
c           %---------------------------------------%
c           | Perform y <-- OP*x                    |
c           | = (inv[A-SIGMA*M])*(A+SIGMA*M)*x      |
c           | to force the starting vector into the |
c           | range of OP.                          |
c           %---------------------------------------%
c
            if ( bmat .eq. 'G' ) then
               call dgbmv('Notranspose', n, n, kl, ku, one,
     &                    ab(itop,1), lda, workd(ipntr(1)), 1,
     &                    zero, workd(ipntr(2)), 1)
               call dgbmv('Notranspose', n, n, kl, ku, sigma,
     &                    mb(itop,1), lda, workd(ipntr(1)), 1,
     &                    one, workd(ipntr(2)), 1)
            else
               call dcopy(n, workd(ipntr(1)), 1, workd(ipntr(2)), 1)
               call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                    lda, workd(ipntr(1)), 1, sigma,
     &                    workd(ipntr(2)), 1)
            end if
c
            call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                   iwork, workd(ipntr(2)), n, ierr)
c
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_SBAND: Error with _gbtrs.'
               print*, ' '
               go to 9000
            end if
c
         end if
c
      else if (ido .eq. 1) then
c
         if ( type .eq. 1) then
c
c           %----------------------------%
c           | Perform  y <--- OP*x = A*x |
c           %----------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                 lda, workd(ipntr(1)), 1, zero,
     &                 workd(ipntr(2)), 1)
c
         else if ( type .eq. 2) then
c
c              %----------------------------------%
c              |             Perform              |
c              | y <--- OP*x = inv[A-sigma*I]*x.  |
c              %----------------------------------%
c
               call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1)
               call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                       iwork, workd(ipntr(2)), n, ierr)
               if ( ierr .ne. 0 ) then
                  print*, ' '
                  print*, '_SBAND: Error with _gbtrs.'
                  print*, ' '
                  go to 9000
               end if
c
         else if ( type .eq. 3 ) then
c
c           %-----------------------------------%
c           | Perform  y <--- OP*x = inv[M]*A*x |
c           %-----------------------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                  lda, workd(ipntr(1)), 1, zero,
     &                  workd(ipntr(2)), 1)
            call dcopy(n, workd(ipntr(2)), 1, workd(ipntr(1)), 1)
            call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                    iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_SBAND: error with _bgtrs.'
               print*, ' '
               go to 9000
            end if
c
         else if ( type .eq. 4 ) then
c
c           %-------------------------------------%
c           | Perform y <-- inv(A-sigma*M)*(M*x). |
c           | (M*x) has been computed and stored  |
c           | in workd(ipntr(3)).                 |
c           %-------------------------------------%
c
            call dcopy(n, workd(ipntr(3)), 1, workd(ipntr(2)), 1)
            call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda,
     &                    iwork, workd(ipntr(2)), n, ierr)
            if (ierr .ne. 0) then
               print*, ' '
               print*, '_SBAND: Error with _gbtrs.'
               print*, ' '
               go to 9000
            end if
c
         else if ( type .eq. 5 ) then
c
c           %-------------------------------%
c           | Perform y <-- OP*x            |
c           |    = inv[A-SIGMA*M]*A*x       |
c           | B*x = A*x has been computed   |
c           | and saved in workd(ipntr(3)). |
c           %-------------------------------%
c
            call dcopy (n, workd(ipntr(3)), 1, workd(ipntr(2)), 1)
            call dgbtrs('Notranspose', n, kl, ku, 1, rfac, lda,
     &                   iwork, workd(ipntr(2)), n, ierr)
            if ( ierr .ne. 0 ) then
               print*, ' '
               print*, ' _SBAND: Error with _gbtrs. '
               print*, ' '
               go to 9000
            end if
c
         else if ( type .eq. 6) then
c
c           %---------------------------------%
c           | Perform y <-- OP*x              |
c           | = inv[A-SIGMA*M]*(A+SIGMA*M)*x. |
c           | (M*x) has been saved in         |
c           | workd(ipntr(3)).                |
c           %---------------------------------%
c
            if ( bmat .eq. 'G' ) then
               call dgbmv('Notranspose', n, n, kl, ku, one,
     &                    ab(itop,1), lda, workd(ipntr(1)), 1,
     &                    zero, workd(ipntr(2)), 1)
               call daxpy( n, sigma, workd(ipntr(3)), 1,
     &                    workd(ipntr(2)), 1 )
            else
               call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1)
               call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1),
     &                    lda, workd(ipntr(1)), 1, sigma,
     &                    workd(ipntr(2)), 1)
            end if
            call dgbtrs('Notranspose', n, kl, ku, 1, rfac, lda,
     &                   iwork, workd(ipntr(2)), n, ierr)
c
         end if
c
      else if (ido .eq. 2) then
c
c        %----------------------------------%
c        |        Perform y <-- B*x         |
c        | Note when Buckling mode is used, |
c        | B = A, otherwise B=M.            |
c        %----------------------------------%
c
         if (type .eq. 5) then
c
c           %---------------------%
c           | Buckling Mode, B=A. |
c           %---------------------%
c
            call dgbmv('Notranspose', n, n, kl, ku, one,
     &                ab(itop,1), lda, workd(ipntr(1)), 1,
     &                zero, workd(ipntr(2)), 1)
         else

            call dgbmv('Notranspose', n, n, kl, ku, one,
     &                mb(itop,1), lda, workd(ipntr(1)), 1,
     &                zero, workd(ipntr(2)), 1)
         end if
c
      else
c
c        %-----------------------------------------%
c        | Either we have convergence, or there is |
c        | error.                                  |
c        %-----------------------------------------%
c
         if ( info .lt. 0) then
c
c           %--------------------------%
c           | Error message, check the |
c           | documentation in DSAUPD  |
c           %--------------------------%
c
            print *, ' '
            print *, ' Error with _saupd info = ',info
            print *, ' Check the documentation of _saupd '
            print *, ' '
            go to 9000
c
         else
c
            if ( info .eq. 1) then
               print *, ' '
               print *, ' Maximum number of iterations reached.'
               print *, ' '
            else if ( info .eq. 3) then
               print *, ' '
               print *, ' No shifts could be applied during implicit',
     &                  ' Arnoldi update, try increasing NCV.'
               print *, ' '
            end if
c
            if (iparam(5) .gt. 0) then
c
               call dseupd ( rvec, 'A', select, d, z, ldz, sigma,
     &                  bmat, n, which, nev, tol, resid, ncv, v, ldv,
     &                  iparam, ipntr, workd, workl, lworkl, info )
c
               if ( info .ne. 0) then
c
c                 %------------------------------------%
c                 | Check the documentation of dneupd. |
c                 %------------------------------------%
c
                  print *, ' '
                  print *, ' Error with _neupd = ', info
                  print *, ' Check the documentation of _neupd '
                  print *, ' '
                  go to 9000
c
               end if
c
            end if
c
         end if
c
         go to 9000
c
      end if
c
c     %----------------------------------------%
c     | L O O P  B A C K to call DSAUPD again. |
c     %----------------------------------------%
c
      go to 90
c
 9000 continue
c
      end