program preprocessor4
implicit none
#define XPOW(a) ((a)**2)
#define X123(a,b) ((a)+XPOW(b))
integer :: x, y
x = (2+3)*5
print *, x, X123(1,2)
end program


      program AOC

      integer :: ios, u = 42, kept, ones, result_o2 = 0, result_co2 = 0
      integer :: row_o2, row_co2

      character(12), dimension(1000) :: report
      character(1) :: keeping

      integer, dimension(1000) :: keep

      open(unit=u, file='day_3.txt', iostat=ios)

      if ( ios /= 0 ) stop "ABNORMAL TERMINATE"

      do i = 1, 1000
         read(u, *, iostat=ios) report(i)
         if (ios /= 0) exit
         keep(i) = 1
      end do

C     Part 1: O2 Rating

      do i = 1, 12

         kept = 0
         ones = 0

         do j = 1, 1000
            if (keep(j) == 1) then
               kept = kept + 1
               if (report(j)(i:i) == "1") ones = ones + 1
            end if
         end do

         if (ones >= kept / 2) then
            keeping = "1"
         else
            keeping = "0"
         end if

         kept = 0

         do j = 1, 1000
            if (report(j)(i:i) /= keeping) keep(j) = 0
            if (keep(j) == 1) then
               kept = kept + 1
               row_o2 = j
            end if
         end do

         if (kept == 1) exit

      end do

      do i = 1, 12
         if (report(row_o2)(i:i) == "1") then
            result_o2 = result_o2 + ISHFT(1, 12 - i)
         end if
      end do

C     Part 2: CO2 Rating

      do i = 1, 1000
         keep(i) = 1
      end do

      do i = 1, 12

         kept = 0
         zeroes = 0

         do j = 1, 1000
            if (keep(j) == 1) then
               kept = kept + 1
               if (report(j)(i:i) == "0") then
                  zeroes = zeroes + 1
               end if
            end if
         end do

         if (zeroes <= kept / 2) then
            keeping = "0"
         else
            keeping = "1"
         end if

         kept = 0

         do j = 1, 1000
            if (report(j)(i:i) /= keeping) keep(j) = 0
            if (keep(j) == 1) then
               kept = kept + 1
               row_co2 = j
            end if
         end do

         if (kept == 1) exit

      end do

      do i = 1, 12
         if (report(row_co2)(i:i) == "1") then
            result_co2 = result_co2 + ISHFT(1, 12 - i)
         end if
      end do

      print*, "Overall rating", result_o2 * result_co2

      close(u)

      end program AOC


program ch1202
    ! The abs Generic Function
    implicit none

    complex :: c = cmplx(1.,1.)
    real :: r = 10.9
    integer :: i = -27

    print *, abs(c)
    print *, abs(r)
    print *, abs(i)
end program


!! R627 alloc-opt
!    or SOURCE = source-expr
!   - F2008 addition
!   - SOURCE= in ALLOCATE statement can give array bounds as well as the value

program alloc_opt
  real :: old(2,4)
  real, allocatable :: new(:,:)

  old(1,1:4) = [11,12,13,14]
  old(2,1:4) = [21,22,23,24]

  ALLOCATE (new, SOURCE=old(1:2,1:3))

end program


submodule(euler_interface_m) euler_prob_0058_m
    implicit none

contains

    module character(len=20) function euler0058()
        write (euler0058, "(i20)") ans()
    end function euler0058

    integer(int64) function ans()
        use euler_primes_m, only: is_prime
        implicit none

        integer(int64) :: n, k, i, arr(4)

        k = 0
        n = 2
        main_loop: do
            call diagonal_nums(n, arr)
            do i = 1, 3
                if (is_prime(arr(i))) k = k + 1
            end do

            associate (p_nums => real(k), tot_nums => real((n - 1)*4 + 1))
                if (p_nums/tot_nums < 0.1_sp) exit main_loop
            end associate
            n = n + 1
        end do main_loop

        ans = side_len(n)
    end function ans

    subroutine diagonal_nums(n, arr)
        integer(int64), intent(in) :: n
        integer(int64), intent(out) :: arr(:)
        integer(int64) :: bottom_left, diff

        bottom_left = (n*2 - 1)**2
        diff = (n - 1)*2
        arr(1) = bottom_left - 3*diff
        arr(2) = bottom_left - 2*diff
        arr(3) = bottom_left - diff
        arr(4) = bottom_left
    end subroutine diagonal_nums

    integer(int64) function side_len(n)
        integer(int64), intent(in) :: n

        side_len = n*2_int64 - 1_int64
    end function side_len

end submodule euler_prob_0058_m


module module_globals
  implicit none

  complex(8),parameter :: one=cmplx(1.d0,0.d0,kind(1.d0))
  complex(8),parameter :: zero=cmplx(0.d0,0.d0,kind(1.d0))
  complex(8),parameter :: ione=cmplx(0.d0,1.d0,kind(1.d0))
  real(8),parameter :: pi=acos(-1.d0)
  integer,parameter :: maxs=10
  integer,parameter :: ntaylor=maxs*2
  integer,parameter :: maxngt=70

end module module_globals


      SUBROUTINE SB10DD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB,
     $                   C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK,
     $                   DK, LDDK, X, LDX, Z, LDZ, RCOND, TOL, IWORK,
     $                   DWORK, LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrices of an H-infinity (sub)optimal n-state
C     controller
C
C                           | AK | BK |
C                       K = |----|----|,
C                           | CK | DK |
C
C     for the discrete-time system
C
C                   | A  | B1  B2  |   | A | B |
C               P = |----|---------| = |---|---|
C                   | C1 | D11 D12 |   | C | D |
C                   | C2 | D21 D22 |
C
C     and for a given value of gamma, where B2 has as column size the
C     number of control inputs (NCON) and C2 has as row size the number
C     of measurements (NMEAS) being provided to the controller.
C
C     It is assumed that
C
C     (A1) (A,B2) is stabilizable and (C2,A) is detectable,
C
C     (A2) D12 is full column rank and D21 is full row rank,
C
C               j*Theta
C     (A3) | A-e       *I  B2  | has full column rank for all
C          |    C1         D12 |
C
C          0 <= Theta < 2*Pi ,
C
C               j*Theta
C     (A4) | A-e       *I  B1  |  has full row rank for all
C          |    C2         D21 |
C
C          0 <= Theta < 2*Pi .
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     NP      (input) INTEGER
C             The row size of the matrix C.  NP >= 0.
C
C     NCON    (input) INTEGER
C             The number of control inputs (M2).  M >= NCON >= 0,
C             NP-NMEAS >= NCON.
C
C     NMEAS   (input) INTEGER
C             The number of measurements (NP2).  NP >= NMEAS >= 0,
C             M-NCON >= NMEAS.
C
C     GAMMA   (input) DOUBLE PRECISION
C             The value of gamma. It is assumed that gamma is
C             sufficiently large so that the controller is admissible.
C             GAMMA > 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             system state matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading NP-by-N part of this array must contain the
C             system output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,NP).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading NP-by-M part of this array must contain the
C             system input/output matrix D.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= max(1,NP).
C
C     AK      (output) DOUBLE PRECISION array, dimension (LDAK,N)
C             The leading N-by-N part of this array contains the
C             controller state matrix AK.
C
C     LDAK    INTEGER
C             The leading dimension of the array AK.  LDAK >= max(1,N).
C
C     BK      (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS)
C             The leading N-by-NMEAS part of this array contains the
C             controller input matrix BK.
C
C     LDBK    INTEGER
C             The leading dimension of the array BK.  LDBK >= max(1,N).
C
C     CK      (output) DOUBLE PRECISION array, dimension (LDCK,N)
C             The leading NCON-by-N part of this array contains the
C             controller output matrix CK.
C
C     LDCK    INTEGER
C             The leading dimension of the array CK.
C             LDCK >= max(1,NCON).
C
C     DK      (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS)
C             The leading NCON-by-NMEAS part of this array contains the
C             controller input/output matrix DK.
C
C     LDDK    INTEGER
C             The leading dimension of the array DK.
C             LDDK >= max(1,NCON).
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,N)
C             The leading N-by-N part of this array contains the matrix
C             X, solution of the X-Riccati equation.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= max(1,N).
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
C             The leading N-by-N part of this array contains the matrix
C             Z, solution of the Z-Riccati equation.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= max(1,N).
C
C     RCOND   (output) DOUBLE PRECISION array, dimension (8)
C             RCOND contains estimates of the reciprocal condition
C             numbers of the matrices which are to be inverted and
C             estimates of the reciprocal condition numbers of the
C             Riccati equations which have to be solved during the
C             computation of the controller. (See the description of
C             the algorithm in [2].)
C             RCOND(1) contains the reciprocal condition number of the
C                      matrix R3;
C             RCOND(2) contains the reciprocal condition number of the
C                      matrix R1 - R2'*inv(R3)*R2;
C             RCOND(3) contains the reciprocal condition number of the
C                      matrix V21;
C             RCOND(4) contains the reciprocal condition number of the
C                      matrix St3;
C             RCOND(5) contains the reciprocal condition number of the
C                      matrix V12;
C             RCOND(6) contains the reciprocal condition number of the
C                      matrix Im2 + DKHAT*D22
C             RCOND(7) contains the reciprocal condition number of the
C                      X-Riccati equation;
C             RCOND(8) contains the reciprocal condition number of the
C                      Z-Riccati equation.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             Tolerance used in neglecting the small singular values
C             in rank determination. If TOL <= 0, then a default value
C             equal to 1000*EPS is used, where EPS is the relative
C             machine precision.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (max(2*max(M2,N),M,M2+NP2,N*N))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal
C             LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= max(LW1,LW2,LW3,LW4), where
C             LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2));
C             LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2));
C             LW3 = 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + 6*N +
C                   max(14*N+23,16*N,2*N+M,3*M);
C             LW4 = 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + 6*N +
C                   N*(M+NP2) + max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2));
C             For good performance, LDWORK must generally be larger.
C             Denoting Q = max(M1,M2,NP1,NP2), an upper bound is
C             max((N+Q)*(N+Q+6),13*N*N + M*M + 2*Q*Q + N*(M+Q) +
C                 max(M*(M+7*N),2*Q*(8*N+M+2*Q)) + 6*N +
C                 max(14*N+23,16*N,2*N+max(M,2*Q),3*max(M,2*Q)).
C
C     BWORK   LOGICAL array, dimension (2*N)
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                                      j*Theta
C             = 1:  if the matrix | A-e       *I  B2  | had not full
C                                 |      C1       D12 |
C                   column rank;
C                                      j*Theta
C             = 2:  if the matrix | A-e       *I  B1  | had not full
C                                 |      C2       D21 |
C                   row rank;
C             = 3:  if the matrix D12 had not full column rank;
C             = 4:  if the matrix D21 had not full row rank;
C             = 5:  if the controller is not admissible (too small value
C                   of gamma);
C             = 6:  if the X-Riccati equation was not solved
C                   successfully (the controller is not admissible or
C                   there are numerical difficulties);
C             = 7:  if the Z-Riccati equation was not solved
C                   successfully (the controller is not admissible or
C                   there are numerical difficulties);
C             = 8:  if the matrix Im2 + DKHAT*D22 is singular.
C             = 9:  if the singular value decomposition (SVD) algorithm
C                   did not converge (when computing the SVD of one of
C                   the matrices |A   B2 |, |A   B1 |, D12 or D21).
C                                |C1  D12|  |C2  D21|
C
C     METHOD
C
C     The routine implements the method presented in [1].
C
C     REFERENCES
C
C     [1] Green, M. and Limebeer, D.J.N.
C         Linear Robust Control.
C         Prentice-Hall, Englewood Cliffs, NJ, 1995.
C
C     [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M.
C         Fortran 77 routines for Hinf and H2 design of linear
C         discrete-time control systems.
C         Report 99-8, Department of Engineering, Leicester University,
C         April 1999.
C
C     NUMERICAL ASPECTS
C
C     With approaching the minimum value of gamma some of the matrices
C     which are to be inverted tend to become ill-conditioned and
C     the X- or Z-Riccati equation may also become ill-conditioned
C     which may deteriorate the accuracy of the result. (The
C     corresponding reciprocal condition numbers are given in
C     the output array RCOND.)
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999.
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2000.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, discrete-time H-infinity optimal
C     control, robust control.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, THOUSN
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
     $                     THOUSN = 1.0D+3 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD,
     $                   LDDK, LDWORK, LDX, LDZ, M, N, NCON, NMEAS, NP
      DOUBLE PRECISION   GAMMA, TOL
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), AK( LDAK, * ), B( LDB, * ),
     $                   BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ),
     $                   D( LDD, * ), DK( LDDK, * ), DWORK( * ),
     $                   RCOND( * ), X( LDX, * ), Z( LDZ, * )
      LOGICAL            BWORK( * )
