!==========================================================================
elemental function gsw_internal_energy (sa, ct, p)
!==========================================================================
!
!  Calculates specific internal energy of seawater.
!
!  sa     : Absolute Salinity                               [g/kg]
!  ct     : Conservative Temperature                       [deg C]
!  p      : sea pressure                                    [dbar]
!
!  gsw_internal_energy  :  internal_energy of seawater    [ J/kg ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_enthalpy, gsw_specvol

use gsw_mod_teos10_constants, only : gsw_p0, db2pa

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p

real (r8) :: gsw_internal_energy

gsw_internal_energy = gsw_enthalpy(sa,ct,p) - &
				(gsw_p0 + db2pa*p)*gsw_specvol(sa,ct,p)
return
end function

!--------------------------------------------------------------------------


      SUBROUTINE MB04PA( LHAM, N, K, NB, A, LDA, QG, LDQG, XA, LDXA,
     $                   XG, LDXG, XQ, LDXQ, YA, LDYA, CS, TAU, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce a Hamiltonian like matrix
C
C                   [  A   G  ]           T          T
C              H =  [       T ] ,    G = G ,    Q = Q,
C                   [  Q  -A  ]
C
C     or a skew-Hamiltonian like matrix
C
C                   [  A   G  ]            T          T
C              W =  [       T ] ,    G = -G ,   Q = -Q,
C                   [  Q   A  ]
C
C     so that elements below the (k+1)-th subdiagonal in the first nb
C     columns of the (k+n)-by-n matrix A, and offdiagonal elements
C     in the first nb columns and rows of the n-by-n matrix Q are zero.
C
C     The reduction is performed by an orthogonal symplectic
C     transformation UU'*H*UU and matrices U, XA, XG, XQ, and YA are
C     returned so that
C
C                    [ Aout + U*XA'+ YA*U'   Gout + U*XG'+ XG*U' ]
C         UU'*H*UU = [                                           ].
C                    [ Qout + U*XQ'+ XQ*U'  -Aout'- XA*U'- U*YA' ]
C
C     Similarly,
C
C                    [ Aout + U*XA'+ YA*U'   Gout + U*XG'- XG*U' ]
C         UU'*W*UU = [                                           ].
C                    [ Qout + U*XQ'- XQ*U'   Aout'+ XA*U'+ U*YA' ]
C
C     This is an auxiliary routine called by MB04PB.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LHAM    LOGICAL
C             Specifies the type of matrix to be reduced:
C             = .FALSE. :  skew-Hamiltonian like W;
C             = .TRUE.  :  Hamiltonian like H.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     K       (input) INTEGER
C             The offset of the reduction. Elements below the (K+1)-th
C             subdiagonal in the first NB columns of A are reduced
C             to zero.  K >= 0.
C
C     NB      (input) INTEGER
C             The number of columns/rows to be reduced.  N > NB >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading (K+N)-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading (K+N)-by-N part of this array
C             contains the matrix Aout and in the zero part
C             information about the elementary reflectors used to
C             compute the reduction.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,K+N).
C
C     QG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDQG,N+1)
C             On entry, the leading N+K-by-N+1 part of this array must
C             contain in the bottom left part the lower triangular part
C             of the N-by-N matrix Q and in the remainder the upper
C             trapezoidal part of the last N columns of the N+K-by-N+K
C             matrix G.
C             On exit, the leading N+K-by-N+1 part of this array
C             contains parts of the matrices Q and G in the same fashion
C             as on entry only that the zero parts of Q contain
C             information about the elementary reflectors used to
C             compute the reduction. Note that if LHAM = .FALSE. then
C             the (K-1)-th and K-th subdiagonals are not referenced.
C
C     LDQG    INTEGER
C             The leading dimension of the array QG. LDQG >= MAX(1,N+K).
C
C     XA      (output) DOUBLE PRECISION array, dimension (LDXA,2*NB)
C             On exit, the leading N-by-(2*NB) part of this array
C             contains the matrix XA.
C
C     LDXA    INTEGER
C             The leading dimension of the array XA.  LDXA >= MAX(1,N).
C
C     XG      (output) DOUBLE PRECISION array, dimension (LDXG,2*NB)
C             On exit, the leading (K+N)-by-(2*NB) part of this array
C             contains the matrix XG.
C
C     LDXG    INTEGER
C             The leading dimension of the array XG. LDXG >= MAX(1,K+N).
C
C     XQ      (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB)
C             On exit, the leading N-by-(2*NB) part of this array
C             contains the matrix XQ.
C
C     LDXQ    INTEGER
C             The leading dimension of the array XQ.  LDXQ >= MAX(1,N).
C
C     YA      (output) DOUBLE PRECISION array, dimension (LDYA,2*NB)
C             On exit, the leading (K+N)-by-(2*NB) part of this array
C             contains the matrix YA.
C
C     LDYA    INTEGER
C             The leading dimension of the array YA. LDYA >= MAX(1,K+N).
C
C     CS      (output) DOUBLE PRECISION array, dimension (2*NB)
C             On exit, the first 2*NB elements of this array contain the
C             cosines and sines of the symplectic Givens rotations used
C             to compute the reduction.
C
C     TAU     (output) DOUBLE PRECISION array, dimension (NB)
C             On exit, the first NB elements of this array contain the
C             scalar factors of some of the elementary reflectors.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (3*NB)
C
C     METHOD
C
C     For details regarding the representation of the orthogonal
C     symplectic matrix UU within the arrays A, QG, CS, TAU see the
C     description of MB04PU.
C
C     The contents of A and QG on exit are illustrated by the following
C     example with n = 5, k = 2 and nb = 2:
C
C           ( a  r  r  a  a  )         ( g  g  r  r  g  g  )
C           ( a  r  r  a  a  )         ( g  g  r  r  g  g  )
C           ( a  r  r  a  a  )         ( q  g  r  r  g  g  )
C       A = ( r  r  r  r  r  ),   QG = ( t  r  r  r  r  r  ),
C           ( u2 r  r  r  r  )         ( u1 t  r  r  r  r  )
C           ( u2 u2 r  a  a  )         ( u1 u1 r  q  g  g  )
C           ( u2 u2 r  a  a  )         ( u1 u1 r  q  q  g  )
C
C     where a, g and q denote elements of the original matrices, r
C     denotes a modified element, t denotes a scalar factor of an
C     applied elementary reflector and ui denote elements of the
C     matrix U.
C
C     REFERENCES
C
C     [1] C. F. VAN LOAN:
C         A symplectic method for approximating all the eigenvalues of
C         a Hamiltonian matrix.
C         Linear Algebra and its Applications, 61, pp. 233-251, 1984.
C
C     [2] D. KRESSNER:
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner (Technical Univ. Berlin, Germany) and
C     P. Benner (Technical Univ. Chemnitz, Germany), December 2003.
C
C     REVISIONS
C
C     V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DLAPVL).
C
C     KEYWORDS
C
C     Elementary matrix operations, Hamiltonian matrix,
C     skew-Hamiltonian matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, HALF
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D+0 )
C     .. Scalar Arguments ..
      LOGICAL           LHAM
      INTEGER           K, LDA, LDQG, LDXA, LDXG, LDXQ, LDYA, N, NB
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*),
     $                  XA(LDXA,*), XG(LDXG,*), XQ(LDXQ,*), YA(LDYA,*)
C     .. Local Scalars ..
      INTEGER           I, J, NB1, NB2
      DOUBLE PRECISION  AKI, ALPHA, C, S, TAUQ, TEMP, TTEMP
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL,
     $                  DSYMV, MB01MD
C     .. Intrinsic Functions ..
      INTRINSIC         MIN
C
C     .. Executable Statements ..
C
C     Quick return if possible.
C
      IF ( N+K.LE.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      NB1 = NB + 1
      NB2 = NB + NB1
C
      IF ( LHAM ) THEN
         DO 50  I = 1, NB
C
C           Transform i-th columns of A and Q. See routine MB04PU.
C
            ALPHA = QG(K+I+1,I)
            CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ )
            QG(K+I+1,I) = ONE
            TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 )
            CALL DAXPY( N-I, TEMP,  QG(K+I+1,I), 1, A(K+I+1,I), 1 )
            AKI = A(K+I+1,I)
            CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) )
            AKI = A(K+I+1,I)
            CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) )
            A(K+I+1,I) = ONE
C
C           Update XA with first Householder reflection.
C
C           xa = H(1:n,1:n)'*u1
            CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA,
     $                  QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 )