C     ..
C     .. Local Scalars ..
      INTEGER            INFO2, IR2, IR3, IS2, IS3, IWB, IWC, IWD, IWG,
     $                   IWH, IWI, IWL, IWQ, IWR, IWRK, IWS, IWT, IWU,
     $                   IWV, IWW, J, LWAMAX, M1, M2, MINWRK, NP1, NP2
      DOUBLE PRECISION   ANORM, FERR, RCOND2, SEPD, TOLL
C
C     .. External Functions
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANSY
      EXTERNAL           DLAMCH, DLANGE, DLANSY
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGECON, DGEMM, DGESVD, DGETRF, DGETRS, DLACPY,
     $                   DLASET, DPOCON, DPOTRF, DSCAL, DSWAP, DSYRK,
     $                   DSYTRF, DSYTRS, DTRCON, DTRSM, MA02AD, MB01RU,
     $                   MB01RX, SB02OD, SB02SD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      M1 = M - NCON
      M2 = NCON
      NP1 = NP - NMEAS
      NP2 = NMEAS
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( NP.LT.0 ) THEN
         INFO = -3
      ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN
         INFO = -4
      ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN
         INFO = -5
      ELSE IF( GAMMA.LE.ZERO ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN
         INFO = -12
      ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN
         INFO = -14
      ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN
         INFO = -16
      ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN
         INFO = -18
      ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN
         INFO = -20
      ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN
         INFO = -22
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -24
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -26
      ELSE
C
C        Compute workspace.
C
         IWB = ( N + NP1 + 1 )*( N + M2 ) +
     $         MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) )
         IWC = ( N + NP2 )*( N + M1 + 1 ) +
     $         MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) )
         IWD = 13*N*N + 2*M*M + N*( 8*M + NP2 ) + M1*( M2 + NP2 ) +
     $         6*N + MAX( 14*N + 23, 16*N, 2*N + M, 3*M )
         IWG = 13*N*N + M*M + ( 8*N + M + M2 + 2*NP2 )*( M2 + NP2 ) +
     $         6*N + N*( M + NP2 ) +
     $         MAX( 14*N + 23, 16*N, 2*N + M2 + NP2, 3*( M2 + NP2 ) )
         MINWRK = MAX( IWB, IWC, IWD, IWG )
         IF( LDWORK.LT.MINWRK )
     $      INFO = -31
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB10DD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0
     $    .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN
          RCOND( 1 ) = ONE
          RCOND( 2 ) = ONE
          RCOND( 3 ) = ONE
          RCOND( 4 ) = ONE
          RCOND( 5 ) = ONE
          RCOND( 6 ) = ONE
          RCOND( 7 ) = ONE
          RCOND( 8 ) = ONE
          DWORK( 1 ) = ONE
          RETURN
      END IF
C
      TOLL = TOL
      IF( TOLL.LE.ZERO ) THEN
C
C        Set the default value of the tolerance in rank determination.
C
         TOLL = THOUSN*DLAMCH( 'Epsilon' )
      END IF
C
C     Workspace usage.
C
      IWS  = (N+NP1)*(N+M2) + 1
      IWRK = IWS + (N+M2)
C
C                      jTheta
C     Determine if |A-e      I  B2 | has full column rank at
C                  |     C1     D12|
C     Theta = Pi/2 .
C     Workspace: need (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2));
C                prefer larger.
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP1 )
      CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( N+1 ), N+NP1 )
      CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB,
     $             DWORK( (N+NP1)*N+1 ), N+NP1 )
      CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD,
     $             DWORK( (N+NP1)*N+N+1 ), N+NP1 )
      CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK, N+NP1, DWORK( IWS ),
     $             DWORK, N+NP1, DWORK, N+M2, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 9
         RETURN
      END IF
      IF( DWORK( IWS+N+M2 ) / DWORK( IWS ).LE.TOLL ) THEN
         INFO = 1
         RETURN
      END IF
      LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1
C
C     Workspace usage.
C
      IWS  = (N+NP2)*(N+M1) + 1
      IWRK = IWS + (N+NP2)
C
C                      jTheta
C     Determine if |A-e      I   B1 | has full row rank at
C                  |     C2      D21|
C     Theta = Pi/2 .
C     Workspace: need   (N+NP2)*(N+M1+1) +
C                       MAX(3*(N+NP2)+N+M1,5*(N+NP2));
C                prefer larger.
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP2 )
      CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( N+1 ),
     $             N+NP2 )
      CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( (N+NP2)*N+1 ),
     $             N+NP2 )
      CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD,
     $             DWORK( (N+NP2)*N+N+1 ), N+NP2 )
      CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK, N+NP2, DWORK( IWS ),
     $             DWORK, N+NP2, DWORK, N+M1, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 9
         RETURN
      END IF
      IF( DWORK( IWS+N+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN
         INFO = 2
         RETURN
      END IF
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Workspace usage.
C
      IWS  = NP1*M2 + 1
      IWRK = IWS + M2
C
C     Determine if D12 has full column rank.
C     Workspace: need   (NP1+1)*M2 + MAX(3*M2+NP1,5*M2);
C                prefer larger.
C
      CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, DWORK, NP1 )
      CALL DGESVD( 'N', 'N', NP1, M2, DWORK, NP1, DWORK( IWS ), DWORK,
     $             NP1, DWORK, M2, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 9
         RETURN
      END IF
      IF( DWORK( IWS+M2 ) / DWORK( IWS ).LE.TOLL ) THEN
         INFO = 3
         RETURN
      END IF
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Workspace usage.
C
      IWS  = NP2*M1 + 1
      IWRK = IWS + NP2
C
C     Determine if D21 has full row rank.
C     Workspace: need   NP2*(M1+1) + MAX(3*NP2+M1,5*NP2);
C                prefer larger.
C
      CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, NP2 )
      CALL DGESVD( 'N', 'N', NP2, M1, DWORK, NP2, DWORK( IWS ), DWORK,
     $             NP2, DWORK, M1, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 9
         RETURN
      END IF
      IF( DWORK( IWS+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN
         INFO = 4
         RETURN
      END IF
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Workspace usage.
C
      IWV  = 1
      IWB  = IWV + M*M
      IWC  = IWB + N*M1
      IWD  = IWC + ( M2 + NP2 )*N
      IWQ  = IWD + ( M2 + NP2 )*M1
      IWL  = IWQ + N*N
      IWR  = IWL + N*M
      IWI  = IWR + 2*N
      IWH  = IWI + 2*N
      IWS  = IWH + 2*N
      IWT  = IWS + ( 2*N + M )*( 2*N + M )
      IWU  = IWT + ( 2*N + M )*2*N
      IWRK = IWU + 4*N*N
      IR2  = IWV + M1
      IR3  = IR2 + M*M1
C
C     Compute R0 = |D11'||D11 D12| -|gamma^2*Im1 0| .
C                  |D12'|           |   0        0|
C
      CALL DSYRK( 'Lower', 'Transpose', M, NP1, ONE, D, LDD, ZERO,
     $            DWORK, M )
      DO 10 J = 1, M*M1, M + 1
         DWORK( J ) = DWORK( J ) - GAMMA*GAMMA
   10 CONTINUE
C
C     Compute C1'*C1 .
C
      CALL DSYRK( 'Lower', 'Transpose', N, NP1, ONE, C, LDC, ZERO,
     $            DWORK( IWQ ), N )
C
C     Compute C1'*|D11 D12| .
C
      CALL DGEMM( 'Transpose', 'NoTranspose', N, M, NP1, ONE, C, LDC,
     $            D, LDD, ZERO, DWORK( IWL ), N )
C
C     Solution of the X-Riccati equation.
C     Workspace: need   13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) +
C                       6*N + max(14*N+23,16*N,2*N+M,3*M);
C                prefer larger.
C
      CALL SB02OD( 'D', 'B', 'N', 'L', 'N', 'S', N, M, NP, A, LDA, B,
     $             LDB, DWORK( IWQ ), N, DWORK, M, DWORK( IWL ), N,
     $             RCOND2, X, LDX, DWORK( IWR ), DWORK( IWI ),
     $             DWORK( IWH ), DWORK( IWS ), 2*N+M, DWORK( IWT ),
     $             2*N+M, DWORK( IWU ), 2*N, TOLL, IWORK,
     $             DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 6
         RETURN
      END IF
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Condition estimation.
C     Workspace: need   4*N*N + 2*M*M + N*(3*M+NP2) + M1*(M2+NP2) +
C                       max(5*N,max(3,2*N*N)+N*N);
C                prefer larger.
C
      IWS  = IWR
      IWH  = IWS + M*M
      IWT  = IWH + N*M
      IWU  = IWT + N*N
      IWG  = IWU + N*N
      IWRK = IWG + N*N
      CALL DLACPY( 'Lower', M, M, DWORK, M, DWORK( IWS ), M )
      CALL DSYTRF( 'Lower', M, DWORK( IWS ), M, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 5
         RETURN
      END IF
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
      CALL MA02AD( 'Full', N, M, B, LDB, DWORK( IWH ), M )
      CALL DSYTRS( 'Lower', M, N, DWORK( IWS ), M, IWORK, DWORK( IWH ),
     $             M, INFO2 )
      CALL MB01RX( 'Left', 'Lower', 'NoTranspose', N, M, ZERO, ONE,
     $             DWORK( IWG ), N, B, LDB, DWORK( IWH ), M, INFO2 )
      CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, A, LDA, DWORK( IWT ), N,
     $             DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, X,
     $             LDX, SEPD, RCOND( 7 ), FERR, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) RCOND( 7 ) = ZERO
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Workspace usage.
C
      IWRK = IWR
C
C     Compute the lower triangle of |R1  R2'| = R0 + B'*X*B .
C                                   |R2  R3 |
C
      CALL MB01RU( 'Lower', 'Transpose', M, N, ONE, ONE, DWORK, M,
     $             B, LDB, X, LDX, DWORK( IWRK ), M*N, INFO2 )
C
C     Compute the Cholesky factorization of R3, R3 = V12'*V12 .
C     Note that V12' is stored.
C
      ANORM = DLANSY( '1', 'Lower', M2, DWORK( IR3 ), M, DWORK( IWRK ) )
      CALL DPOTRF( 'Lower', M2, DWORK( IR3 ), M, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 5
         RETURN
      END IF
      CALL DPOCON( 'Lower', M2, DWORK( IR3 ), M, ANORM, RCOND( 1 ),
     $             DWORK( IWRK ), IWORK, INFO2 )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND( 1 ).LT.TOLL ) THEN
         INFO = 5
         RETURN
      END IF
C
      CALL DTRCON( '1', 'Lower', 'NonUnit', M2, DWORK( IR3 ), M,
     $             RCOND( 5 ), DWORK( IWRK ), IWORK, INFO2 )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND( 5 ).LT.TOLL ) THEN
         INFO = 5
         RETURN
      END IF
C
C     Compute R2 <- inv(V12')*R2 .
C
      CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, M1,
     $            ONE, DWORK( IR3 ), M, DWORK( IR2 ), M )
C
C     Compute -Nabla = R2'*inv(R3)*R2 - R1 .
C
      CALL DSYRK( 'Lower', 'Transpose', M1, M2, ONE, DWORK( IR2 ), M,
     $            -ONE, DWORK, M )
C
C     Compute the Cholesky factorization of -Nabla, -Nabla = V21t'*V21t.
C     Note that V21t' is stored.
C
      ANORM = DLANSY( '1', 'Lower', M1, DWORK, M, DWORK( IWRK ) )
      CALL DPOTRF( 'Lower', M1, DWORK, M, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 5
         RETURN
      END IF
      CALL DPOCON( 'Lower', M1, DWORK, M, ANORM, RCOND( 2 ),
     $             DWORK( IWRK ), IWORK, INFO2 )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND( 2 ).LT.TOLL ) THEN
         INFO = 5
         RETURN
      END IF
C
      CALL DTRCON( '1', 'Lower', 'NonUnit', M1, DWORK, M, RCOND( 3 ),
     $             DWORK( IWRK ), IWORK, INFO2 )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND( 3 ).LT.TOLL ) THEN
         INFO = 5
         RETURN
      END IF
C
C     Compute X*A .
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, X, LDX,
     $            A, LDA, ZERO, DWORK( IWQ ), N )
C
C     Compute |L1| = |D11'|*C1 + B'*X*A .
C             |L2| = |D12'|
C
      CALL MA02AD( 'Full', N, M, DWORK( IWL ), N, DWORK( IWRK ), M )
      CALL DLACPY( 'Full', M, N, DWORK( IWRK ), M, DWORK( IWL ), M )
      CALL DGEMM( 'Transpose', 'NoTranspose', M, N, N, ONE, B, LDB,
     $            DWORK( IWQ ), N, ONE, DWORK( IWL ), M )
C
C     Compute L2 <- inv(V12')*L2 .
C
      CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, N, ONE,
     $            DWORK( IR3 ), M, DWORK( IWL+M1 ), M )
C
C     Compute L_Nabla = L1 - R2'*inv(R3)*L2 .
C
      CALL DGEMM( 'Transpose', 'NoTranspose', M1, N, M2, -ONE,
     $            DWORK( IR2 ), M, DWORK( IWL+M1 ), M, ONE,
     $            DWORK( IWL ), M )
C
C     Compute L_Nabla <- inv(V21t')*L_Nabla .
C
      CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M1, N, ONE,
     $            DWORK, M, DWORK( IWL ), M )
C
C     Compute Bt1 = B1*inv(V21t) .
C
      CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IWB ), N )
      CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', N, M1, ONE,
     $            DWORK, M, DWORK( IWB ), N )
C
C     Compute At .
C
      CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M1, ONE,
     $            DWORK( IWB ), N, DWORK( IWL ), M, ONE, AK, LDAK )
C
C     Scale Bt1 .
C
      CALL DSCAL( N*M1, GAMMA, DWORK( IWB ), 1 )
C
C     Compute |Dt11| = |R2 |*inv(V21t) .
C             |Dt21|   |D21|
C
      CALL DLACPY( 'Full', M2, M1, DWORK( IR2 ), M, DWORK( IWD ),
     $             M2+NP2 )
      CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK( IWD+M2 ),
     $             M2+NP2 )
      CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M2+NP2,
     $            M1, ONE, DWORK, M, DWORK( IWD ), M2+NP2 )
C
C     Compute Ct = |Ct1| = |L2| + |Dt11|*inv(V21t')*L_Nabla .
C                  |Ct2| = |C2| + |Dt21|
C
      CALL DLACPY( 'Full', M2, N, DWORK( IWL+M1 ), M, DWORK( IWC ),
     $             M2+NP2 )
      CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1 ), LDC, DWORK( IWC+M2 ),
     $             M2+NP2 )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', M2+NP2, N, M1, ONE,
     $            DWORK( IWD ), M2+NP2, DWORK( IWL ), M, ONE,
     $            DWORK( IWC ), M2+NP2 )
C
C     Scale |Dt11| .
C           |Dt21|
C
      CALL DSCAL( ( M2+NP2 )*M1, GAMMA, DWORK( IWD ), 1 )
C
C     Workspace usage.
C
      IWW  = IWD + ( M2 + NP2 )*M1
      IWQ  = IWW + ( M2 + NP2 )*( M2 + NP2 )
      IWL  = IWQ + N*N
      IWR  = IWL + N*( M2 + NP2 )
      IWI  = IWR + 2*N
      IWH  = IWI + 2*N
      IWS  = IWH + 2*N
      IWT  = IWS + ( 2*N + M2 + NP2 )*( 2*N + M2 + NP2 )
      IWU  = IWT + ( 2*N + M2 + NP2 )*2*N
      IWG  = IWU + 4*N*N
      IWRK = IWG + ( M2 + NP2 )*N
      IS2  = IWW + ( M2 + NP2 )*M2
      IS3  = IS2 + M2
C
C     Compute S0 = |Dt11||Dt11' Dt21'| -|gamma^2*Im2 0| .
C                  |Dt21|               |   0        0|
C
      CALL DSYRK( 'Upper', 'NoTranspose', M2+NP2, M1, ONE, DWORK( IWD ),
     $            M2+NP2, ZERO, DWORK( IWW ), M2+NP2 )
      DO 20 J = IWW, IWW - 1 + ( M2 + NP2 )*M2, M2 + NP2 + 1
         DWORK( J ) = DWORK( J ) - GAMMA*GAMMA
   20 CONTINUE
C
C     Compute Bt1*Bt1' .
C
      CALL DSYRK( 'Upper', 'NoTranspose', N, M1, ONE, DWORK( IWB ), N,
     $            ZERO, DWORK( IWQ ), N )
C
C     Compute Bt1*|Dt11' Dt21'| .
C
      CALL DGEMM( 'NoTranspose', 'Transpose', N, M2+NP2, M1, ONE,
     $            DWORK( IWB ), N, DWORK( IWD ), M2+NP2, ZERO,
     $            DWORK( IWL ), N )
C
C     Transpose At in situ (in AK) .
C
      DO 30 J = 2, N
         CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 )
   30 CONTINUE
C
C     Transpose Ct .
C
      CALL MA02AD( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2,
     $             DWORK( IWG ), N )
C
C     Solution of the Z-Riccati equation.
C     Workspace: need   13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) +
C                       N*(M+NP2) + 6*N +
C                       max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2));
C                prefer larger.
C
      CALL SB02OD( 'D', 'B', 'N', 'U', 'N', 'S', N, M2+NP2, NP, AK,
     $             LDAK, DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWW ),
     $             M2+NP2, DWORK( IWL ), N, RCOND2, Z, LDZ, DWORK( IWR),
     $             DWORK( IWI ), DWORK( IWH ), DWORK( IWS ), 2*N+M2+NP2,
     $             DWORK( IWT ), 2*N+M2+NP2, DWORK( IWU ), 2*N, TOLL,
     $             IWORK, DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 7
         RETURN
      END IF
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Condition estimation.
C     Workspace: need   4*N*N + M*M + 2*(M2+NP2)*(M2+NP2)+
C                       N*(M+2*M2+3*NP2) + (M2+NP2)*M1 +
C                       max(5*N,max(3,2*N*N)+N*N);
C                prefer larger.
C
      IWS  = IWR
      IWH  = IWS + ( M2 + NP2 )*( M2 + NP2 )
      IWT  = IWH + N*( M2 + NP2 )
      IWU  = IWT + N*N
      IWG  = IWU + N*N
      IWRK = IWG + N*N
      CALL DLACPY( 'Upper', M2+NP2, M2+NP2, DWORK( IWW ), M2+NP2,
     $             DWORK( IWS ), M2+NP2 )
      CALL DSYTRF( 'Upper', M2+NP2, DWORK( IWS ), M2+NP2, IWORK,
     $             DWORK( IWRK ), LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 5
         RETURN
      END IF
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
      CALL DLACPY( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2,
     $             DWORK( IWH ), M2+NP2 )
      CALL DSYTRS( 'Upper', M2+NP2, N, DWORK( IWS ), M2+NP2, IWORK,
     $             DWORK( IWH ), M2+NP2, INFO2 )
      CALL MB01RX( 'Left', 'Upper', 'Transpose', N, M2+NP2, ZERO, ONE,
     $             DWORK( IWG ), N, DWORK( IWC ), M2+NP2, DWORK( IWH ),
     $             M2+NP2, INFO2 )
      CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWT ),
     $             N, DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N,
     $             Z, LDZ, SEPD, RCOND( 8 ), FERR, IWORK, DWORK( IWRK ),
     $             LDWORK-IWRK+1, INFO2 )
      IF( INFO2.GT.0 ) RCOND( 8 ) = ZERO
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Workspace usage.
C
      IWRK = IWR
C
C     Compute the upper triangle of
C             |St1   St2| = S0 + |Ct1|*Z*|Ct1' Ct2'| .
C             |St2'  St3|        |Ct2|
C
      CALL MB01RU( 'Upper', 'NoTranspose', M2+NP2, N, ONE, ONE,
     $             DWORK( IWW ), M2+NP2, DWORK( IWC ), M2+NP2, Z, LDZ,
     $             DWORK( IWRK ), (M2+NP2)*N, INFO2 )
C
C     Compute the Cholesky factorization of St3, St3 = U12'*U12 .
C
      ANORM = DLANSY( '1', 'Upper', NP2, DWORK( IS3 ), M2+NP2,
     $                DWORK( IWRK ) )
      CALL DPOTRF( 'Upper', NP2, DWORK( IS3 ), M2+NP2, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 5
         RETURN
      END IF
      CALL DPOCON( 'Upper', NP2, DWORK( IS3 ), M2+NP2, ANORM,
     $             RCOND( 4 ), DWORK( IWRK ), IWORK, INFO2 )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND( 4 ).LT.TOLL ) THEN
         INFO = 5
         RETURN
      END IF