C           w1 = U1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG,
     $                  QG(K+I+1,I), 1, ZERO, DWORK, 1 )
C           xa = xa + XA1*w1
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA,
     $                  DWORK, 1, ONE, XA(I+1,I), 1 )
C           w2 = U2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 )
C           xa = xa + XA2*w2
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
     $                  LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 )
C           temp = YA1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA,
     $                  QG(K+I+1,I), 1, ZERO, XA(1,I), 1 )
C           xa = xa + U1*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1),
     $                  LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 )
C           temp = YA2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA,
     $                  QG(K+I+1,I), 1, ZERO, XA(1,I), 1 )
C           xa = xa + U2*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  XA(1,I), 1, ONE, XA(I+1,I), 1 )
C           xa = -tauq*xa
            CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 )
C
C           Update YA with first Householder reflection.
C
C           ya = H(1:n,1:n)*u1
            CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA,
     $                  QG(K+I+1,I), 1, ZERO, YA(1,I), 1 )
C           temp = XA1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA,
     $                  QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 )
C           ya = ya + U1*temp
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1),
     $                  LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 )
C           temp = XA2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA,
     $                  QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 )
C           ya = ya + U2*temp
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 )
C           ya = ya + YA1*w1
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA,
     $                  DWORK, 1, ONE, YA(1,I), 1 )
C           ya = ya + YA2*w2
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
     $                  DWORK(NB1), 1, ONE, YA(1,I), 1 )
C           ya = -tauq*ya
            CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 )
C           temp = -tauq*ya'*u1
            TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 )
C           ya = ya + temp*u1
            CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 )
C
C           Update (i+1)-th column of A.
C
C           A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG,
     $                  XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 )
C           A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 )
C           A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)';
            CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA,
     $                  QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 )
C           A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)';
            CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA,
     $                  A(K+I+1,1), LDA, ONE, A(1,I+1), 1 )
C
C           Update (i+1)-th row of A.
C
            IF ( N.GT.I+1 ) THEN
C              A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)'
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1),
     $                     LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2),
     $                     LDA )
C              A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)'
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1),
     $                     LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2),
     $                     LDA )
C              A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)'
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                     LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2),
     $                     LDA )
C              A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)'
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2),
     $                     LDA )
            END IF
C
C           Annihilate updated parts in YA.
C
            DO 10  J = 1, I
               YA(K+I+1,J) = ZERO
   10       CONTINUE
            DO 20  J = 1, I-1
               YA(K+I+1,NB+J) = ZERO
   20       CONTINUE
C
C           Update XQ with first Householder reflection.
C
C           xq = Q*u1
            CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG,
     $                  QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 )
C           xq = xq + XQ1*w1
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ,
     $                  DWORK, 1, ONE, XQ(I+1,I), 1 )
C           xq = xq + XQ2*w2
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
     $                  LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 )
C           temp = XQ1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ,
     $                  QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 )
C           xq = xq + U1*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1),
     $                  LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 )
C           temp = XQ2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ,
     $                  QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 )
C           xq = xq + U2*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  XQ(1,I), 1, ONE, XQ(I+1,I), 1 )
C           xq = -tauq*xq
            CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 )
C           temp = -tauq/2*xq'*u1
            TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 )
C           xq = xq + temp*u1
            CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 )
C
C           Update (i+1)-th column and row of Q.
C
C           Q(:,i+1) = Q(:,i+1) + U1 * XQ1(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG,
     $                  XQ(I+1,1), LDXQ, ONE, QG(K+I+1,I+1), 1 )
C           Q(:,i+1) = Q(:,i+1) + U2 * XQ2(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  XQ(I+1,NB1), LDXQ, ONE, QG(K+I+1,I+1), 1 )
C           Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
     $                  QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+1), 1 )
C           Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
     $                  LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+1), 1 )
C
C           Update XG with first Householder reflection.
C
C           xg = G*u1
            CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG,
     $                  QG(K+I+1,I), 1, ZERO, XG(1,I), 1 )
            CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG,
     $                  QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 )
C           xg = xg + XG1*w1
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG,
     $                  DWORK, 1, ONE, XG(1,I), 1 )
C           xg = xg + XG2*w2
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
     $                  LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 )
C           temp = XG1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ,
     $                  QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 )
C           xg = xg + U1*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1),
     $                  LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 )
C           temp = XG2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1),
     $                  LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 )
C           xg = xg + U2*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 )
C           xg = -tauq*xg
            CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 )
C           temp = -tauq/2*xq'*u1
            TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I),
     $                              1 )
C           xg = xg + temp*u1
            CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 )
C
C           Update (i+1)-th column and row of G.
C
C           G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)';
            CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG,
     $                  QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 )
C           G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)';
            CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG,
     $                  A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 )
C           G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I, ONE, XG(K+I+1,1), LDXG,
     $                  QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+2), LDQG )
C           G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XG(K+I+1,NB1),
     $                  LDXG, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+2),
     $                  LDQG )
C           G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG,
     $                  XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+2), LDQG )
C           G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+2), LDQG )
C
C           Annihilate updated parts in XG.
C
            DO 30  J = 1, I
               XG(K+I+1,J) = ZERO
   30       CONTINUE
            DO 40  J = 1, I-1
               XG(K+I+1,NB+J) = ZERO
   40       CONTINUE
C
C           Apply orthogonal symplectic Givens rotation.
C
            CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S )
            IF ( N.GT.I+1 ) THEN
               CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG,
     $                    C, S )
               CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, C,
     $                    S )
            END IF
            TEMP  = A(K+I+1,I+1)
            TTEMP = QG(K+I+1,I+2)
            A(K+I+1,I+1)  = C*TEMP  + S*QG(K+I+1,I+1)
            QG(K+I+1,I+2) = C*TTEMP - S*TEMP
            QG(K+I+1,I+1) = -S*TEMP + C*QG(K+I+1,I+1)
            TTEMP = -S*TTEMP - C*TEMP
            TEMP  = A(K+I+1,I+1)
            QG(K+I+1,I+1) =  C*QG(K+I+1,I+1) + S*TTEMP
            A(K+I+1,I+1)  =  C*TEMP + S*QG(K+I+1,I+2)
            QG(K+I+1,I+2) = -S*TEMP + C*QG(K+I+1,I+2)
            CS(2*I-1) = C
            CS(2*I)   = S
            QG(K+I+1,I) = TAUQ
C
C           Update XA with second Householder reflection.
C
C           xa = H(1:n,1:n)'*u2
            CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA,
     $                  A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 )
            IF ( N.GT.I+1 ) THEN
C              w1 = U1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                    LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 )
C              xa = xa + XA1*w1
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1),
     $                     LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 )
C              w2 = U2'*u2
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 )
C              xa = xa + XA2*w2
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1),
     $                     LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 )
C              temp = YA1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1),
     $                     LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 )
C              xa = xa + U1*temp
               CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                     LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 )
C              temp = YA2'*u1
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1),
     $                     LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 )
C              xa = xa + U2*temp
               CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 )
            END IF
C           xa = -tau*xa
            CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 )
C
C           Update YA with second Householder reflection.
C
C           ya = H(1:n,1:n)*u2
            CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA,
     $                  A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 )
            IF ( N.GT.I+1 ) THEN
C              temp = XA1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA,
     $                     A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 )
C              ya = ya + U1*temp
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                     LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 )
C              temp = XA2'*u1
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1),
     $                     LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 )
C              ya = ya + U2*temp
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 )
            END IF
C           ya = ya + YA1*w1
            CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
     $                     DWORK, 1, ONE, YA(1,NB+I), 1 )
C           ya = ya + YA2*w2
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
     $                  DWORK(NB1), 1, ONE, YA(1,NB+I), 1 )
C           ya = -tau*ya
            CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 )
C           temp = -tau*ya'*u2
            TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 )
C           ya = ya + temp*u2
            CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 )
C
C           Update (i+1)-th column of A.
C
C           H(1:n,i+1) = H(1:n,i+1) + ya
            CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 )
C           H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2
            CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1),
     $                  1 )
C
C           Update (i+1)-th row of A.
C
            IF ( N.GT.I+1 ) THEN
C              H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)';
               CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2),
     $                     LDA )
C              H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)'
               CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1,
     $                     A(K+I+1,I+2), LDA )
            END IF
C
C           Annihilate updated parts in YA.
C
            YA(K+I+1,NB+I) = ZERO