C
C     Compute St2 <- St2*inv(U12) .
C
      CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M2, NP2,
     $            ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 )
C
C     Check the negative definiteness of St1 - St2*inv(St3)*St2' .
C
      CALL DSYRK( 'Upper', 'NoTranspose', M2, NP2, ONE, DWORK( IS2 ),
     $            M2+NP2, -ONE, DWORK( IWW ), M2+NP2 )
      CALL DPOTRF( 'Upper', M2, DWORK( IWW ), M2+NP2, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 5
         RETURN
      END IF
C
C     Restore At in situ .
C
      DO 40 J = 2, N
         CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 )
   40 CONTINUE
C
C     Compute At*Z .
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, AK, LDAK,
     $            Z, LDZ, ZERO, DWORK( IWRK ), N )
C
C     Compute Mt2 = Bt1*Dt21' + At*Z*Ct2' in BK .
C
      CALL DLACPY( 'Full', N, NP2, DWORK( IWL+N*M2 ), N, BK, LDBK )
      CALL DGEMM( 'NoTranspose', 'Transpose', N, NP2, N, ONE,
     $            DWORK( IWRK ), N, DWORK( IWC+M2 ), M2+NP2, ONE,
     $            BK, LDBK )
C
C     Compute St2 <- St2*inv(U12') .
C
      CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M2, NP2,
     $            ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 )
C
C     Compute DKHAT = -inv(V12)*St2 in DK .
C
      CALL DLACPY( 'Full', M2, NP2, DWORK( IS2 ), M2+NP2, DK, LDDK )
      CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, NP2,
     $            -ONE, DWORK( IR3 ), M, DK, LDDK )
C
C     Compute CKHAT = -inv(V12)*(Ct1 - St2*inv(St3)*Ct2) in CK .
C
      CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, N, NP2, -ONE,
     $            DWORK( IS2 ), M2+NP2, DWORK( IWC+M2 ), M2+NP2, ONE,
     $            CK, LDCK )
      CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, N, -ONE,
     $            DWORK( IR3 ), M, CK, LDCK )
C
C     Compute Mt2*inv(St3) in BK .
C
      CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, NP2,
     $            ONE, DWORK( IS3 ), M2+NP2, BK, LDBK )
      CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, NP2,
     $            ONE, DWORK( IS3 ), M2+NP2, BK, LDBK )
C
C     Compute AKHAT in AK .
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, ONE,
     $            B( 1, M1+1 ), LDB, CK, LDCK, ONE, AK, LDAK )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, NP2, -ONE, BK,
     $            LDBK, DWORK( IWC+M2 ), M2+NP2, ONE, AK, LDAK )
C
C     Compute BKHAT in BK .
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, ONE,
     $            B( 1, M1+1 ), LDB, DK, LDDK, ONE, BK, LDBK )
C
C     Compute Im2 + DKHAT*D22 .
C
      IWRK = M2*M2 + 1
      CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, M2, NP2, ONE, DK,
     $            LDDK, D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 )
      ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) )
      CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 8
         RETURN
      END IF
      CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND( 6 ), DWORK( IWRK ),
     $             IWORK( M2+1 ), INFO2 )
C
C     Return if the matrix is singular to working precision.
C
      IF( RCOND( 6 ).LT.TOLL ) THEN
         INFO = 8
         RETURN
      END IF
C
C     Compute CK .
C
      CALL DGETRS( 'NoTranspose', M2, N, DWORK, M2, IWORK, CK, LDCK,
     $             INFO2 )
C
C     Compute DK .
C
      CALL DGETRS( 'NoTranspose', M2, NP2, DWORK, M2, IWORK, DK, LDDK,
     $             INFO2 )
C
C     Compute AK .
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M2, NP2, ONE, BK,
     $            LDBK, D( NP1+1, M1+1 ), LDD, ZERO, DWORK, N )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, -ONE, DWORK,
     $            N, CK, LDCK, ONE, AK, LDAK )
C
C     Compute BK .
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, -ONE, DWORK,
     $            N, DK, LDDK, ONE, BK, LDBK )
C
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB10DD ***
      END


!======================================================================!
  real function UserVRms(grid, y)
!----------------------------------------------------------------------!
!   Prescribes mean spanwise velocity fluctuations for the channel.    !
!----------------------------------------------------------------------!
  implicit none
!-----------------------------[Arguments]------------------------------!
  real :: y
!======================================================================!
!   Wall is at y=0, and centerline at y=1                              !
!----------------------------------------------------------------------!

  UserVRms =                                                        &
   +2.432998e+003  * y**9  -  1.166312e+004  * y**8                 &
   +2.368065e+004  * y**7  -  2.653575e+004  * y**6                 &
   +1.793421e+004  * y**5  -  7.514617e+003  * y**4                 &
   +1.941100e+003  * y**3  -  3.012721e+002  * y**2                 &
   +2.639077e+001  * y**1  +  2.737377e-002

  end function UserVRms


module module_convolution
  use, intrinsic :: iso_fortran_env
  use internal
  implicit none
  integer(int64), private, parameter :: mod1 = 167772161, root1 = 3
  integer(int64), private, parameter :: mod2 = 469762049, root2 = 3
  integer(int64), private, parameter :: mod3 = 1224736769, root3 = 3
  integer(int64), private, parameter :: mod12 = mod1 * mod2
  integer(int64), private, parameter :: inv12 = 104391568 ! inv_mod(mod1, mod2)
  integer(int64), private, parameter :: inv123 = 721017874 ! inv_mod(mod12, mod3)
  private :: pow_mod, swap
contains
  integer(int32) function find_pow2(n) result(res)
    integer(int32), intent(in) :: n
    res = n - 1
    res = or(res, rshift(res, 1))
    res = or(res, rshift(res, 2))
    res = or(res, rshift(res, 4))
    res = or(res, rshift(res, 8))
    res = or(res, rshift(res, 16))
    res = res + 1
  end
  subroutine ntt(n, a, modulus, root, inverse)
    integer(int32), intent(in) :: n
    integer(int64), intent(inout) :: a(0:n - 1)
    integer(int64), intent(in) :: modulus, root
    logical, optional, intent(in) :: inverse
    logical :: inv
    integer(int32) :: i, j, k, l
    integer(int64) :: h, b, w, u, d
    inv = merge(inverse, .false., present(inverse))
    h = pow_mod(root, (modulus - 1) / n, modulus)
    if (inv) h = inv_mod(h, modulus)
    i = 0
    do j = 1, n - 2
      k = rshift(n, 1)
      i = xor(i, k)
      do while (k > i)
        k = rshift(k, 1)
        i = xor(i, k)
      end do
      if (j < i) call swap(a(i), a(j))
    end do
    i = 1
    do while (i < n)
      k = i * 2
      b = pow_mod(h, int(n / k, int64), modulus)
      w = 1
      do j = 0, i - 1
        do l = j, n - 1, k
          u = a(l)
          d = mod(a(l + i) * w, modulus)
          a(l) = u + d
          if (a(l) > modulus) a(l) = a(l) - modulus
          a(l + i) = u - d
          if (a(l + i) < 0) a(l + i) = a(l + i) + modulus
        end do
        w = mod(w * b, modulus)
      end do
      i = i * 2
    end do
    do i = 0, n - 1
      if (a(i) < 0) a(i) = a(i) + modulus
    end do
    if (inv) then
      a = mod(a * inv_mod(int(n, int64), modulus), modulus)
    end if
  end
  function convolution(na_, a, nb_, b, modulus, root) result(res)
    integer(int32), intent(in) :: na_, nb_
    integer(int64), intent(in) :: a(0:na_ - 1), b(0:nb_ - 1), modulus, root
    integer(int32) :: na, nb, n
    integer(int64) :: res(0:na_ + nb_ - 2)
    integer(int64), allocatable :: x(:), y(:), z(:)
    res = 0
    na = na_
    do while (na > 0)
      if (a(na - 1) /= 0) exit
      na = na - 1
    end do
    if (na == 0) return
    nb = nb_
    do while (nb > 0)
      if (b(nb - 1) /= 0) exit
      nb = nb - 1
    end do
    if (nb == 0) return
    n = find_pow2(na + nb - 1)
    allocate(x(0:n - 1), y(0:n - 1), z(0:n - 1))
    x(0:na - 1) = a(0:na - 1)
    x(na:n - 1) = 0
    call ntt(n, x, modulus, root, .false.)
    y(0:nb - 1) = b(0:nb - 1)
    y(nb:n - 1) = 0
    call ntt(n, y, modulus, root, .false.)
    z = mod(x * y, modulus)
    call ntt(n, z, modulus, root, .true.)
    res(0:na + nb - 2) = z(0:na + nb - 2)
  end
  function convolution_ll(na, a, nb, b, modulus) result(res)
    integer(int32), intent(in) :: na, nb
    integer(int64), intent(in) :: a(0:na - 1), b(0:nb - 1), modulus
    integer(int64) :: p(0:na - 1), q(0:nb - 1), modm, v1, v2
    integer(int64), dimension(0:na + nb - 2) :: res, x, y, z
    integer(int32) :: i
    p = modulo(a, modulus)
    q = modulo(b, modulus)
    x = convolution(na, p, nb, q, mod1, root1)
    y = convolution(na, p, nb, q, mod2, root2)
    z = convolution(na, p, nb, q, mod3, root3)
    modm = mod(mod12, modulus)
    do i = 0, na + nb - 2
      v1 = modulo((y(i) - x(i)) * inv12, mod2)
      v2 = modulo((z(i) - mod(x(i) + mod1 * v1, mod3)) * inv123, mod3)
      res(i) = modulo(x(i) + mod1 * v1 + modm * v2, modulus)
    end do
  end
end module


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      real*8 function fumid(n,x,cotet,kontet,ipoeln,ieln,node,iedge,
     &     ipoeled,ieled,iedgmid,iedtet)
!
!     determination of the quality of the shell of quadratic tetrahedron
!     elements around a node; consists of a combination of:
!     - the quality of the linear tetrahedrons in which it can be
!       subdivided (P.L. George)
!     - a penalty function for negative Jacobians at the integration
!       points
!
      implicit none
!
      integer n,kontet(4,*),ipoeln(*),ieln(2,*),node,ine(2,6),indexe,
     &     ielem,nodes(10),n1,n2,i,j,k,m,iedge,ipoeled(*),ieled(2,*),
     &     iedgmid(*),iedtet(6,*),i6(4,8),nodesedge(4),iflag
!
      real*8 cotet(3,*),alpha,x(n),volume,surface(4),totsurface,
     &     edgelength(6),radius,hmax,quality,xi,et,ze,shp(4,10),xsj,
     &     xl(3,10)
!
!     nodes belonging to the linear sub-tetrahedra
!
      data i6 /8,9,10,4,1,5,7,8,7,6,3,10,9,8,10,7,
     &     8,9,5,7,9,10,6,7,5,6,7,9,5,2,6,9/
!
!     edges of a tetrahedron
!
      data ine /1,2,2,3,1,3,1,4,2,4,3,4/
!
      data iflag /2/
!
      include "gauss.f"
!
      fumid=0.d0
!
!     alpha is the proporionality factor
!
      alpha=dsqrt(6.d0)/12.d0