C
C           Update XQ with second Householder reflection.
C
C           xq = Q*u2
            CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG,
     $                  A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 )
            IF ( N.GT.I+1 ) THEN
C              xq = xq + XQ1*w1
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1),
     $                     LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 )
C              xq = xq + XQ2*w2
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1),
     $                     LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 )
C              temp = XQ1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ,
     $                     A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 )
C              xq = xq + U1*temp
               CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                     LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 )
C              temp = XQ2'*u2
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1),
     $                     LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 )
C              xq = xq + U2*temp
               CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 )
            END IF
C           xq = -tauq*xq
            CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 )
C           temp = -tauq/2*xq'*u2
            TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I),
     $                              1 )
C           xq = xq + temp*u2
            CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 )
C
C           Update (i+1)-th column and row of Q.
C
            CALL DAXPY( N-I, ONE, XQ(I+1,NB+I), 1, QG(K+I+1,I+1), 1 )
C           H(1:n,n+i+1) = H(1:n,n+i+1) + U * XQ(i+1,:)';
            CALL DAXPY( N-I, XQ(I+1,NB+I), A(K+I+1,I), 1,
     $                  QG(K+I+1,I+1), 1 )
C
C           Update XG with second Householder reflection.
C
C           xg = G*u2
            CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG,
     $                  A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 )
            CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG,
     $                  A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 )
C           xg = xg + XG1*w1
            CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
     $                  DWORK, 1, ONE, XG(1,NB+I), 1 )
C           xg = xg + XG2*w2
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
     $                  LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 )
            IF ( N.GT.I+1 ) THEN
C              temp = XG1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1),
     $                     LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 )
C              xg = xg + U1*temp
               CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                     LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 )
C              temp = XG2'*u2
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1),
     $                     LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 )
C              xg = xg + U2*temp
               CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 )
            END IF
C           xg = -tauq*xg
            CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 )
C           temp = -tauq/2*xg'*u1
            TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1,
     $                                XG(K+I+1,NB+I), 1 )
C           xg = xg + temp*u1
            CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 )
C
C           Update (i+1)-th column and row of G.
C
            CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 )
            CALL DAXPY( N-I, ONE, XG(K+I+1,NB+I), 1, QG(K+I+1,I+2),
     $                  LDQG )
            CALL DAXPY( N-I, XG(K+I+1,NB+I), A(K+I+1,I), 1,
     $                  QG(K+I+1,I+2), LDQG )
C
C           Annihilate updated parts in XG.
C
            XG(K+I+1,NB+I) = ZERO
C
            A(K+I+1,I) = AKI
   50    CONTINUE
      ELSE
         DO 100  I = 1, NB
C
C           Transform i-th columns of A and Q.
C
            ALPHA = QG(K+I+1,I)
            CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ )
            QG(K+I+1,I) = ONE
            TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 )
            CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 )
            AKI = A(K+I+1,I)
            CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) )
            AKI = A(K+I+1,I)
            CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) )
            A(K+I+1,I) = ONE
C
C           Update XA with first Householder reflection.
C
C           xa = H(1:n,1:n)'*u1
            CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA,
     $                  QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 )
C           w1 = U1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG,
     $                  QG(K+I+1,I), 1, ZERO, DWORK, 1 )
C           xa = xa + XA1*w1
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA,
     $                  DWORK, 1, ONE, XA(I+1,I), 1 )
C           w2 = U2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 )
C           xa = xa + XA2*w2
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
     $                  LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 )
C           temp = YA1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA,
     $                  QG(K+I+1,I), 1, ZERO, XA(1,I), 1 )
C           xa = xa + U1*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1),
     $                  LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 )
C           temp = YA2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA,
     $                  QG(K+I+1,I), 1, ZERO, XA(1,I), 1 )
C           xa = xa + U2*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  XA(1,I), 1, ONE, XA(I+1,I), 1 )
C           xa = -tauq*xa
            CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 )
C
C           Update YA with first Householder reflection.
C
C           ya = H(1:n,1:n)*u1
            CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA,
     $                  QG(K+I+1,I), 1, ZERO, YA(1,I), 1 )
C           temp = XA1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA,
     $                  QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 )
C           ya = ya + U1*temp
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1),
     $                  LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 )
C           temp = XA2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA,
     $                  QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 )
C           ya = ya + U2*temp
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 )
C           ya = ya + YA1*w1
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA,
     $                  DWORK, 1, ONE, YA(1,I), 1 )
C           ya = ya + YA2*w2
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
     $                  DWORK(NB1), 1, ONE, YA(1,I), 1 )
C           ya = -tauq*ya
            CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 )
C           temp = -tauq*ya'*u1
            TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 )
C           ya = ya + temp*u1
            CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 )
C
C           Update (i+1)-th column of A.
C
C           A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG,
     $                  XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 )
C           A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)';
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
     $                  XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 )
C           A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)';
            CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA,
     $                  QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 )
C           A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)';
            CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA,
     $                  A(K+I+1,1), LDA, ONE, A(1,I+1), 1 )
C
C           Update (i+1)-th row of A.
C
            IF ( N.GT.I+1 ) THEN
C              A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)'
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1),
     $                     LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2),
     $                     LDA )
C              A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)'
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1),
     $                     LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2),
     $                     LDA )
C              A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)'
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                     LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2),
     $                     LDA )
C              A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)'
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2),
     $                     LDA )
            END IF
C
C           Annihilate updated parts in YA.
C
            DO 60  J = 1, I
               YA(K+I+1,J) = ZERO
   60       CONTINUE
            DO 70  J = 1, I-1
               YA(K+I+1,NB+J) = ZERO
   70       CONTINUE
C
C           Update XQ with first Householder reflection.
C
C           xq = Q*u1
            CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG,
     $                  QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 )
C           xq = xq + XQ1*w1
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ,
     $                  DWORK, 1, ONE, XQ(I+1,I), 1 )
C           xq = xq + XQ2*w2
            CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
     $                  LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 )
C           temp = XQ1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ,
     $                  QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 )
C           xq = xq - U1*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1),
     $                  LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 )
C           temp = XQ2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ,
     $                  QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 )
C           xq = xq - U2*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA,
     $                  XQ(1,I), 1, ONE, XQ(I+1,I), 1 )
C           xq = -tauq*xq
            CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 )
C           temp = -tauq/2*xq'*u1
            TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 )
C           xq = xq + temp*u1
            CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 )
C
C           Update (i+1)-th column and row of Q.
C
            IF ( N.GT.I+1 ) THEN
C              Q(:,i+1) = Q(:,i+1) - U1 * XQ1(i+1,:)';
               CALL DGEMV( 'No transpose', N-I-1, I, -ONE, QG(K+I+2,1),
     $                     LDQG, XQ(I+1,1), LDXQ, ONE, QG(K+I+2,I+1),
     $                     1 )
C              Q(:,i+1) = Q(:,i+1) - U2 * XQ2(i+1,:)';
               CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, A(K+I+2,1),
     $                     LDA, XQ(I+1,NB1), LDXQ, ONE, QG(K+I+2,I+1),
     $                     1 )
C              Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)';
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1),
     $                     LDXQ, QG(K+I+1,1), LDQG, ONE, QG(K+I+2,I+1),
     $                     1 )
C              Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)';
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1),
     $                     LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+2,I+1),
     $                     1 )
            END IF
C
C           Update XG with first Householder reflection.
C
C           xg = G*u1
            CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG,
     $                  QG(K+I+1,I), 1, ZERO, XG(1,I), 1 )
            CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG,
     $                  QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 )
C           xg = xg + XG1*w1
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG,
     $                  DWORK, 1, ONE, XG(1,I), 1 )
C           xg = xg + XG2*w2
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
     $                  LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 )
C           temp = XG1'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ,
     $                  QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 )
C           xg = xg - U1*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1),
     $                  LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 )
C           temp = XG2'*u1
            CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1),
     $                  LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 )
C           xg = xg - U2*temp
            CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA,
     $                  DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 )
C           xg = -tauq*xg
            CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 )
C           temp = -tauq/2*xq'*u1
            TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I),
     $                              1 )
C           xg = xg + temp*u1
            CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 )
C
C           Update (i+1)-th column and row of G.
C
C           G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)';
            CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG,
     $                  QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 )
C           G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)';
            CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG,
     $                  A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 )
            IF ( N.GT.I+1 ) THEN