!
      indexe=ipoeled(iedge)
!
      do
        if(indexe.eq.0) exit
        ielem=ieled(1,indexe)
!
!     determine the coordinates of the nodes belonging to the element
!
!     vertex nodes
!
        do i=1,4
          nodes(i)=kontet(i,ielem)
          do k=1,3
            xl(k,i)=cotet(k,nodes(i))
          enddo
        enddo
!
!     middle nodes
!
        do i=1,6
          nodes(i+4)=iedgmid(iedtet(i,ielem))
          do k=1,3
            xl(k,i+4)=cotet(k,nodes(i+4))
          enddo
!
!     replace the coordinates by the optimization variables
!
          if(nodes(i+4).eq.node) then
            do m=1,3
              cotet(m,node)=x(m)
              xl(m,i+4)=x(m)
            enddo
          endif
        enddo
!
!     loop over the linear sub-tetrahedrons
!
        do i=1,8
!
          call calcvol(nodes(i6(1,i)),nodes(i6(2,i)),nodes(i6(3,i)),
     &         nodes(i6(4,i)),cotet,volume)
          if(volume.le.1.d-15) volume=1.d-15
!
!     calculating the area of each face of the element
!
          call calcsurf(nodes(i6(1,i)),nodes(i6(2,i)),nodes(i6(3,i)),
     &         cotet,surface(1))
          call calcsurf(nodes(i6(2,i)),nodes(i6(3,i)),nodes(i6(4,i)),
     &         cotet,surface(2))
          call calcsurf(nodes(i6(3,i)),nodes(i6(4,i)),nodes(i6(1,i)),
     &         cotet,surface(3))
          call calcsurf(nodes(i6(4,i)),nodes(i6(1,i)),nodes(i6(2,i)),
     &         cotet,surface(4))
!
!     calculating the total surface
!
          totsurface=surface(1)+surface(2)+surface(3)+surface(4)
!
!     radius of the inscribed sphere
!
          radius=3.d0*volume/totsurface
!
!     length of each edge
!
          nodesedge(1)=nodes(i6(1,i))
          nodesedge(2)=nodes(i6(2,i))
          nodesedge(3)=nodes(i6(3,i))
          nodesedge(4)=nodes(i6(4,i))
!
          do j=1,6
            n1=nodesedge(ine(1,j))
            n2=nodesedge(ine(2,j))
            edgelength(j)=dsqrt((cotet(1,n1)-cotet(1,n2))**2+
     &           (cotet(2,n1)-cotet(2,n2))**2+
     &           (cotet(3,n1)-cotet(3,n2))**2)
          enddo
!
!     maximum edge length
!
          hmax=maxval(edgelength)
!
!     quality of the element
!
          quality=alpha*hmax/radius
!
          fumid=max(fumid,quality)
        enddo
!
!     determine the Jacobian in each integration point
!     notice: the penalty due to a negative Jacobian must be
!     bigger than the size of quality (volume >= 1.d-15)
!
        do j=1,4
          xi=gauss3d5(1,j)
          et=gauss3d5(2,j)
          ze=gauss3d5(3,j)
          call shape10tet(xi,et,ze,xl,xsj,shp,iflag)
          if(xsj.le.0.d0) then
            fumid=fumid+1.d30*(1.d0-xsj)
            exit
          endif
        enddo
!
        indexe=ieled(2,indexe)
      enddo
!
      return
      end


      SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C,
     $                   LDC, D, LDD, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To perform a transformation on the parameters (A,B,C,D) of a
C     system, which is equivalent to a bilinear transformation of the
C     corresponding transfer function matrix.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPE    CHARACTER*1
C             Indicates the type of the original system and the
C             transformation to be performed as follows:
C             = 'D':  discrete-time   -> continuous-time;
C             = 'C':  continuous-time -> discrete-time.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     ALPHA,  (input) DOUBLE PRECISION
C     BETA    Parameters specifying the bilinear transformation.
C             Recommended values for stable systems: ALPHA = 1,
C             BETA = 1.  ALPHA <> 0, BETA <> 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 state matrix A of the original system.
C             On exit, the leading N-by-N part of this array contains
C                              _
C             the state matrix A of the transformed system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B of the original system.
C             On exit, the leading N-by-M part of this array contains
C                              _
C             the input matrix B of the transformed system.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C of the original system.
C             On exit, the leading P-by-N part of this array contains
C                               _
C             the output matrix C of the transformed system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the input/output matrix D for the original system.
C             On exit, the leading P-by-M part of this array contains
C                                     _
C             the input/output matrix D of the transformed system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C             For optimum performance LDWORK >= MAX(1,N*NB), where NB
C             is the optimal blocksize.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the matrix (ALPHA*I + A) is exactly singular;
C             = 2:  if the matrix  (BETA*I - A) is exactly singular.
C
C     METHOD
C
C     The parameters of the discrete-time system are transformed into
C     the parameters of the continuous-time system (TYPE = 'D'), or
C     vice-versa (TYPE = 'C') by the transformation:
C
C     1.  Discrete -> continuous
C         _                     -1
C         A = beta*(alpha*I + A)  * (A - alpha*I)
C         _                                     -1
C         B = sqrt(2*alpha*beta) * (alpha*I + A)  * B
C         _                                         -1
C         C = sqrt(2*alpha*beta) * C * (alpha*I + A)
C         _                        -1
C         D = D - C * (alpha*I + A)  * B
C
C     which is equivalent to the bilinear transformation
C
C                       z - alpha
C         z -> s = beta ---------  .
C                       z + alpha
C
C     of one transfer matrix onto the other.
C
C     2.  Continuous -> discrete
C         _                     -1
C         A = alpha*(beta*I - A)  * (beta*I + A)
C         _                                    -1
C         B = sqrt(2*alpha*beta) * (beta*I - A)  * B
C         _                                        -1
C         C = sqrt(2*alpha*beta) * C * (beta*I - A)
C         _                       -1
C         D = D + C * (beta*I - A)  * B
C
C     which is equivalent to the bilinear transformation
C
C                      beta + s
C       s -> z = alpha -------- .
C                      beta - s
C
C     of one transfer matrix onto the other.
C
C     REFERENCES
C
C     [1] Al-Saggaf, U.M. and Franklin, G.F.
C         Model reduction via balanced realizations: a extension and
C         frequency weighting techniques.
C         IEEE Trans. Autom. Contr., AC-33, pp. 687-692, 1988.
C
C     NUMERICAL ASPECTS
C                                                      3
C     The time taken is approximately proportional to N .
C     The accuracy depends mainly on the condition number of the matrix
C     to be inverted.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and
C                  A. Varga, German Aerospace Research Establishment,
C                  Oberpfaffenhofen, Germany, Nov. 1996.
C     Supersedes Release 2.0 routine AB04AD by W. van der Linden, and
C     A.J. Geurts, Technische Hogeschool Eindhoven, Holland.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Bilinear transformation, continuous-time system, discrete-time
C     system, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TYPE
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LTYPE
      INTEGER           I, IP
      DOUBLE PRECISION  AB2, PALPHA, PBETA, SQRAB2
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DGETRF, DGETRS, DGETRI, DLASCL, DSCAL,
     $                  DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, SIGN, SQRT
C     .. Executable Statements ..
C
      INFO = 0
      LTYPE = LSAME( TYPE, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LTYPE .AND. .NOT.LSAME( TYPE, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( ALPHA.EQ.ZERO ) THEN
         INFO = -5
      ELSE IF( BETA.EQ.ZERO ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -14
      ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN
         INFO = -17
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB04MD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, M, P ).EQ.0 )
     $   RETURN
C
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
      IF (LTYPE) THEN
C
C        Discrete-time to continuous-time with (ALPHA, BETA).
C
         PALPHA = ALPHA
         PBETA = BETA
      ELSE
C
C        Continuous-time to discrete-time with (ALPHA, BETA) is
C        equivalent with discrete-time to continuous-time with
C        (-BETA, -ALPHA), if B and C change the sign.
C
         PALPHA = -BETA
         PBETA = -ALPHA
      END IF
C
      AB2 = PALPHA*PBETA*TWO
      SQRAB2 = SIGN( SQRT( ABS( AB2 ) ), PALPHA )
C                          -1
C     Compute (alpha*I + A)  .
C
      DO 10 I = 1, N
         A(I,I)  =  A(I,I) + PALPHA
   10 CONTINUE
C
      CALL DGETRF( N, N, A, LDA, IWORK, INFO )
C
      IF (INFO.NE.0) THEN
C
C        Error return.
C
         IF (LTYPE) THEN
            INFO = 1
         ELSE
            INFO = 2
         END IF
         RETURN
      END IF
C                         -1
C     Compute  (alpha*I+A)  *B.
C
      CALL DGETRS( 'No transpose', N, M, A, LDA, IWORK, B, LDB, INFO )
C                               -1
C     Compute  D - C*(alpha*I+A)  *B.
C
      CALL DGEMM( 'No transpose', 'No transpose', P, M, N, -ONE, C,
     $            LDC, B, LDB, ONE, D, LDD )
C
C     Scale B by  sqrt(2*alpha*beta).
C
      CALL DLASCL( 'General', 0, 0, ONE, SQRAB2, N, M, B, LDB, INFO )
C                                                -1
C     Compute  sqrt(2*alpha*beta)*C*(alpha*I + A)  .
C
      CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', P, N,
     $            SQRAB2, A, LDA, C, LDC )
C
      CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', P, N, ONE,
     $            A, LDA, C, LDC )
C
C     Apply column interchanges to the solution matrix.
C
      DO 20 I = N-1, 1, -1
         IP = IWORK(I)
         IF ( IP.NE.I )
     $      CALL DSWAP( P, C(1,I), 1, C(1,IP), 1 )
  20  CONTINUE
C                               -1
C     Compute beta*(alpha*I + A)  *(A - alpha*I) as
C                                        -1
C     beta*I - 2*alpha*beta*(alpha*I + A)  .
C
C     Workspace: need N;  prefer N*NB.
C
      CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO )
C
      DO 30 I = 1, N
         CALL DSCAL(N, -AB2, A(1,I), 1)
         A(I,I) = A(I,I) + PBETA
   30 CONTINUE
C
      RETURN
C *** Last line of AB04MD ***
      END