C              G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)';
               CALL DGEMV( 'No transpose', N-I-1, I, -ONE, XG(K+I+2,1),
     $                     LDXG, QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+3),
     $                     LDQG )
C              G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)';
               CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE,
     $                     XG(K+I+2,NB1), LDXG, A(K+I+1,1), LDA, ONE,
     $                     QG(K+I+1,I+3), LDQG )
C              G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)';
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                     LDQG, XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+3),
     $                     LDQG )
C              G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)';
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+3),
     $                     LDQG )
            END IF
C
C           Annihilate updated parts in XG.
C
            DO 80  J = 1, I
               XG(K+I+1,J) = ZERO
   80       CONTINUE
            DO 90  J = 1, I-1
               XG(K+I+1,NB+J) = ZERO
   90       CONTINUE
C
C           Apply orthogonal symplectic Givens rotation.
C
            CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S )
            IF ( N.GT.I+1 ) THEN
               CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG,
     $                    C, -S )
               CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1,
     $                    C, -S )
            END IF
            CS(2*I-1) = C
            CS(2*I)   = S
            QG(K+I+1,I) = TAUQ
C
C           Update XA with second Householder reflection.
C
C           xa = H(1:n,1:n)'*u2
            CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA,
     $                  A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 )
            IF ( N.GT.I+1 ) THEN
C              w1 = U1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                    LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 )
C              xa = xa + XA1*w1
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1),
     $                     LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 )
C              w2 = U2'*u2
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 )
C              xa = xa + XA2*w2
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1),
     $                     LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 )
C              temp = YA1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1),
     $                     LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 )
C              xa = xa + U1*temp
               CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                     LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 )
C              temp = YA2'*u1
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1),
     $                     LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 )
C              xa = xa + U2*temp
               CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 )
            END IF
C           xa = -tau*xa
            CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 )
C
C           Update YA with second Householder reflection.
C
C           ya = H(1:n,1:n)*u2
            CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA,
     $                  A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 )
            IF ( N.GT.I+1 ) THEN
C              temp = XA1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA,
     $                     A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 )
C              ya = ya + U1*temp
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1),
     $                     LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 )
C              temp = XA2'*u1
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1),
     $                     LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 )
C              ya = ya + U2*temp
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1),
     $                     LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 )
            END IF
C           ya = ya + YA1*w1
            CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
     $                     DWORK, 1, ONE, YA(1,NB+I), 1 )
C           ya = ya + YA2*w2
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
     $                  DWORK(NB1), 1, ONE, YA(1,NB+I), 1 )
C           ya = -tau*ya
            CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 )
C           temp = -tau*ya'*u2
            TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 )
C           ya = ya + temp*u2
            CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 )
C
C           Update (i+1)-th column of A.
C
C           H(1:n,i+1) = H(1:n,i+1) + ya
            CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 )
C           H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2
            CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1),
     $                  1 )
C
C           Update (i+1)-th row of A.
C
            IF ( N.GT.I+1 ) THEN
C              H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)';
               CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2),
     $                     LDA )
C              H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)'
               CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1,
     $                     A(K+I+1,I+2), LDA )
            END IF
C
C           Annihilate updated parts in YA.
C
            YA(K+I+1,NB+I) = ZERO
C
C           Update XQ with second Householder reflection.
C
C           xq = Q*u2
            CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG,
     $                  A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 )
            IF ( N.GT.I+1 ) THEN
C              xq = xq + XQ1*w1
               CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1),
     $                     LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 )
C              xq = xq + XQ2*w2
               CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1),
     $                     LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 )
C              temp = XQ1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ,
     $                     A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 )
C              xq = xq - U1*temp
               CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1),
     $                     LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 )
C              temp = XQ2'*u2
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1),
     $                     LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 )
C              xq = xq - U2*temp
               CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1),
     $                     LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 )
            END IF
C           xq = -tauq*xq
            CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 )
C           temp = -tauq/2*xq'*u2
            TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I),
     $                              1 )
C           xq = xq + temp*u2
            CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 )
C
C           Update (i+1)-th column and row of Q.
C
            IF ( N.GT.I+1 ) THEN
               CALL DAXPY( N-I-1, ONE, XQ(I+2,NB+I), 1, QG(K+I+2,I+1),
     $                     1 )
C              H(1:n,n+i+1) = H(1:n,n+i+1) - U * XQ(i+1,:)';
               CALL DAXPY( N-I-1, -XQ(I+1,NB+I), A(K+I+2,I), 1,
     $                     QG(K+I+2,I+1), 1 )
            END IF
C
C           Update XG with second Householder reflection.
C
C           xg = G*u2
            CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG,
     $                  A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 )
            CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG,
     $                  A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 )
C           xg = xg + XG1*w1
            CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
     $                  DWORK, 1, ONE, XG(1,NB+I), 1 )
C           xg = xg + XG2*w2
            CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
     $                  LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 )
            IF ( N.GT.I+1 ) THEN
C              temp = XG1'*u2
               CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1),
     $                     LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 )
C              xg = xg - U1*temp
               CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1),
     $                     LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 )
C              temp = XG2'*u2
               CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1),
     $                     LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 )
C              xg = xg - U2*temp
               CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1),
     $                     LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 )
            END IF
C           xg = -tauq*xg
            CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 )
C           temp = -tauq/2*xg'*u1
            TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1,
     $                                XG(K+I+1,NB+I), 1 )
C           xg = xg + temp*u1
            CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 )
C
C           Update (i+1)-th column and row of G.
C
            CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 )
            IF ( N.GT.I+1 ) THEN
               CALL DAXPY( N-I-1, -ONE, XG(K+I+2,NB+I), 1,
     $                     QG(K+I+1,I+3), LDQG )
               CALL DAXPY( N-I-1, XG(K+I+1,NB+I), A(K+I+2,I), 1,
     $                     QG(K+I+1,I+3), LDQG )
            END IF
C
C           Annihilate updated parts in XG.
C
            XG(K+I+1,NB+I) = ZERO
C
            A(K+I+1,I) = AKI
  100    CONTINUE
      END IF
C
      RETURN
C *** Last line of MB04PA ***
      END


c-------calculate matrix value and inv matrix
c-------O----matrix in R R' Theta Theta'      input
c-------S----matrix in Z Z'                   input
c
c-------Q----inv matrix of O                  output
c-------U----inv matrix of S                  output
c--------------------------------------------
      SUBROUTINE DETINV(Q,O,DETRAD,U,S,DETAXI,IMAT)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION Q(4,9),O(4,4),U(2,2),S(2,2)
      DIMENSION D(4)
c------ hanglie shi
      DETAXI=S(1,1)*S(2,2)-S(1,2)*S(2,1)
      N=0
1     N=N+1
      JB=MOD(N,4)+1
      JC=MOD(N+1,4)+1
      JD=MOD(N+2,4)+1
      D(N)=O(2,JB)*(O(3,JC)*O(4,JD)-O(3,JD)*O(4,JC))+
     1O(2,JC)*(O(3,JD)*O(4,JB)-O(3,JB)*O(4,JD))+
     2O(2,JD)*(O(3,JB)*O(4,JC)-O(3,JC)*O(4,JB))
      IF(N.LE.3) GO TO 1
      DETRAD=O(1,1)*D(1)-O(1,2)*D(2)+O(1,3)*D(3)-O(1,4)*D(4)
      IF(IMAT.LT.8) GO TO 35
      U(1,1)=S(2,2)/DETAXI
      U(1,2)=-S(1,2)/DETAXI
      U(2,1)=-S(2,1)/DETAXI
      U(2,2)=S(1,1)/DETAXI
c------ inv matrix
      DO 20 I=1,4
      DO 20 J=1,4
20    Q(I,J)=O(I,J)
      NH=4
      NA=NH+1
      NE=NH+NH+1
      NP1=NA+1
      DO 51 I=1,NH
      DO 51 J=NP1,NE
51    Q(I,J)=0.
      DO 50 I=1,NH
      Q(I,NA)=1.
      IPNA=I+NA
50    Q(I,IPNA)=1.
      I=1
32    N=I+1
      DO 30 J=N,NE
30    Q(I,J)=Q(I,J)/Q(I,I)
      IF(I-NH)33,34,34
33    DO 31 K=N,NH
      DO 31 J=N,NE
31    Q(K,J)=Q(K,J)-Q(K,I)*Q(I,J)
      I=I+1
      GO TO 32
34    N=I-1
      DO 40 K=1,N
      DO 40 J=NA,NE