*> \brief \b SLAQZ0
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAQZ0 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*      SUBROUTINE SLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A, LDA, B,
*     $    LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, REC,
*     $    INFO )
*      IMPLICIT NONE
*
*      Arguments
*      CHARACTER, INTENT( IN ) :: WANTS, WANTQ, WANTZ
*      INTEGER, INTENT( IN ) :: N, ILO, IHI, LDA, LDB, LDQ, LDZ, LWORK,
*     $    REC
*
*      INTEGER, INTENT( OUT ) :: INFO
*
*      REAL, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
*     $    Z( LDZ, * ), ALPHAR( * ), ALPHAI( * ), BETA( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAQZ0 computes the eigenvalues of a real matrix pair (H,T),
*> where H is an upper Hessenberg matrix and T is upper triangular,
*> using the double-shift QZ method.
*> Matrix pairs of this type are produced by the reduction to
*> generalized upper Hessenberg form of a real matrix pair (A,B):
*>
*>    A = Q1*H*Z1**T,  B = Q1*T*Z1**T,
*>
*> as computed by SGGHRD.
*>
*> If JOB='S', then the Hessenberg-triangular pair (H,T) is
*> also reduced to generalized Schur form,
*>
*>    H = Q*S*Z**T,  T = Q*P*Z**T,
*>
*> where Q and Z are orthogonal matrices, P is an upper triangular
*> matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
*> diagonal blocks.
*>
*> The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
*> (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
*> eigenvalues.
*>
*> Additionally, the 2-by-2 upper triangular diagonal blocks of P
*> corresponding to 2-by-2 blocks of S are reduced to positive diagonal
*> form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
*> P(j,j) > 0, and P(j+1,j+1) > 0.
*>
*> Optionally, the orthogonal matrix Q from the generalized Schur
*> factorization may be postmultiplied into an input matrix Q1, and the
*> orthogonal matrix Z may be postmultiplied into an input matrix Z1.
*> If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced
*> the matrix pair (A,B) to generalized upper Hessenberg form, then the
*> output matrices Q1*Q and Z1*Z are the orthogonal factors from the
*> generalized Schur factorization of (A,B):
*>
*>    A = (Q1*Q)*S*(Z1*Z)**T,  B = (Q1*Q)*P*(Z1*Z)**T.
*>
*> To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
*> of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
*> complex and beta real.
*> If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
*> generalized nonsymmetric eigenvalue problem (GNEP)
*>    A*x = lambda*B*x
*> and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
*> alternate form of the GNEP
*>    mu*A*y = B*y.
*> Real eigenvalues can be read directly from the generalized Schur
*> form:
*>   alpha = S(i,i), beta = P(i,i).
*>
*> Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
*>      Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
*>      pp. 241--256.
*>
*> Ref: B. Kagstrom, D. Kressner, "Multishift Variants of the QZ
*>      Algorithm with Aggressive Early Deflation", SIAM J. Numer.
*>      Anal., 29(2006), pp. 199--227.
*>
*> Ref: T. Steel, D. Camps, K. Meerbergen, R. Vandebril "A multishift,
*>      multipole rational QZ method with agressive early deflation"
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] WANTS
*> \verbatim
*>          WANTS is CHARACTER*1
*>          = 'E': Compute eigenvalues only;
*>          = 'S': Compute eigenvalues and the Schur form.
*> \endverbatim
*>
*> \param[in] WANTQ
*> \verbatim
*>          WANTQ is CHARACTER*1
*>          = 'N': Left Schur vectors (Q) are not computed;
*>          = 'I': Q is initialized to the unit matrix and the matrix Q
*>                 of left Schur vectors of (A,B) is returned;
*>          = 'V': Q must contain an orthogonal matrix Q1 on entry and
*>                 the product Q1*Q is returned.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*>          WANTZ is CHARACTER*1
*>          = 'N': Right Schur vectors (Z) are not computed;
*>          = 'I': Z is initialized to the unit matrix and the matrix Z
*>                 of right Schur vectors of (A,B) is returned;
*>          = 'V': Z must contain an orthogonal matrix Z1 on entry and
*>                 the product Z1*Z is returned.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrices A, B, Q, and Z.  N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*>          ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*>          IHI is INTEGER
*>          ILO and IHI mark the rows and columns of A which are in
*>          Hessenberg form.  It is assumed that A is already upper
*>          triangular in rows and columns 1:ILO-1 and IHI+1:N.
*>          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA, N)
*>          On entry, the N-by-N upper Hessenberg matrix A.
*>          On exit, if JOB = 'S', A contains the upper quasi-triangular
*>          matrix S from the generalized Schur factorization.
*>          If JOB = 'E', the diagonal blocks of A match those of S, but
*>          the rest of A is unspecified.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max( 1, N ).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB, N)
*>          On entry, the N-by-N upper triangular matrix B.
*>          On exit, if JOB = 'S', B contains the upper triangular
*>          matrix P from the generalized Schur factorization;
*>          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
*>          are reduced to positive diagonal form, i.e., if A(j+1,j) is
*>          non-zero, then B(j+1,j) = B(j,j+1) = 0, B(j,j) > 0, and
*>          B(j+1,j+1) > 0.
*>          If JOB = 'E', the diagonal blocks of B match those of P, but
*>          the rest of B is unspecified.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max( 1, N ).
*> \endverbatim
*>
*> \param[out] ALPHAR
*> \verbatim
*>          ALPHAR is REAL array, dimension (N)
*>          The real parts of each scalar alpha defining an eigenvalue
*>          of GNEP.
*> \endverbatim
*>
*> \param[out] ALPHAI
*> \verbatim
*>          ALPHAI is REAL array, dimension (N)
*>          The imaginary parts of each scalar alpha defining an
*>          eigenvalue of GNEP.
*>          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
*>          positive, then the j-th and (j+1)-st eigenvalues are a
*>          complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*>          BETA is REAL array, dimension (N)
*>          The scalars beta that define the eigenvalues of GNEP.
*>          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
*>          beta = BETA(j) represent the j-th eigenvalue of the matrix
*>          pair (A,B), in one of the forms lambda = alpha/beta or
*>          mu = beta/alpha.  Since either lambda or mu may overflow,
*>          they should not, in general, be computed.
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*>          Q is REAL array, dimension (LDQ, N)
*>          On entry, if COMPQ = 'V', the orthogonal matrix Q1 used in
*>          the reduction of (A,B) to generalized Hessenberg form.
*>          On exit, if COMPQ = 'I', the orthogonal matrix of left Schur
*>          vectors of (A,B), and if COMPQ = 'V', the orthogonal matrix
*>          of left Schur vectors of (A,B).
*>          Not referenced if COMPQ = 'N'.
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*>          LDQ is INTEGER
*>          The leading dimension of the array Q.  LDQ >= 1.
*>          If COMPQ='V' or 'I', then LDQ >= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*>          Z is REAL array, dimension (LDZ, N)
*>          On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
*>          the reduction of (A,B) to generalized Hessenberg form.
*>          On exit, if COMPZ = 'I', the orthogonal matrix of
*>          right Schur vectors of (H,T), and if COMPZ = 'V', the
*>          orthogonal matrix of right Schur vectors of (A,B).
*>          Not referenced if COMPZ = 'N'.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*>          LDZ is INTEGER
*>          The leading dimension of the array Z.  LDZ >= 1.
*>          If COMPZ='V' or 'I', then LDZ >= N.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (MAX(1,LWORK))
*>          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.  LWORK >= max(1,N).
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[in] REC
*> \verbatim
*>          REC is INTEGER
*>             REC indicates the current recursion level. Should be set
*>             to 0 on first call.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*>          = 1,...,N: the QZ iteration did not converge.  (A,B) is not
*>                     in Schur form, but ALPHAR(i), ALPHAI(i), and
*>                     BETA(i), i=INFO+1,...,N should be correct.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Thijs Steel, KU Leuven
*
*> \date May 2020
*
*> \ingroup doubleGEcomputational
*>
*  =====================================================================
      RECURSIVE SUBROUTINE SLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
     $                             LDA, B, LDB, ALPHAR, ALPHAI, BETA,
     $                             Q, LDQ, Z, LDZ, WORK, LWORK, REC,
     $                             INFO )
      IMPLICIT NONE

*     Arguments
      CHARACTER, INTENT( IN ) :: WANTS, WANTQ, WANTZ
      INTEGER, INTENT( IN ) :: N, ILO, IHI, LDA, LDB, LDQ, LDZ, LWORK,
     $         REC

      INTEGER, INTENT( OUT ) :: INFO

      REAL, INTENT( INOUT ) :: A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
     $   Z( LDZ, * ), ALPHAR( * ), ALPHAI( * ), BETA( * ), WORK( * )

*     Parameters
      REAL :: ZERO, ONE, HALF
      PARAMETER( ZERO = 0.0, ONE = 1.0, HALF = 0.5 )

*     Local scalars
      REAL :: SMLNUM, ULP, ESHIFT, SAFMIN, SAFMAX, C1, S1, TEMP, SWAP
      INTEGER :: ISTART, ISTOP, IITER, MAXIT, ISTART2, K, LD, NSHIFTS,
     $           NBLOCK, NW, NMIN, NIBBLE, N_UNDEFLATED, N_DEFLATED,
     $           NS, SWEEP_INFO, SHIFTPOS, LWORKREQ, K2, ISTARTM,
     $           ISTOPM, IWANTS, IWANTQ, IWANTZ, NORM_INFO, AED_INFO,
     $           NWR, NBR, NSR, ITEMP1, ITEMP2, RCOST, I
      LOGICAL :: ILSCHUR, ILQ, ILZ
      CHARACTER :: JBCMPZ*3

*     External Functions
      EXTERNAL :: XERBLA, SHGEQZ, SLAQZ3, SLAQZ4, SLASET, SLABAD,
     $            SLARTG, SROT
      REAL, EXTERNAL :: SLAMCH
      LOGICAL, EXTERNAL :: LSAME
      INTEGER, EXTERNAL :: ILAENV

*
*     Decode wantS,wantQ,wantZ
*
      IF( LSAME( WANTS, 'E' ) ) THEN
         ILSCHUR = .FALSE.
         IWANTS = 1
      ELSE IF( LSAME( WANTS, 'S' ) ) THEN
         ILSCHUR = .TRUE.
         IWANTS = 2
      ELSE
         IWANTS = 0
      END IF

      IF( LSAME( WANTQ, 'N' ) ) THEN
         ILQ = .FALSE.
         IWANTQ = 1
      ELSE IF( LSAME( WANTQ, 'V' ) ) THEN
         ILQ = .TRUE.
         IWANTQ = 2
      ELSE IF( LSAME( WANTQ, 'I' ) ) THEN
         ILQ = .TRUE.
         IWANTQ = 3
      ELSE
         IWANTQ = 0
      END IF

      IF( LSAME( WANTZ, 'N' ) ) THEN
         ILZ = .FALSE.
         IWANTZ = 1
      ELSE IF( LSAME( WANTZ, 'V' ) ) THEN
         ILZ = .TRUE.
         IWANTZ = 2
      ELSE IF( LSAME( WANTZ, 'I' ) ) THEN
         ILZ = .TRUE.
         IWANTZ = 3
      ELSE
         IWANTZ = 0
      END IF
*
*     Check Argument Values
*
      INFO = 0
      IF( IWANTS.EQ.0 ) THEN
         INFO = -1
      ELSE IF( IWANTQ.EQ.0 ) THEN
         INFO = -2
      ELSE IF( IWANTZ.EQ.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( ILO.LT.1 ) THEN
         INFO = -5
      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.N ) THEN
         INFO = -8
      ELSE IF( LDB.LT.N ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
         INFO = -15
      ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
         INFO = -17
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLAQZ0', -INFO )
         RETURN
      END IF

*
*     Quick return if possible
*
      IF( N.LE.0 ) THEN
         WORK( 1 ) = REAL( 1 )
         RETURN
      END IF

*
*     Get the parameters
*
      JBCMPZ( 1:1 ) = WANTS
      JBCMPZ( 2:2 ) = WANTQ
      JBCMPZ( 3:3 ) = WANTZ

      NMIN = ILAENV( 12, 'SLAQZ0', JBCMPZ, N, ILO, IHI, LWORK )

      NWR = ILAENV( 13, 'SLAQZ0', JBCMPZ, N, ILO, IHI, LWORK )
      NWR = MAX( 2, NWR )
      NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )

      NIBBLE = ILAENV( 14, 'SLAQZ0', JBCMPZ, N, ILO, IHI, LWORK )

      NSR = ILAENV( 15, 'SLAQZ0', JBCMPZ, N, ILO, IHI, LWORK )
      NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
      NSR = MAX( 2, NSR-MOD( NSR, 2 ) )

      RCOST = ILAENV( 17, 'SLAQZ0', JBCMPZ, N, ILO, IHI, LWORK )
      ITEMP1 = INT( NSR/SQRT( 1+2*NSR/( REAL( RCOST )/100*N ) ) )
      ITEMP1 = ( ( ITEMP1-1 )/4 )*4+4
      NBR = NSR+ITEMP1

      IF( N .LT. NMIN .OR. REC .GE. 2 ) THEN
         CALL SHGEQZ( WANTS, WANTQ, WANTZ, N, ILO, IHI, A, LDA, B, LDB,
     $                ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
     $                LWORK, INFO )
         RETURN
      END IF

*
*     Find out required workspace
*

*     Workspace query to slaqz3
      NW = MAX( NWR, NMIN )
      CALL SLAQZ3( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW, A, LDA, B, LDB,
     $             Q, LDQ, Z, LDZ, N_UNDEFLATED, N_DEFLATED, ALPHAR,
     $             ALPHAI, BETA, WORK, NW, WORK, NW, WORK, -1, REC,
     $             AED_INFO )
      ITEMP1 = INT( WORK( 1 ) )
*     Workspace query to slaqz4
      CALL SLAQZ4( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NSR, NBR, ALPHAR,
     $             ALPHAI, BETA, A, LDA, B, LDB, Q, LDQ, Z, LDZ, WORK,
     $             NBR, WORK, NBR, WORK, -1, SWEEP_INFO )
      ITEMP2 = INT( WORK( 1 ) )

      LWORKREQ = MAX( ITEMP1+2*NW**2, ITEMP2+2*NBR**2 )
      IF ( LWORK .EQ.-1 ) THEN
         WORK( 1 ) = REAL( LWORKREQ )
         RETURN
      ELSE IF ( LWORK .LT. LWORKREQ ) THEN
         INFO = -19
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLAQZ0', INFO )
         RETURN
      END IF
*
*     Initialize Q and Z
*
      IF( IWANTQ.EQ.3 ) CALL SLASET( 'FULL', N, N, ZERO, ONE, Q, LDQ )
      IF( IWANTZ.EQ.3 ) CALL SLASET( 'FULL', N, N, ZERO, ONE, Z, LDZ )

*     Get machine constants
      SAFMIN = SLAMCH( 'SAFE MINIMUM' )
      SAFMAX = ONE/SAFMIN
      CALL SLABAD( SAFMIN, SAFMAX )
      ULP = SLAMCH( 'PRECISION' )
      SMLNUM = SAFMIN*( REAL( N )/ULP )

      ISTART = ILO
      ISTOP = IHI
      MAXIT = 3*( IHI-ILO+1 )
      LD = 0

      DO IITER = 1, MAXIT
         IF( IITER .GE. MAXIT ) THEN
            INFO = ISTOP+1
            GOTO 80
         END IF
         IF ( ISTART+1 .GE. ISTOP ) THEN
            ISTOP = ISTART
            EXIT
         END IF

*        Check deflations at the end
         IF ( ABS( A( ISTOP-1, ISTOP-2 ) ) .LE. MAX( SMLNUM,
     $      ULP*( ABS( A( ISTOP-1, ISTOP-1 ) )+ABS( A( ISTOP-2,
     $      ISTOP-2 ) ) ) ) ) THEN
            A( ISTOP-1, ISTOP-2 ) = ZERO
            ISTOP = ISTOP-2
            LD = 0
            ESHIFT = ZERO
         ELSE IF ( ABS( A( ISTOP, ISTOP-1 ) ) .LE. MAX( SMLNUM,
     $      ULP*( ABS( A( ISTOP, ISTOP ) )+ABS( A( ISTOP-1,
     $      ISTOP-1 ) ) ) ) ) THEN
            A( ISTOP, ISTOP-1 ) = ZERO
            ISTOP = ISTOP-1
            LD = 0
            ESHIFT = ZERO
         END IF
*        Check deflations at the start
         IF ( ABS( A( ISTART+2, ISTART+1 ) ) .LE. MAX( SMLNUM,
     $      ULP*( ABS( A( ISTART+1, ISTART+1 ) )+ABS( A( ISTART+2,
     $      ISTART+2 ) ) ) ) ) THEN
            A( ISTART+2, ISTART+1 ) = ZERO
            ISTART = ISTART+2
            LD = 0
            ESHIFT = ZERO
         ELSE IF ( ABS( A( ISTART+1, ISTART ) ) .LE. MAX( SMLNUM,
     $      ULP*( ABS( A( ISTART, ISTART ) )+ABS( A( ISTART+1,
     $      ISTART+1 ) ) ) ) ) THEN
            A( ISTART+1, ISTART ) = ZERO
            ISTART = ISTART+1
            LD = 0
            ESHIFT = ZERO
         END IF

         IF ( ISTART+1 .GE. ISTOP ) THEN
            EXIT
         END IF

*        Check interior deflations
         ISTART2 = ISTART
         DO K = ISTOP, ISTART+1, -1
            IF ( ABS( A( K, K-1 ) ) .LE. MAX( SMLNUM, ULP*( ABS( A( K,
     $         K ) )+ABS( A( K-1, K-1 ) ) ) ) ) THEN
               A( K, K-1 ) = ZERO
               ISTART2 = K
               EXIT
            END IF
         END DO

*        Get range to apply rotations to
         IF ( ILSCHUR ) THEN
            ISTARTM = 1
            ISTOPM = N
         ELSE
            ISTARTM = ISTART2
            ISTOPM = ISTOP
         END IF

*        Check infinite eigenvalues, this is done without blocking so might
*        slow down the method when many infinite eigenvalues are present
         K = ISTOP
         DO WHILE ( K.GE.ISTART2 )
            TEMP = ZERO
            IF( K .LT. ISTOP ) THEN
               TEMP = TEMP+ABS( B( K, K+1 ) )
            END IF
            IF( K .GT. ISTART2 ) THEN
               TEMP = TEMP+ABS( B( K-1, K ) )
            END IF

            IF( ABS( B( K, K ) ) .LT. MAX( SMLNUM, ULP*TEMP ) ) THEN
*              A diagonal element of B is negligable, move it
*              to the top and deflate it

               DO K2 = K, ISTART2+1, -1
                  CALL SLARTG( B( K2-1, K2 ), B( K2-1, K2-1 ), C1, S1,
     $                         TEMP )
                  B( K2-1, K2 ) = TEMP
                  B( K2-1, K2-1 ) = ZERO

                  CALL SROT( K2-2-ISTARTM+1, B( ISTARTM, K2 ), 1,
     $                       B( ISTARTM, K2-1 ), 1, C1, S1 )
                  CALL SROT( MIN( K2+1, ISTOP )-ISTARTM+1, A( ISTARTM,
     $                       K2 ), 1, A( ISTARTM, K2-1 ), 1, C1, S1 )
                  IF ( ILZ ) THEN
                     CALL SROT( N, Z( 1, K2 ), 1, Z( 1, K2-1 ), 1, C1,
     $                          S1 )
                  END IF

                  IF( K2.LT.ISTOP ) THEN
                     CALL SLARTG( A( K2, K2-1 ), A( K2+1, K2-1 ), C1,
     $                            S1, TEMP )
                     A( K2, K2-1 ) = TEMP
                     A( K2+1, K2-1 ) = ZERO

                     CALL SROT( ISTOPM-K2+1, A( K2, K2 ), LDA, A( K2+1,
     $                          K2 ), LDA, C1, S1 )
                     CALL SROT( ISTOPM-K2+1, B( K2, K2 ), LDB, B( K2+1,
     $                          K2 ), LDB, C1, S1 )
                     IF( ILQ ) THEN
                        CALL SROT( N, Q( 1, K2 ), 1, Q( 1, K2+1 ), 1,
     $                             C1, S1 )
                     END IF
                  END IF

               END DO

               IF( ISTART2.LT.ISTOP )THEN
                  CALL SLARTG( A( ISTART2, ISTART2 ), A( ISTART2+1,
     $                         ISTART2 ), C1, S1, TEMP )
                  A( ISTART2, ISTART2 ) = TEMP
                  A( ISTART2+1, ISTART2 ) = ZERO

                  CALL SROT( ISTOPM-( ISTART2+1 )+1, A( ISTART2,
     $                       ISTART2+1 ), LDA, A( ISTART2+1,
     $                       ISTART2+1 ), LDA, C1, S1 )
                  CALL SROT( ISTOPM-( ISTART2+1 )+1, B( ISTART2,
     $                       ISTART2+1 ), LDB, B( ISTART2+1,
     $                       ISTART2+1 ), LDB, C1, S1 )
                  IF( ILQ ) THEN
                     CALL SROT( N, Q( 1, ISTART2 ), 1, Q( 1,
     $                          ISTART2+1 ), 1, C1, S1 )
                  END IF
               END IF

               ISTART2 = ISTART2+1

            END IF
            K = K-1
         END DO

*        istart2 now points to the top of the bottom right
*        unreduced Hessenberg block
         IF ( ISTART2 .GE. ISTOP ) THEN
            ISTOP = ISTART2-1
            LD = 0
            ESHIFT = ZERO
            CYCLE
         END IF

         NW = NWR
         NSHIFTS = NSR
         NBLOCK = NBR

         IF ( ISTOP-ISTART2+1 .LT. NMIN ) THEN
*           Setting nw to the size of the subblock will make AED deflate
*           all the eigenvalues. This is slightly more efficient than just
*           using qz_small because the off diagonal part gets updated via BLAS.
            IF ( ISTOP-ISTART+1 .LT. NMIN ) THEN
               NW = ISTOP-ISTART+1
               ISTART2 = ISTART
            ELSE
               NW = ISTOP-ISTART2+1
            END IF
         END IF

*
*        Time for AED
*
         CALL SLAQZ3( ILSCHUR, ILQ, ILZ, N, ISTART2, ISTOP, NW, A, LDA,
     $                B, LDB, Q, LDQ, Z, LDZ, N_UNDEFLATED, N_DEFLATED,
     $                ALPHAR, ALPHAI, BETA, WORK, NW, WORK( NW**2+1 ),
     $                NW, WORK( 2*NW**2+1 ), LWORK-2*NW**2, REC,
     $                AED_INFO )

         IF ( N_DEFLATED > 0 ) THEN
            ISTOP = ISTOP-N_DEFLATED
            LD = 0
            ESHIFT = ZERO
         END IF

         IF ( 100*N_DEFLATED > NIBBLE*( N_DEFLATED+N_UNDEFLATED ) .OR.
     $      ISTOP-ISTART2+1 .LT. NMIN ) THEN
*           AED has uncovered many eigenvalues. Skip a QZ sweep and run
*           AED again.
            CYCLE
         END IF

         LD = LD+1

         NS = MIN( NSHIFTS, ISTOP-ISTART2 )
         NS = MIN( NS, N_UNDEFLATED )
         SHIFTPOS = ISTOP-N_DEFLATED-N_UNDEFLATED+1