40    Q(K,J)=Q(K,J)-Q(K,I)*Q(I,J)
      I=I-1
      IF(I-1)34,35,34
35    RETURN
      END


program main

    use rkf45_simd_mod
    use rkf45_scalar_mod
    use check_result_mod
    use iso_fortran_env, only: real64
    implicit none

    ! The actual width of the array (analogous to # of cells to sweep
    ! through in Nyx).
    integer, parameter :: array_length = 2**19

    ! The width of the array to pass to the SIMD integrator. The
    ! integrator supports arrays of arbitrary width, but there is likely
    ! a sweet spot for the best with to give it. The minimum should be
    ! the SIMD width of the architecture (for HSW it's 256 bits -> 4
    ! doubles; for Knights it's 512 bits -> 8 doubles). Choosing a
    ! smaller number means the temporary arrays use less memory, but the
    ! code makes more function calls. The converse is true for larger
    ! array widths. Larger array widths may also incur memory access
    ! penalties due to spilling out of cache. So the sweet spot may be
    ! somewhere in the middle.
    integer :: rkf_array_width

    ! Initial and final values of the variable in the ODE. In contrast
    ! to most other integrators, I decided not to make this this one
    ! update the values in situ.
    real(real64) :: y0(array_length), y(array_length)

    ! Initial and final times for the integration. In a Strang splitting
    ! grid sweep in Nyx, all cells have the same initial and final time,
    ! so these are scalars, not arrays.
    real(real64) :: t0, tf

    ! Initial guess for the time step in the integration. In theory we
    ! could have a unique guess for each cell, but that would be an
    ! awful lot of work. So just make all cells use the same initial
    ! guess.
    real(real64) :: dt0

    ! Tolerance for the local truncation error, which decides how small
    ! the time steps can be when integrating from t0 to tf.
    real(real64) :: eps

    ! Final value of the time and last time step. t should be just tf,
    ! so there is no good reason to keep it, and it can probably go
    ! away. dt just shows the value of the last time step when arriving
    ! at tf.
    real(real64) :: t, dt

    ! Used for wall clock timers.
    real(real64) :: t1, t2

    ! Number of steps the integration took to get from t0 to tf.
    integer :: num_steps

    ! 0 means integration succeeded; < 0 means it failed.
    integer :: flag, err = 0

    integer :: i

    write (*,'(a20, i8)') 'Array length: ', array_length

    ! Set initial conditions. Just use the value of the loop index as the
    ! initial condition.
    do i = 1, array_length
      y0(i) = real(i, real64)
    end do

    ! Every ODE must use the same limits of integration. This is the case for the
    ! Nyx problem, where the Strang splitting time step is the same in every
    ! cell during each grid sweep.
    t0 = 0.0d0
    tf = 5.0d0

    ! Use the same initial guess for the time step for every ODE.
    dt0 = 25.0d0

    ! Local truncation error tolerance.
    eps = 1.0d-3

    write (*, *), 'Integrating the equation y''(t) = 2*t from:'
    write (*, '(a3, es12.3e2, a3, es12.3e2, a3)') '[', t0, ', ', tf, ']'
    write (*, '(a45, es18.6e2)') 'local truncation error tolerance: ', eps

    ! First do the integrations using the scalar version of RKF45.
    call cpu_time(t1)
    !$omp simd
    do i = 1, array_length
      call rkf45_scalar(y0(i), t0, tf, dt0, eps, t, dt, y(i), flag, num_steps)
      err = err + flag
    end do
    call cpu_time(t2)
    write (*, *) 'time in scalar RKF45 (sec): ', t2-t1
    write (*, *)

    call check_result(y)

    ! Now do the same sweep of integrations using the SIMD RKF45, but
    ! repeat with varying array widths given to RKF.
    rkf_array_width = 2
    do while (rkf_array_width <= array_length)
      write (*,'(a40, i8)') 'Array width per call to RKF45: ', rkf_array_width
      call cpu_time(t1)
      do i = 1, array_length, rkf_array_width
        call rkf45_simd(y0(i:i+rkf_array_width-1), t0, tf, dt0, eps, t, dt, y(i:i+rkf_array_width-1), flag, num_steps)
        err = err + flag
      end do
      call cpu_time(t2)
      write (*, *) 'time in SIMD RKF45 (sec): ', t2-t1
      rkf_array_width = rkf_array_width*2
    end do

    if (err < 0) error stop 'ERROR: Integration failed!'

    call check_result(y)

    write (*, *) 'Success!'
    write (*, '(a50, 2i8)') '# of time steps taken: ', num_steps

end program main


      subroutine parametric_line(x1,y1,z1,t1,x2,y2,z2,t2,
     1     alam,amue,anue,line_flag)
c s kelkar March 24, 06
c parametric equation of a straight line passing thru the points
c (x1,y1,z1), and (x2,y2,z2), given by, with t as the parameter,
c with values t1 and t2 at the two points respectively
c x = x1 + alam*(t-t1)
c y = y1 + amue*(t-t1)
c z = z1 + anue*(t-t1)
c********************************************************************
c INPUT VARIABLES
c
c OUTOUT VARIABLES
c
c INTERNAL VARIABLES
c********************************************************************
c INPUT
c     x1,y1,z1 and x2,y2,z2 : coordinates of the two points
c OUTOUT
c     alam,amue,anue : coeffecients in the parametric equations
c

      use comunits

      implicit none

      logical line_flag

      real*8 x1,y1,z1,t1,x2,y2,z2,t2,dt,alam,amue,anue

      dt=t2-t1
      line_flag= .true.

      if(dt.eq.0.) then
         write(error_unit_number,*)' zero delta-t in',
     1        'parametric_line'
         write(error_unit_number,*)'STOP'
c     stop
         line_flag = .false.
      else
         alam=(x2-x1)/dt
         amue=(y2-y1)/dt
         anue=(z2-z1)/dt
      endif

      if(alam.eq.0.) then
         if(amue.eq.0.) then
            if(anue.eq.0.) then
               line_flag = .false.
            endif
         endif
      endif

      return

      end

c........................................................................


!##############################################################################
! PROGRAM EndogenousGrid
!
! ## Policy function iteration and the method of endogenous gridpoints
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog08_07m.f90"

program EndogenousGrid

    use globals
    use toolbox

    implicit none

    ! start timer
    call tic()

    ! initialize a, c and value function
    call grid_Cons_Equi(a, 0d0, a0)
    c(:) = a(:)/2d0

    ! iterate until policy function converges
    do iter = 1, itermax

        ! set a = 0 manually
        a_endog(0) = 0d0
        c_endog(0) = 0d0

        ! calculate optimal decision for every gridpoint
        do ia = 1, NA

            ! calculate endogenous gridpoint and consumption
            c_endog(ia) = c(ia)*beta**(-gamma)
            a_endog(ia) = a(ia) + c_endog(ia)

        enddo

        ! stretch out to exogenous grid again
        do ia = 0, NA
            c_new(ia) = linint_Gen(a(ia), a_endog, c_endog, ia)
        enddo

        ! get convergence level
        con_lev = maxval(abs(c_new(:) - c(:))/max(abs(c(:)), 1d-10))
        write(*,'(i5,2x,f20.7)')iter, con_lev

        ! check for convergence
        if(con_lev < sig)then
            call output()
        endif

        c = c_new
    enddo

    write(*,*)'No Convergence'

contains

    ! For creating output plots.
    subroutine output()

        use toolbox

        implicit none
        integer, parameter :: n_err = 10000
        real*8 :: err, a_err, err_temp

        ! end timer
        call toc()

        ! interpolate policy function
        call spline_interp(c, coeff_c)

        ! calculate the time path of consumption numerically
        a_t(0) = a0
        c_t(0) = spline_eval(a_t(0), coeff_c, 0d0, a0)
        do it = 1, TT
            a_t(it) = a_t(it-1) - c_t(it-1)
            c_t(it) = spline_eval(a_t(it), coeff_c, 0d0, a0)
        enddo
        call plot((/(dble(it),it=0,TT)/), c_t, legend='numerical')

        ! calculate the time path of consumption analytically
        a_t(0) = a0
        c_t(0) = a_t(0)*(1d0-beta**gamma)
        do it = 1, TT
            a_t(it) = a_t(it-1) - c_t(it-1)
            c_t(it) = a_t(it)*(1d0-beta**gamma)
        enddo
        call plot((/(dble(it),it=0,TT)/), c_t, legend='analytical')
        call execplot(xlabel='Time t', ylabel='Consumption c_t')

        ! plot numerical and analytical consumption
        call plot(a, c, legend='numerical')
        call plot(a, a*(1d0-beta**gamma), legend='analytical')
        call execplot(xlabel='Level of resources a', ylabel='Policy Function c(a)')

        ! calculate consumption function error
        err = 0d0
        do ia = 0, n_err
            a_err = a0*dble(ia)/dble(n_err)
            err_temp = abs(spline_eval(a_err, coeff_c, 0d0, a0) - a_err*(1d0-beta**gamma)) &
                                                /max(a_err*(1d0-beta**gamma), 1d-10)
            if(err_temp > err)err = err_temp
        enddo
        write(*,'(a, es15.7)')'Consumption function error:',err

        ! quit program
        stop

    end subroutine

end program


program double_loop_1

    integer,parameter :: n=139

    real*8 A(n, n)

    !$xev loop_tag
    do i=1,n
        do j_sk=i+1, i+n
            A(i,j_sk-i)=A(i-1,j_sk-i)+A(i,j_sk-i-1)
        end do
    end do

end program double_loop_1


program test_blas
   use wrapped_gemv, only : sp, gemv
   implicit none

   integer :: i, j
   real(sp) :: mat(4, 4), vec(4), res(4)

   do i = 1, size(vec)
      vec(i) = sqrt(real(i, sp))
   end do

   do i = 1, size(mat, 2)
      do j = 1, size(mat, 1)
         mat(j, i) = sqrt(real(j * i, sp))
      end do
   end do

   call gemv(mat, vec, res, alpha=-1.0_sp, trans='t')

end program test_blas


      SUBROUTINE PTSPL (ILIM, X,Y,Z, A,B,C,D)

C  Given a set of supposedly co-planar points, find containing
C  plane.  Idea here is to find 2 points at greatest separation
C  along a principal axis (x, y, or z) and then select 3rd point
C  as the one with greatest distance from the line connecting
C  these 2 points.  This is an attempt to find 3 "good" (widely
C  separated, highly non-colinear) points for computing the plane.
C  If there are 3 non-colinear points, this will find them.

      INTEGER   IA, ILIM, IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN
      INTEGER   ILO,IHI, IBEST

      REAL      X(ILIM),Y(ILIM),Z(ILIM), XT(3),YT(3),ZT(3)
      REAL      A,B,C,D, XSEP,YSEP,ZSEP, SEP, AL,BL,CL,XL,YL,ZL
      REAL      DISTMX,DIST, XN,YN,ZN

      IXMAX = 1
      IXMIN = 1
      IYMAX = 1
      IYMIN = 1
      IZMAX = 1
      IZMIN = 1

C  find min,max points for x,y,z
      DO 100 IA = 2,ILIM
         IF (X(IA) .GT. X(IXMAX)) IXMAX = IA
         IF (X(IA) .LT. X(IXMIN)) IXMIN = IA

         IF (Y(IA) .GT. Y(IYMAX)) IYMAX = IA
         IF (Y(IA) .LT. Y(IYMIN)) IYMIN = IA

         IF (Z(IA) .GT. Z(IZMAX)) IZMAX = IA
         IF (Z(IA) .LT. Z(IZMIN)) IZMIN = IA
100   CONTINUE

      XSEP = X(IXMAX) - X(IXMIN)
      YSEP = Y(IYMAX) - Y(IYMIN)
      ZSEP = Z(IZMAX) - Z(IZMIN)

C  take largest of the three separations:
      IF (XSEP .GT. YSEP) THEN
         IHI = IXMAX
         ILO = IXMIN
         SEP = XSEP
      ELSE
         IHI = IYMAX
         ILO = IYMIN
         SEP = YSEP
      ENDIF

      IF (ZSEP .GT. SEP) THEN
         IHI = IZMAX
         ILO = IZMIN
      ENDIF

C  use two widely separated points as axis for plane
      XT(1) = X(ILO)
      YT(1) = Y(ILO)
      ZT(1) = Z(ILO)

      XT(2) = X(IHI)
      YT(2) = Y(IHI)
      ZT(2) = Z(IHI)

C  Parameters for axis
      AL = XT(2) - XT(1)
      BL = YT(2) - YT(1)
      CL = ZT(2) - ZT(1)

      XL = XT(1)
      YL = YT(1)
      ZL = ZT(1)

C  as 3rd point, use one with greatest distance from line
      DISTMX = -1.1
      DO 200 IA = 1,ILIM
         CALL PTLNDS (X(IA),Y(IA),Z(IA), AL,BL,CL, XL,YL,ZL,
     1                XN,YN,ZN, DIST)
         IF (DIST .GT. DISTMX) THEN
            DISTMX = DIST
            IBEST  = IA
         ENDIF
200   CONTINUE

      XT(3) = X(IBEST)
      YT(3) = Y(IBEST)
      ZT(3) = Z(IBEST)

      CALL PT3PL (XT,YT,ZT, A,B,C,D)

      END


!comentar ou remover o comentario dependendo da situacao

subroutine mmqfortran
!program mmqfortran

IMPLICIT NONE
INTEGER :: i, j, m, k, g, quant_amostras
REAL :: MAT(100,100), VET(100), soma, COEF(100) !mat eh uma matrix mXm
!REAL,DIMENSION(:,:),ALLOCATABLE::MAT !aqui dizemos que a dimensao da matriz MAT deve ser alocada dinamicamente
REAL,ALLOCATABLE::X(:), F(:) !alocacao dinamica
character dummy

COMMON/PLOT/ m, quant_amostras

    open (unit=123, file="cpp_input.txt", status="unknown", action="write")!abertura do novo arquivo
    open (unit=321, file="entrada.txt", status="unknown", action="read")!abertura do novo arquivo

    read(321,*)dummy !texto
    read(321,*)m
    read(321,*)dummy !texto
    read(321,*)quant_amostras
    !PRINT*, 'Ordem do polinomio(maximo 99): ', m
    m = m+1
    !PRINT*, 'Quantidade de amostras', quant_amostras

    ALLOCATE(X(quant_amostras))
    ALLOCATE(F(quant_amostras))

    WRITE(123,*) 'Valores de X'

    read(321,*)dummy !texto

    DO i=1,quant_amostras,1
        READ(321,*) X(i),F(i)
        WRITE(123,*) X(i)
    END DO

    WRITE(123,*) 'Valores de F(X)'
    DO i=1,quant_amostras,1
        WRITE(123,*) F(i)
    END DO

    DO i=1,quant_amostras,1
        print*,'X'
        !WRITE(*,*) X(i)
        print*,'FX'
        !WRITE(*,*) F(i)
    END DO

    soma = 0

    DO i=1,m+1,1

        DO j=1,i,1

            soma = 0
            k=i+j-2

            DO g=1,quant_amostras,1
                !Nessa parte que ocorre a soma dos termos relacionados a x da matriz do metodo dos minimos quadrados
                soma = soma + X(g)**k

            END DO
            !Aqui ocorre a atribuicao da soma
            MAT(i,j) = soma
            MAT(j,i) = soma

        END DO

        soma = 0

            DO g=1,quant_amostras,1
                !Nessa parte é feita a soma dos termos do vetor f(x)*x
                soma = soma +F(g)*(X(g)**(i-1))

            END DO
        !Aqui é atribuido a soma dos termos calculados acima
        VET(i) = soma

    END DO
    !Nessa parte é feita a reducao da matriz para facilitar o calculo da solucao dos coeficientes
    DO k=1,m-1,1
        DO i=k+1,m,1

            DO j=k+1,m,1

                MAT(i,j)= MAT(i,j) - (MAT(i,k)/MAT(k,k))*MAT(k,j)

            END DO

            VET(i) = VET(i)- (MAT(i,k)/MAT(k,k))*VET(k)

        END DO

    END DO

   !Aqui os valores dos coeficientes são atribuidos
    DO i=1,m,1
        COEF(i) = VET(i)/MAT(i,i)
    END DO

    soma = 0

    DO i = m-1,1,-1
        soma = 0

        DO j=i+1,m,1
            soma = soma + MAT(i,j)*COEF(j)
        END DO

    COEF(i) = (VET(i)-soma)/MAT(i,i)

    END DO

    WRITE(123,*) 'COEFICIENTES'
    DO i=0,m,1
        !PRINT*, COEF(i+1), '* X^',(i)
        WRITE(123,*) COEF(i+1)
    END DO

!deallocate(MAT) !necessario desalocar a memoria após o uso
    deallocate(X)
    deallocate(f)
    close(123)
    close(321)
END


module problem
    integer,parameter :: num_spin=300, num_tempscales=64, nms=4000
    real,parameter :: tempscales(num_tempscales) = (/((10-i*0.15),i=0,num_tempscales-1)/) ! assign to y in increments of 1.5 starting at 1.5
    real :: jmat(num_spin,num_spin)

    !f2py integer,parameter :: num_spin,num_tempscales,nms
    !f2py timescale
    !f2py jmat

    contains
    subroutine init_problem()
        call loadexample('example.txt')
    end subroutine init_problem

    subroutine loadexample(filename)
        implicit none
        character(len=*),intent(in) :: filename
        integer :: ibond,i,j
        real :: weight
        jmat=0
        open(10, file = filename)
        do ibond = 1, num_spin*(num_spin-1)/2
            read(10, *) i,j,weight
            jmat(i+1,j+1)=weight/2
            jmat(j+1,i+1)=weight/2
        end do
        close(10)
    end subroutine loadexample

    subroutine get_cost(config,cost)
        implicit none
        real,intent(out) :: cost
        integer,intent(in) :: config(num_spin)
        !f2py integer,intent(aux) :: num_spin
        cost=sum(matmul(config,jmat)*config)
    end subroutine get_cost

    subroutine propose(config,field,ispin,delta)
        implicit none
        integer,intent(in) :: config(num_spin)
        real,intent(in) :: field(num_spin)
        integer,intent(out) :: ispin
        real,intent(out) :: delta
        real :: rn
        !f2py integer,intent(aux) :: num_spin

        call random_number(rn)
        ispin = floor(num_spin*rn)+1
        delta = -field(ispin)*config(ispin)*4 !2 for spin change, 2 for mutual energy.
    end subroutine propose

    subroutine accept(ispin,config,field)
        implicit none
        integer,intent(inout) :: config(num_spin)
        real,intent(inout) :: field(num_spin)
        integer,intent(in) :: ispin
        !f2py integer,intent(aux) :: num_spin

        config(ispin)=-config(ispin)
        !update field
        field=field+2*config(ispin)*jmat(:,ispin)
    end subroutine accept

    subroutine get_random_config(config,field)
        implicit none
        integer,intent(out) :: config(num_spin)
        real,intent(out) :: field(num_spin)
        real :: rn(num_spin)
        !f2py integer,intent(aux) :: num_spin

        call random_number(rn)
        config=floor(rn*2)*2-1
        field=matmul(jmat,config)
    end subroutine get_random_config
end module problem


      SUBROUTINE pcshft(a,b,d,n)
      INTEGER n
      REAL a,b,d(n)
      INTEGER j,k
      REAL const,fac
      const=2./(b-a)
      fac=const
      do 11 j=2,n
        d(j)=d(j)*fac
        fac=fac*const
11    continue
      const=0.5*(a+b)
      do 13 j=1,n-1
        do 12 k=n-1,j,-1
          d(k)=d(k)-const*d(k+1)
12      continue
13    continue
      return
      END

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


      SUBROUTINE SPOLZ(A,NDEG,Z,H,IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2001-05-25 SPOLZ  Krogh Minor change for making .f90 version.
c>> 1996-04-27 SPOLZ  Krogh Changes to use .C. and C%%.
c>> 1996-03-30 SPOLZ  Krogh Added external statement, MIN0 => MIN.
C>> 1995-01-25 SPOLZ  Krogh Automate C conversion.
C>> 1995-11-17 SPOLZ  Krogh SFTRAN converted to Fortran 77
C>> 1994-10-19 SPOLZ  Krogh  Changes to use M77CON
C>> 1992-05-11 SPOLZ  CLL
C>> 1988-11-16        CLL More editing of spec stmts.
C>> 1988-06-07 SPOLZ  CLL Reordered spec stmts for ANSI standard.
C>> 1987-09-16 SPOLZ  Lawson  Initial code.
c--S replaces "?": ?POLZ,
C     ------------------------------------------------------------------
C
C     Given coefficients A(1),...,A(NDEG+1) this subr computes the
C     NDEG roots of the polynomial
C                 A(1)*X**NDEG + ... + A(NDEG+1)
C     storing the roots as complex numbers in the array Z( ).
C     Require NDEG .ge. 1 and A(1) .ne. 0.
C
C     ------------------------------------------------------------------
C-- Begin mask code changes
C
C     Argument Definitions
C     --------------------
C
C     A( )     (In) Contains the coefficients of a polynomial, high
C              order coefficient first with A(1).ne.0. The contents
C              of this array will not be modified by the subroutine.
C
C     NDEG     (In) Degree of the polynomial.
C
C     Z( )     (Out) Contains the polynomial roots stored as complex
C              numbers. The real and imaginary parts of the Jth roots
C              will be stored in Z(2*J-1) and Z(2*J) respectively.
C
C     H( )     (Scratch) Array of work space.
C
C     IERR     (Out) Error flag. Set by the subroutine to 0 on normal
C              termination. Set to -1 if A(1)=0. Set to -2 if NDEG
C              .le. 0. Set to  J > 0 if the iteration count limit
C              has been exceeded and roots 1 through J have not been
C              determined.
C
C     C.L.Lawson & S.Y.Chan, JPL, June 3,1986.
c     1992-05-11 CLL IERR was not being set when N = 0 or 1. Fixed this.
c                Added type stmts for all variables.
C-- End mask code changes
C     ------------------------------------------------------------------
C
      EXTERNAL R1MACH, I1MACH
      REAL             C43, C75, C95, HALF, ONE, ZERO
      PARAMETER(ZERO=0.E0, ONE=1.E0, C75=.75E0, HALF=.5E0,
     *          C43=-.4375E0, C95=.95E0)
      INTEGER I,J,K,L,M,N,NDEG, EN,LL,MM,NA,ITS,LOW,MP2,
     *        ENM2,IERR,I1MACH
      REAL             A(NDEG+1), H(NDEG,NDEG)
      REAL              P,Q,R,S,T,W,X,Y,ZZ,MACHEP,R1MACH
      REAL              C,F,G,B2,BASE
c++ Default NO_COMPLEX = .C. | (.N. == 'D')
c++ Default COMPLEX = ~NO_COMPLEX
c++ CODE for COMPLEX is active
      COMPLEX Z(*)
c++ CODE for NO_COMPLEX is inactive
C      REAL             Z(*)
c++ END
      LOGICAL NOTLAS,MORE,FIRST
C
      SAVE FIRST, MACHEP, BASE, B2
C
      DATA FIRST /.TRUE./
C     ------------------------------------------------------------------
C
      IF (FIRST) THEN
C
C     Set MACHEP = machine dependent parameter specifying the
C                  relative precision of floating point arithmetic.
C         BASE  = machine dependent parameter specifying the base
C                  of the machine floating point representation.
C
        FIRST = .FALSE.
        MACHEP = R1MACH(4)
        BASE = I1MACH(10)
        B2 = BASE * BASE
      END IF
C
      IERR = 0
C
      IF (NDEG .LE. 0) THEN
        IERR = -2
        CALL ERMSG('SPOLZ',IERR,0,'NDEG .LE. 0','.')
        RETURN
      END IF
C
      IF (A(1) .EQ. ZERO) THEN
        IERR = -1
        CALL ERMSG('SPOLZ',IERR,0,'A(1) .EQ. ZERO','.')
        RETURN
      END IF
C
      N = NDEG
      IERR = 0
C
C     Build first row of companion matrix.
C
      DO 10 I = 2,NDEG+1
        H(1,I-1) = -(A(I) / A(1))
   10 CONTINUE
C
C     Extract any exact zero roots and set N = degree of
C     remaining polynomial.
C
      DO 20 J = NDEG,1,-1
        IF (H(1,J) .NE. ZERO) go to 30
c++  Code for COMPLEX is active
        Z(J) = ZERO
c++  Code for NO_COMPLEX is inactive
C        Z(2*J-1) = ZERO
C        Z(2*J) = ZERO
c++  End
        N = N - 1
   20 CONTINUE
   30 CONTINUE
C
C     Special for N = 0 or 1.
C
      IF (N .EQ. 0) RETURN
      IF (N .EQ. 1) THEN
        Z(1) = H(1,1)
        RETURN
      END IF
C
C     Build rows 2 thru N of the companion matrix.
C
      DO 50 I = 2,N
        DO 40 J = 1,N
          H(I,J) = ZERO
   40   CONTINUE
        H(I,I-1) = ONE
   50 CONTINUE
C
C ***************** BALANCE THE MATRIX ***********************
C
C     This is an adaption of the EISPACK subroutine BALANC to
C     the special case of a companion matrix. The EISPACK BALANCE
C     is a translation of the ALGOL procedure BALANCE, NUM. MATH.
C     13, 293-304(1969) by Parlett and Reinsch.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     ********** ITERATIVE LOOP FOR NORM REDUCTION **********
   60   CONTINUE
        MORE = .FALSE.
        DO 110 I = 1, N
C     Compute R = sum of magnitudes in row I skipping diagonal.
C             C = sum of magnitudes in col I skipping diagonal.
          IF (I .EQ. 1) THEN
            R = ABS(H(1,2))
            DO 70 J = 3,N
              R = R + ABS(H(1,J))
   70       CONTINUE
            C = ABS(H(2,1))
          ELSE
            R = ABS(H(I,I-1))
            C = ABS(H(1,I))
            IF (I .NE. N) THEN
              C = C + ABS(H(I+1,I))
            END IF
          END IF
C
C     Determine column scale factor, F.
C
          G = R / BASE
          F = ONE
          S = C + R
   80     IF (C .LT. G) THEN
            F = F * BASE
            C = C * B2
            GO TO 80
          END IF
          G = R * BASE
   90     IF (C .GE. G) THEN
            F = F / BASE
            C = C / B2
            GO TO 90
          END IF
C
C     Will the factor F have a significant effect ?
C
          IF ((C + R) / F .LT. C95 * S) THEN
C
C           Yes, so do the scaling.
C
            G = ONE / F
            MORE = .TRUE.
C
C     Scale Row I
C
            IF (I .EQ. 1) THEN
              DO 100 J = 1,N
                H(1,J) = H(1,J)*G
  100         CONTINUE
            ELSE
              H(I,I-1) = H(I,I-1)*G
            END IF
C
C     Scale Column I
C
            H(1,I) = H(1,I) * F
            IF (I .NE. N) H(I+1,I) = H(I+1,I) * F
C
          END IF
  110   CONTINUE
      if (MORE) go to 60
C
C ***************** QR EIGENVALUE ALGORITHM ***********************
C
C     This is the EISPACK subroutine HQR that uses the QR
C     algorithm to compute all eigenvalues of an upper
C     Hessenberg matrix. Original ALGOL code was due to Martin,
C     Peters, and Wilkinson, Numer. Math., 14, 219-231(1970).
C
      LOW = 1
      EN = N
      T = ZERO
C     ********** SEARCH FOR NEXT EIGENVALUES **********
  160 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********
  170 DO 180 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 200
         IF (ABS(H(L,L-1)) .LE. MACHEP * (ABS(H(L-1,L-1))
     X      + ABS(H(L,L)))) GO TO 200
  180 CONTINUE
C     ********** FORM SHIFT **********
  200 X = H(EN,EN)
      IF (L .EQ. EN) GO TO 370
      Y = H(NA,NA)
      W = H(EN,NA) * H(NA,EN)
      IF (L .EQ. NA) GO TO 380
      IF (ITS .EQ. 30) GO TO 1000
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 230
C     ********** FORM EXCEPTIONAL SHIFT **********
      T = T + X
C
      DO 220 I = LOW, EN
  220 H(I,I) = H(I,I) - X
C
      S = ABS(H(EN,NA)) + ABS(H(NA,ENM2))
      X = C75 * S
      Y = X
      W = C43 * S * S
  230 ITS = ITS + 1
C     ********** LOOK FOR TWO CONSECUTIVE SMALL
C                SUB-DIAGONAL ELEMENTS.
C                FOR M=EN-2 STEP -1 UNTIL L DO -- **********
      DO 240 MM = L, ENM2
         M = ENM2 + L - MM
         ZZ = H(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / H(M+1,M) + H(M,M+1)
         Q = H(M+1,M+1) - ZZ - R - S
         R = H(M+2,M+1)
         S = ABS(P) + ABS(Q) + ABS(R)
         P = P / S
         Q = Q / S
         R = R / S
         IF (M .EQ. L) GO TO 250
         IF (ABS(H(M,M-1)) * (ABS(Q) + ABS(R)) .LE. MACHEP * ABS(P)
     X    * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))) GO TO 250
  240 CONTINUE
C
  250 MP2 = M + 2
C
      DO 260 I = MP2, EN
         H(I,I-2) = ZERO
         IF (I .EQ. MP2) GO TO 260
         H(I,I-3) = ZERO
  260 CONTINUE
C     ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND
C                COLUMNS M TO EN **********
      DO 360 K = M, NA
         NOTLAS = K .NE. NA
         IF (K .EQ. M) GO TO 270
         P = H(K,K-1)
         Q = H(K+1,K-1)
         R = ZERO
         IF (NOTLAS) R = H(K+2,K-1)
         X = ABS(P) + ABS(Q) + ABS(R)
         IF (X .EQ. ZERO) GO TO 360
         P = P / X
         Q = Q / X
         R = R / X
  270    S = SIGN(SQRT(P*P+Q*Q+R*R),P)
         IF (K .EQ. M) GO TO 280
         H(K,K-1) = -S * X
         GO TO 290
  280    IF (L .NE. M) H(K,K-1) = -H(K,K-1)
  290    P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
C     ********** ROW MODIFICATION **********
         DO 310 J = K, EN
            P = H(K,J) + Q * H(K+1,J)
            IF (.NOT. NOTLAS) GO TO 300
            P = P + R * H(K+2,J)
            H(K+2,J) = H(K+2,J) - P * ZZ
  300       H(K+1,J) = H(K+1,J) - P * Y
            H(K,J) = H(K,J) - P * X
  310    CONTINUE
C
         J = MIN(EN,K+3)
C     ********** COLUMN MODIFICATION **********
         DO 330 I = L, J
            P = X * H(I,K) + Y * H(I,K+1)
            IF (.NOT. NOTLAS) GO TO 320
            P = P + ZZ * H(I,K+2)
            H(I,K+2) = H(I,K+2) - P * R
  320       H(I,K+1) = H(I,K+1) - P * Q
            H(I,K) = H(I,K) - P
  330    CONTINUE
C
  360 CONTINUE
C
      GO TO 170
C     ********** ONE ROOT FOUND **********
c++  Code for COMPLEX is active
  370 Z(EN) = CMPLX(X+T,ZERO)
c++  Code for NO_COMPLEX is inactive
C  370 Z(2*EN-1) = X+T
C      Z(2*EN) = ZERO
c++  End
      EN = NA
      GO TO 160
C     ********** TWO ROOTS FOUND **********
  380 P = (Y - X) * HALF
      Q = P * P + W
      ZZ = SQRT(ABS(Q))
      X = X + T
      IF (Q .LT. ZERO) GO TO 420
C     ********** PAIR OF REALS **********
      ZZ = P + SIGN(ZZ,P)
c++  Code for COMPLEX is active
      Z(NA) = CMPLX(X+ZZ,ZERO)
      Z(EN) = Z(NA)
      IF (ZZ .NE. ZERO) Z(EN) = CMPLX(X-W/ZZ,ZERO)
c++  Code for NO_COMPLEX is inactive
C      Z(2*NA-1) = X + ZZ
C      Z(2*NA) = ZERO
C      Z(2*EN-1) = Z(2*NA-1)
C      Z(2*EN) = Z(2*NA)
C      IF (ZZ .NE. ZERO) THEN
C        Z(2*EN-1) = X - W/ZZ
C        Z(2*EN) = ZERO
C      END IF
c++  End
      GO TO 430
C     ********** COMPLEX PAIR **********
c++  Code for COMPLEX is active
  420 Z(NA) = CMPLX(X+P,ZZ)
      Z(EN) = CMPLX(X+P,-ZZ)
c++  Code for NO_COMPLEX is inactive
C  420 Z(2*NA-1) = X + P
C      Z(2*NA) = ZZ
C      Z(2*EN-1) = X + P
C      Z(2*EN) = -ZZ
c++  End
  430 EN = ENM2
      GO TO 160
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = EN
 1001 CONTINUE
C
      IF (IERR .NE. 0) THEN
        CALL ERMSG('SPOLZ',IERR,0,'Convergence failure','.')
      END IF
      RETURN
      END