*
*        Shuffle shifts to put double shifts in front
*        This ensures that we don't split up a double shift
*
         DO I = SHIFTPOS, SHIFTPOS+N_UNDEFLATED-1, 2
            IF( ALPHAI( I ).NE.-ALPHAI( I+1 ) ) THEN
*
               SWAP = ALPHAR( I )
               ALPHAR( I ) = ALPHAR( I+1 )
               ALPHAR( I+1 ) = ALPHAR( I+2 )
               ALPHAR( I+2 ) = SWAP

               SWAP = ALPHAI( I )
               ALPHAI( I ) = ALPHAI( I+1 )
               ALPHAI( I+1 ) = ALPHAI( I+2 )
               ALPHAI( I+2 ) = SWAP

               SWAP = BETA( I )
               BETA( I ) = BETA( I+1 )
               BETA( I+1 ) = BETA( I+2 )
               BETA( I+2 ) = SWAP
            END IF
         END DO

         IF ( MOD( LD, 6 ) .EQ. 0 ) THEN
*
*           Exceptional shift.  Chosen for no particularly good reason.
*
            IF( ( REAL( MAXIT )*SAFMIN )*ABS( A( ISTOP,
     $         ISTOP-1 ) ).LT.ABS( A( ISTOP-1, ISTOP-1 ) ) ) THEN
               ESHIFT = A( ISTOP, ISTOP-1 )/B( ISTOP-1, ISTOP-1 )
            ELSE
               ESHIFT = ESHIFT+ONE/( SAFMIN*REAL( MAXIT ) )
            END IF
            ALPHAR( SHIFTPOS ) = ONE
            ALPHAR( SHIFTPOS+1 ) = ZERO
            ALPHAI( SHIFTPOS ) = ZERO
            ALPHAI( SHIFTPOS+1 ) = ZERO
            BETA( SHIFTPOS ) = ESHIFT
            BETA( SHIFTPOS+1 ) = ESHIFT
            NS = 2
         END IF

*
*        Time for a QZ sweep
*
         CALL SLAQZ4( ILSCHUR, ILQ, ILZ, N, ISTART2, ISTOP, NS, NBLOCK,
     $                ALPHAR( SHIFTPOS ), ALPHAI( SHIFTPOS ),
     $                BETA( SHIFTPOS ), A, LDA, B, LDB, Q, LDQ, Z, LDZ,
     $                WORK, NBLOCK, WORK( NBLOCK**2+1 ), NBLOCK,
     $                WORK( 2*NBLOCK**2+1 ), LWORK-2*NBLOCK**2,
     $                SWEEP_INFO )

      END DO

*
*     Call SHGEQZ to normalize the eigenvalue blocks and set the eigenvalues
*     If all the eigenvalues have been found, SHGEQZ will not do any iterations
*     and only normalize the blocks. In case of a rare convergence failure,
*     the single shift might perform better.
*
   80 CALL SHGEQZ( WANTS, WANTQ, WANTZ, N, ILO, IHI, A, LDA, B, LDB,
     $             ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK,
     $             NORM_INFO )

      INFO = NORM_INFO

      END SUBROUTINE


!---Calculate the l2 norm of the precursor soln

subroutine l2_norm(nl_iter)

    USE flags_M
    USE global_parameters_M
    USE solution_vectors_M
    USE time_info_M
    USE mesh_info_M
    USE material_info_M

    use Mod_SetupOutputFiles

    implicit none

    !---Dummy
    integer, intent(in)    :: nl_iter

    !---Local
    integer  :: f,g,n,i,j
    real(dp) :: nl_iter_tolerance, difference_L2
    integer  :: abs_max_nl_iter
    integer  :: difference_counter

    !---Describe absolute default tolerances
    max_nl_iter = 500
    abs_max_nl_iter = 600
    nl_iter_tolerance = 1E-4_dp

    !---Reset the difference counters
    L2_diffs_precursors(:,:) = 0.0
    L2_diffs_temperature     = 0.0
    L2_current_precursors    = 0.0

    !---Calculate L2 norm of precursor solution
    if(nl_iter > 1) then
        do f = 1, num_isotopes
            do g = 1, num_delay_group
                do i = 1, num_elem
                    do j = 1, nodes_per_elem
                        !---Calculate current sum of the squares
                        L2_current_precursors(f,g) = L2_current_precursors(f,g) + &
                            precursor_soln_new(f,g,i,j)*precursor_soln_new(f,g,i,j)

                        !---Calculate SUM([Current - Previous]^2)
                        L2_diffs_precursors(f,g) = L2_diffs_precursors(f,g) + &
                            (precursor_soln_new(f,g,i,j) - precursor_soln_prev(f,g,i,j) )*&
                            (precursor_soln_new(f,g,i,j) - precursor_soln_prev(f,g,i,j) )
                    end do
                end do

                !---Get the current L2
                L2_current_precursors(f,g) = sqrt(L2_current_precursors(f,g))
                !---Get sqrt of the sum of the differences
                L2_diffs_precursors(f,g)   = sqrt(L2_diffs_precursors(f,g))
            end do
        end do

        !---Calculate L2 norm for the temperature
        do i = 1, num_elem
            do j = 1, nodes_per_elem
                !--Calculate current sum of squares
                L2_current_temperature = L2_current_temperature + &
                         temperature_soln_new(i,j)*temperature_soln_new(i,j)

                !---SUM of the square differences
                L2_diffs_temperature = L2_diffs_temperature + &
                        (temperature_soln_new(i,j) - temperature_soln_prev(i,j))*&
                        (temperature_soln_new(i,j) - temperature_soln_prev(i,j))
            end do
        end do

        !---Check if temperature has converged
        if(L2_diffs_temperature < nl_iter_tolerance*L2_current_temperature) then
            temperature_converged = .TRUE.
        end if

        !---Reset the difference counter
        difference_counter = 0

        !---Check if the convergence criteria has been reached for all groups
        do f = 1, num_isotopes
           do g = 1, num_delay_group
                !---Evaluate ||Current - Previous|| < tolerance * ||Current||
                if(L2_diffs_precursors(f,g) < nl_iter_tolerance*&
                   L2_current_precursors(f,g)) then

                    difference_counter = difference_counter + 1

                end if
           end do
        end do

        !---Need to make sure the L2 norm converges for all precursor groups
        if ( difference_counter == num_delay_group) then
            max_nl_iter = nl_iter - 1
        end if

    !---Swap for next iteration
        L2_prev_precursors  = L2_current_precursors
        L2_prev_temperature = L2_current_temperature
    end if

    !---Check if too many nonlinear iterations and not converging
    if ( nl_iter > max_nl_iter) then
        if(nl_iter > abs_max_nl_iter) then
            write(outfile_unit,fmt=('(a)')) 'Gone past max amount of &
                         nonlinear iterations &
                         and might have a problem'
        else
            if (DEBUG .eqv. .TRUE.) then
                write(outfile_unit,fmt=('(a,I3,a,8es14.3)')) &
                'Took this # of iterations to converge --> ',nl_iter,&
                '  <-- at time step -->', t0
            end if
        end if

        nl_iter_flag = .FALSE.

    !---Write to outfile
        if(DEBUG .eqv. .TRUE.) then
            do f = 1, num_isotopes
                write(nl_outfile_unit,fmt=('(I6,8es14.5,8es14.5,8es14.5,8es14.5,&
                                     8es14.5,8es14.5,8es14.5)'))&
                nl_iter,L2_current_precursors(1,1),L2_diffs_temperature,(L2_diffs_precursors(f,g), g=1,num_delay_group)
            end do
        end if
    end if

end subroutine l2_norm


   PROGRAM GALAHAD_L2RT_EXAMPLE   !  GALAHAD 2.2 - 05/06/2008 AT 10:45 GMT.
   USE GALAHAD_L2RT_DOUBLE                            ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: working = KIND( 1.0D+0 )     ! set precision
   REAL ( KIND = working ), PARAMETER :: one = 1.0_working
   INTEGER, PARAMETER :: n = 50, m = 2 * n            ! problem dimensions
   INTEGER :: i
   REAL ( KIND = working ) :: p = 3.0_working         ! order of regulatisation
   REAL ( KIND = working ) :: sigma = 1.0_working     ! regulatisation weight
   REAL ( KIND = working ) :: mu = 0.0_working        ! zero shift
   REAL ( KIND = working ), DIMENSION( n ) :: X, V
   REAL ( KIND = working ), DIMENSION( m ) :: U, RES
   TYPE ( L2RT_data_type ) :: data
   TYPE ( L2RT_control_type ) :: control
   TYPE ( L2RT_inform_type ) :: inform
   CALL L2RT_initialize( data, control )  ! Initialize control parameters
   control%fraction_opt = 0.99            ! Only require 99% of the best
   U = one                                ! The term b is a vector of ones
   inform%status = 1
   DO                                     ! Iteration to find the minimizer
      CALL L2RT_solve( m, n, p, sigma, mu, X, U, V, data, control, inform )
      SELECT CASE( inform%status )  !  Branch as a result of inform%status
      CASE( 2 )                     !  Form u <- u + A * v
        U( : n ) = U( : n ) + V     !  A^T = ( I : diag(1:n) )
        DO i = 1, n
          U( n + i ) = U( n + i ) + i * V( i )
        END DO
      CASE( 3 )                     !  Form v <- v + A^T * u
        V = V + U( : n )
         DO i = 1, n
           V( i ) = V( i ) + i * U( n + i )
         END DO
      CASE ( 4 )                    !  Restart
         U = one                    !  re-initialize u to b
      CASE ( 0 )                    !  Successful return
         RES = one                  !  Compute the residuals for checking
         RES( : n )  = RES( : n ) - X
         DO i = 1, n
            RES( n + i ) = RES( n + i ) - i * X( i )
         END DO
         WRITE( 6, "( 1X, I0, ' 1st pass and ', I0, ' 2nd pass iterations' )" ) &
           inform%iter, inform%iter_pass2
         WRITE( 6, "( ' objective recurred and calculated = ', 2ES16.8 )" )     &
           inform%obj, SQRT( DOT_PRODUCT( RES, RES ) +                          &
             mu * SQRT( DOT_PRODUCT( X, X ) ) ** 2 ) + ( sigma / p ) *          &
           ( SQRT( DOT_PRODUCT( X, X ) ) ) ** p
         WRITE( 6, "( '    ||x||  recurred and calculated = ', 2ES16.8 )" )     &
           inform%x_norm, SQRT( DOT_PRODUCT( X, X ) )
         WRITE( 6, "( '  ||Ax-b|| recurred and calculated = ', 2ES16.8 )" )     &
           inform%r_norm, SQRT( DOT_PRODUCT( RES, RES ) )
         CALL L2RT_terminate( data, control, inform ) ! delete internal workspace
         EXIT
      CASE DEFAULT                  !  Error returns
         WRITE( 6, "( ' L2RT_solve exit status = ', I6 ) " ) inform%status
         CALL L2RT_terminate( data, control, inform ) ! delete internal workspace
         EXIT
      END SELECT
   END DO
   END PROGRAM GALAHAD_L2RT_EXAMPLE