C*************************************************
      subroutine CXSOIL(N1)
C***********************************************************************
C
C   THIS ROUTINE CALCULATES THE complex SOIL PROPERTIES AND TRANSFER
C   FUNCTIONS FOR THE LAYERS
C
C        N1      = NUMBER OF SOIL LAYERS
C        BL      = RATIO OF CRITICAL DAMPING
C        GL      = SHEAR MODULUS
C        R       = DENSITY
C        G       = complex SHEAR MODULUS
C        V       = complex SHEAR WAVE VELOCITY
C        PLUS    = complex TRANSFER FUNCTION
C        MINUS   = complex TRANSFER FUNCTION
C
C   CODED BY PER B SCHNABEL OCT 1971
C
C***********************************************************************
C
      complex G, V, PLUS, MINUS, MU
      character*6 IDNT
      common /SOILA/ IDNT(6),BL(51),GL(51),FACT(51),H(51),R(51),BF(51)
      common /CSOIL/ G(51), V(51), PLUS(51), MINUS(51)
C
      N = N1 + 1
      do 1 I = 1,N
      GIMAG=2.*BL(I)*GL(I)*SQRT(1.-BL(I)*BL(I))
      GREAL=GL(I)*(1.-2.*BL(I)*BL(I))
      G(I)=CMPLX(GREAL,GIMAG)
      V(I) = CSQRT(G(I)/R(I))
    1 continue
      do 2 I = 1,N1
      J = I + 1
      MU = CSQRT(R(I)/R(J)*G(I)/G(J))
      PLUS(I) = (1. + MU)/2.
      MINUS(I)= (1. - MU)/2.
    2 continue
      return
      end


module nuclear_models
  use numerical_constants
  implicit none

contains
  subroutine nilsson_model(num_levels, E_levels, delta, max_num_levels)
    implicit none
    integer, intent(in) :: num_levels, max_num_levels
    real(kind=dp), intent(in) :: delta
    real(kind=dp), intent(out) :: E_levels(max_num_levels)
    real(kind=dp) :: ham(max_num_levels, max_num_levels), evals(max_num_levels), evecs(max_num_levels)
    real(kind=dp) :: rkappa = 0.05d0, rmu(0:7) = [0.0d0,0.0d0, 0.0d0, 0.35d0, 0.625d0, 0.63d0, 0.448d0, 0.434d0]
    real(kind=dp) :: fdel
    real(kind=dp) :: hw0, hw00, c, d, h00, hl2, hls, hr2, hy20, hdel
    ! Quantum numbers and basis states calculations
    integer :: n, l, omega, lambda, sigma, l_prime, lambda_prime, sigma_prime, nbas=0, i, j, k, icol
    integer, dimension(num_levels) :: l_list, lambda_list, sigma_list
    real(kind=dp), external :: cgc, factlog
    external :: diag

    ! All quantum numbers multiplied by 2
    fdel=((1.0d0 + (2.0d0/3.0d0)*delta)**2)*(1.0d0-(4.0d0/3.0d0)*delta)**(-1.0d0/6.0d0)
    icol = 0
    do n=0,num_levels*2,2
       do omega=1,n+1, 2
          nbas=0
          do l=n,0,-4
             do lambda=-l,l,2
                sigma=omega-lambda
                if(abs(sigma) .ne. 1) cycle ! Only spin half
                nbas=nbas+1
                l_list(nbas) = l
                lambda_list(nbas) = lambda
                sigma_list(nbas) = sigma
             end do
          end do
          hw0=1.0d0; hw00=hw0*fdel;
          c=-2.0d0*hw00*rkappa
          d=rmu(n/2)*c/2.0d0
          do i=1, nbas
             l=l_list(i)
             lambda = lambda_list(i)
             sigma = sigma_list(i)
             do j = i, nbas
                l_prime = l_list(j)
                lambda_prime = lambda_list(j)
                sigma_prime = sigma_list(j)

                h00 = 0.0d0; hl2=0.0d0; hls=0.0d0; hr2=0.0d0; hy20=0.0d0;

                if(i .eq. j) then
                   h00 = float(n+3)/2.0d0*hw0
                   hl2 = float(l*(l+2))/4.0d0
                end if

                if (l .eq. l_prime) then
                   if ((lambda_prime .eq. lambda+2 ) .and. (sigma_prime .eq. sigma-2)) then
                      hls = sqrt(float((l-lambda)*(l+lambda+2)))/4.0d0
                   else if ((lambda_prime .eq. lambda) .and. (sigma_prime .eq. sigma)) then
                      hls = lambda*sigma/4.0d0
                   else if ((lambda_prime .eq. lambda-2) .and. (sigma_prime .eq. sigma+2)) then
                      hls = sqrt(float((l+lambda)*(l-lambda+2)))/4.0d0
                   end if
                   hr2 = float(n+3)/2.0d0
                else if (l_prime .eq. l-4) then
                   hr2 = sqrt(float((n-l+4)*(n+l+2)))/2.0d0
                else if (l_prime .eq. l+4) then
                   hr2 = sqrt(float((n-l)*(n+l+6)))/2.0d0
                end if

                if ((abs(hr2) .gt. 1e-5) .and. (lambda_prime .eq. lambda)) then
                   hy20 = sqrt(float(l+1)/float(l_prime+1))*&
                   cgc(l,4,l_prime, lambda, 0)*cgc(l, 4, l_prime, 0,0)
                end if
                hdel = -delta*hw0*sqrt(4.0d0)/3.0d0*hr2*hy20

                ham(i,j) = h00+hdel+c*hls + d*hl2
                ham(j,i) = ham(i,j)
             end do
          end do

          call diag(ham, max_num_levels, nbas, evals, evecs)

          do i=1,nbas
             E_levels(icol+i) = evals(i)
          end do
          icol = icol+nbas
       end do
    end do

  end subroutine nilsson_model
end module nuclear_models


!-------------------------------------------------------------------
! Kinetic Flux Vector Splitting Method
!-------------------------------------------------------------------

subroutine flux_kfvs_1f1v(fluxw, fluxh, hL, hR, uspace, weight, unum, dt, shL, shR)

    integer, intent(in) :: unum !// number of velocity grids
    real(kind=8), intent(inout) :: fluxw(3), fluxh(unum) !// interface fluxes
    real(kind=8), intent(in) :: hL(unum), shL(unum) !// distribution functions and their slopes in left cell
    real(kind=8), intent(in) :: hR(unum), shR(unum) !// distribution functions and their slopes in right cell
    real(kind=8), intent(in) :: uspace(unum), weight(unum) !// velocity quadrature points and weights
    real(kind=8), intent(in) :: dt !// time step

    !--------------------------------------------------
    ! initialize
    !--------------------------------------------------
    ! interface variable
    real(kind=8) :: h(unum)
    real(kind=8) :: sh(unum)

    ! time integral
    real(kind=8) :: Mt(2)

    ! heaviside step function
    real(kind=8) :: delta(unum)
    delta = (sign(1.d0, uspace) + 1.d0) / 2.d0

    !--------------------------------------------------
    ! upwind reconstruction
    !--------------------------------------------------
    h = hL * delta + hR * (1.d0 - delta)
    sh = shL * delta + shR * (1.d0 - delta)

    Mt(1) = dt
    Mt(2) = 0.5d0 * dt**2

    !--------------------------------------------------
    ! fluxes
    !--------------------------------------------------
    ! macro flux
    fluxw(1) = Mt(1) * sum(weight * uspace * h) - Mt(2) * sum(weight * uspace**2 * sh)
    fluxw(2) = Mt(1) * sum(weight * uspace**2 * h) - Mt(2) * sum(weight * uspace**3 * sh)
    fluxw(3) = Mt(1) * 0.5d0 * sum(weight * uspace * uspace**2 * h) - &
               Mt(2) * 0.5d0 * sum(weight * uspace**2 * uspace**2 * sh)

    ! micro flux
    fluxh = Mt(1) * uspace * h - Mt(2) * uspace**2 * sh

end

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

subroutine flux_kfvs_2f1v(fluxw, fluxh, fluxb, hL, bL, hR, bR, &
                          unum, uspace, weight, dt, shL, sbL, shR, sbR)

    integer, intent(in) :: unum !// number of velocity grids
    real(kind=8), intent(inout) :: fluxw(3), fluxh(unum), fluxb(unum) !// interface fluxes
    real(kind=8), intent(in) :: hL(unum), bL(unum), shL(unum), sbL(unum) !// distribution functions and their slopes in left cell
    real(kind=8), intent(in) :: hR(unum), bR(unum), shR(unum), sbR(unum) !// distribution functions and their slopes in right cell
    real(kind=8), intent(in) :: uspace(unum), weight(unum) !// velocity quadrature points and weights
    real(kind=8), intent(in) :: dt !// time step

    !--------------------------------------------------
    ! initialize
    !--------------------------------------------------
    ! interface variable
    real(kind=8) :: h(unum)
    real(kind=8) :: b(unum)
    real(kind=8) :: sh(unum)
    real(kind=8) :: sb(unum)

    ! time integral
    real(kind=8) :: Mt(2)

    ! heaviside step function
    real(kind=8) :: delta(unum)
    delta = (sign(1.d0, uspace) + 1.d0) / 2.d0

    !--------------------------------------------------
    ! upwind reconstruction
    !--------------------------------------------------
    h = hL * delta + hR * (1.d0 - delta)
    b = bL * delta + bR * (1.d0 - delta)

    sh = shL * delta + shR * (1.d0 - delta)
    sb = sbL * delta + sbR * (1.d0 - delta)

    Mt(1) = dt
    Mt(2) = 0.5d0 * dt**2

    !--------------------------------------------------
    ! fluxes
    !--------------------------------------------------
    ! macro flux
    fluxw(1) = Mt(1) * sum(weight * uspace * h) - Mt(2) * sum(weight * uspace**2 * sh)
    fluxw(2) = Mt(1) * sum(weight * uspace**2 * h) - Mt(2) * sum(weight * uspace**3 * sh)
    fluxw(3) = Mt(1) * 0.5d0 * (sum(weight * uspace * uspace**2 * h) + sum(weight * uspace * b)) - &
               Mt(2) * 0.5d0 * (sum(weight * uspace**2 * uspace**2 * sh) + sum(weight * uspace**2 * sb))

    ! micro flux
    fluxh = Mt(1) * uspace * h - Mt(2) * uspace**2 * sh
    fluxb = Mt(1) * uspace * b - Mt(2) * uspace**2 * sb

end


      subroutine fpcuro(a,b,c,d,x,n)
c  subroutine fpcuro finds the real zeros of a cubic polynomial
c  p(x) = a*x**3+b*x**2+c*x+d.
c
c  calling sequence:
c     call fpcuro(a,b,c,d,x,n)
c
c  input parameters:
c    a,b,c,d: real values, containing the coefficients of p(x).
c
c  output parameters:
c    x      : real array,length 3, which contains the real zeros of p(x)
c    n      : integer, giving the number of real zeros of p(x).
c  ..
c  ..scalar arguments..
      real*8 a,b,c,d
      integer n
c  ..array argument..
      real*8 x(3)
c  ..local scalars..
      integer i
      real*8 a1,b1,c1,df,disc,d1,e3,f,four,half,ovfl,pi3,p3,q,r,
     * step,tent,three,two,u,u1,u2,y
c  ..function references..
      real*8 abs,max,datan,atan2,cos,sign,sqrt
c  set constants
      two = 0.2d+01
      three = 0.3d+01
      four = 0.4d+01
      ovfl =0.1d+05
      half = 0.5d+0
      tent = 0.1d+0
      e3 = tent/0.3d0
      pi3 = datan(0.1d+01)/0.75d0
      a1 = abs(a)
      b1 = abs(b)
      c1 = abs(c)
      d1 = abs(d)
c  test whether p(x) is a third degree polynomial.
      if(max(b1,c1,d1).lt.a1*ovfl) go to 300
c  test whether p(x) is a second degree polynomial.
      if(max(c1,d1).lt.b1*ovfl) go to 200
c  test whether p(x) is a first degree polynomial.
      if(d1.lt.c1*ovfl) go to 100
c  p(x) is a constant function.
      n = 0
      go to 800
c  p(x) is a first degree polynomial.
 100  n = 1
      x(1) = -d/c
      go to 500
c  p(x) is a second degree polynomial.
 200  disc = c*c-four*b*d
      n = 0
      if(disc.lt.0.) go to 800
      n = 2
      u = sqrt(disc)
      b1 = b+b
      x(1) = (-c+u)/b1
      x(2) = (-c-u)/b1
      go to 500
c  p(x) is a third degree polynomial.
 300  b1 = b/a*e3
      c1 = c/a
      d1 = d/a
      q = c1*e3-b1*b1
      r = b1*b1*b1+(d1-b1*c1)*half
      disc = q*q*q+r*r
      if(disc.gt.0.) go to 400
      u = sqrt(abs(q))
      if(r.lt.0.) u = -u
      p3 = atan2(sqrt(-disc),abs(r))*e3
      u2 = u+u
      n = 3
      x(1) = -u2*cos(p3)-b1
      x(2) = u2*cos(pi3-p3)-b1
      x(3) = u2*cos(pi3+p3)-b1
      go to 500
 400  u = sqrt(disc)
      u1 = -r+u
      u2 = -r-u
      n = 1
      x(1) = sign(abs(u1)**e3,u1)+sign(abs(u2)**e3,u2)-b1
c  apply a newton iteration to improve the accuracy of the roots.
 500  do 700 i=1,n
        y = x(i)
        f = ((a*y+b)*y+c)*y+d
        df = (three*a*y+two*b)*y+c
        step = 0.
        if(abs(f).lt.abs(df)*tent) step = f/df
        x(i) = y-step
 700  continue
 800  return
      end


      SUBROUTINE SB16AD( DICO, JOBC, JOBO, JOBMR, WEIGHT, EQUIL, ORDSEL,
     $                   N, M, P, NC, NCR, ALPHA, A, LDA, B, LDB,
     $                   C, LDC, D, LDD, AC, LDAC, BC, LDBC, CC, LDCC,
     $                   DC, LDDC, NCS, HSVC, TOL1, TOL2, IWORK, DWORK,
     $                   LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a reduced order controller (Acr,Bcr,Ccr,Dcr) for an
C     original state-space controller representation (Ac,Bc,Cc,Dc) by
C     using the frequency-weighted square-root or balancing-free
C     square-root Balance & Truncate (B&T) or Singular Perturbation
C     Approximation (SPA) model reduction methods. The algorithm tries
C     to minimize the norm of the frequency-weighted error
C
C           ||V*(K-Kr)*W||
C
C     where K and Kr are the transfer-function matrices of the original
C     and reduced order controllers, respectively. V and W are special
C     frequency-weighting transfer-function matrices constructed
C     to enforce closed-loop stability and/or closed-loop performance.
C     If G is the transfer-function matrix of the open-loop system, then
C     the following weightings V and W can be used:
C                      -1
C      (a)   V = (I-G*K) *G, W = I - to enforce closed-loop stability;
C                              -1
C      (b)   V = I,  W = (I-G*K) *G - to enforce closed-loop stability;
C                      -1              -1
C      (c)   V = (I-G*K) *G, W = (I-G*K)  - to enforce closed-loop
C            stability and performance.
C
C     G has the state space representation (A,B,C,D).
C     If K is unstable, only the ALPHA-stable part of K is reduced.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the original controller as follows:
C             = 'C':  continuous-time controller;
C             = 'D':  discrete-time controller.
C
C     JOBC    CHARACTER*1
C             Specifies the choice of frequency-weighted controllability
C             Grammian as follows:
C             = 'S': choice corresponding to standard Enns' method [1];
C             = 'E': choice corresponding to the stability enhanced
C                    modified Enns' method of [2].
C
C     JOBO    CHARACTER*1
C             Specifies the choice of frequency-weighted observability
C             Grammian as follows:
C             = 'S': choice corresponding to standard Enns' method [1];
C             = 'E': choice corresponding to the stability enhanced
C                    modified combination method of [2].
C
C     JOBMR   CHARACTER*1
C             Specifies the model reduction approach to be used
C             as follows:
C             = 'B':  use the square-root B&T method;
C             = 'F':  use the balancing-free square-root B&T method;
C             = 'S':  use the square-root SPA method;
C             = 'P':  use the balancing-free square-root SPA method.
C
C     WEIGHT  CHARACTER*1
C             Specifies the type of frequency-weighting, as follows:
C             = 'N':  no weightings are used (V = I, W = I);
C             = 'O':  stability enforcing left (output) weighting
C                               -1
C                     V = (I-G*K) *G is used (W = I);
C             = 'I':  stability enforcing right (input) weighting
C                               -1
C                     W = (I-G*K) *G is used (V = I);
C             = 'P':  stability and performance enforcing weightings
C                               -1                -1
C                     V = (I-G*K) *G ,  W = (I-G*K)  are used.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to preliminarily
C             equilibrate the triplets (A,B,C) and (Ac,Bc,Cc) as
C             follows:
C             = 'S':  perform equilibration (scaling);
C             = 'N':  do not perform equilibration.
C
C     ORDSEL  CHARACTER*1
C             Specifies the order selection method as follows:
C             = 'F':  the resulting order NCR is fixed;
C             = 'A':  the resulting order NCR is automatically
C                     determined on basis of the given tolerance TOL1.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the open-loop system state-space
C             representation, i.e., the order of the 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     NC      (input) INTEGER
C             The order of the controller state-space representation,
C             i.e., the order of the matrix AC.  NC >= 0.
C
C     NCR     (input/output) INTEGER
C             On entry with ORDSEL = 'F', NCR is the desired order of
C             the resulting reduced order controller.  0 <= NCR <= NC.
C             On exit, if INFO = 0, NCR is the order of the resulting
C             reduced order controller. For a controller with NCU
C             ALPHA-unstable eigenvalues and NCS ALPHA-stable
C             eigenvalues (NCU+NCS = NC), NCR is set as follows:
C             if ORDSEL = 'F', NCR is equal to
C             NCU+MIN(MAX(0,NCR-NCU),NCMIN), where NCR is the desired
C             order on entry, NCMIN is the number of frequency-weighted
C             Hankel singular values greater than NCS*EPS*S1, EPS is the
C             machine precision (see LAPACK Library Routine DLAMCH) and
C             S1 is the largest Hankel singular value (computed in
C             HSVC(1)); NCR can be further reduced to ensure
C             HSVC(NCR-NCU) > HSVC(NCR+1-NCU);
C             if ORDSEL = 'A', NCR is the sum of NCU and the number of
C             Hankel singular values greater than MAX(TOL1,NCS*EPS*S1).
C
C     ALPHA   (input) DOUBLE PRECISION
C             Specifies the ALPHA-stability boundary for the eigenvalues
C             of the state dynamics matrix AC. For a continuous-time
C             controller (DICO = 'C'), ALPHA <= 0 is the boundary value
C             for the real parts of eigenvalues; for a discrete-time
C             controller (DICO = 'D'), 0 <= ALPHA <= 1 represents the
C             boundary value for the moduli of eigenvalues.
C             The ALPHA-stability domain does not include the boundary.
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 dynamics matrix A of the open-loop
C             system.
C             On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-N
C             part of this array contains the scaled state dynamics
C             matrix of the open-loop system.
C             If EQUIL = 'N', this array is unchanged on exit.
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/state matrix B of the open-loop system.
C             On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-M
C             part of this array contains the scaled input/state matrix
C             of the open-loop system.
C             If EQUIL = 'N', this array is unchanged on exit.
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 state/output matrix C of the open-loop system.
C             On exit, if INFO = 0 and EQUIL = 'S', the leading P-by-N
C             part of this array contains the scaled state/output matrix
C             of the open-loop system.
C             If EQUIL = 'N', this array is unchanged on exit.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading P-by-M part of this array must contain the
C             input/output matrix D of the open-loop system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     AC      (input/output) DOUBLE PRECISION array, dimension (LDAC,NC)
C             On entry, the leading NC-by-NC part of this array must
C             contain the state dynamics matrix Ac of the original
C             controller.
C             On exit, if INFO = 0, the leading NCR-by-NCR part of this
C             array contains the state dynamics matrix Acr of the
C             reduced controller. The resulting Ac has a
C             block-diagonal form with two blocks.
C             For a system with NCU ALPHA-unstable eigenvalues and
C             NCS ALPHA-stable eigenvalues (NCU+NCS = NC), the leading
C             NCU-by-NCU block contains the unreduced part of Ac
C             corresponding to the ALPHA-unstable eigenvalues.
C             The trailing (NCR+NCS-NC)-by-(NCR+NCS-NC) block contains
C             the reduced part of Ac corresponding to ALPHA-stable
C             eigenvalues.
C
C     LDAC    INTEGER
C             The leading dimension of array AC.  LDAC >= MAX(1,NC).
C
C     BC      (input/output) DOUBLE PRECISION array, dimension (LDBC,P)
C             On entry, the leading NC-by-P part of this array must
C             contain the input/state matrix Bc of the original
C             controller.
C             On exit, if INFO = 0, the leading NCR-by-P part of this
C             array contains the input/state matrix Bcr of the reduced
C             controller.
C
C     LDBC    INTEGER
C             The leading dimension of array BC.  LDBC >= MAX(1,NC).
C
C     CC      (input/output) DOUBLE PRECISION array, dimension (LDCC,NC)
C             On entry, the leading M-by-NC part of this array must
C             contain the state/output matrix Cc of the original
C             controller.
C             On exit, if INFO = 0, the leading M-by-NCR part of this
C             array contains the state/output matrix Ccr of the reduced
C             controller.
C
C     LDCC    INTEGER
C             The leading dimension of array CC.  LDCC >= MAX(1,M).
C
C     DC      (input/output) DOUBLE PRECISION array, dimension (LDDC,P)
C             On entry, the leading M-by-P part of this array must
C             contain the input/output matrix Dc of the original
C             controller.
C             On exit, if INFO = 0, the leading M-by-P part of this
C             array contains the input/output matrix Dcr of the reduced
C             controller.
C
C     LDDC    INTEGER
C             The leading dimension of array DC.  LDDC >= MAX(1,M).
C
C     NCS     (output) INTEGER
C             The dimension of the ALPHA-stable part of the controller.
C
C     HSVC    (output) DOUBLE PRECISION array, dimension (NC)
C             If INFO = 0, the leading NCS elements of this array
C             contain the frequency-weighted Hankel singular values,
C             ordered decreasingly, of the ALPHA-stable part of the
C             controller.
C
C     Tolerances
C
C     TOL1    DOUBLE PRECISION
C             If ORDSEL = 'A', TOL1 contains the tolerance for
C             determining the order of the reduced controller.
C             For model reduction, the recommended value is
C             TOL1 = c*S1, where c is a constant in the
C             interval [0.00001,0.001], and S1 is the largest
C             frequency-weighted Hankel singular value of the
C             ALPHA-stable part of the original controller
C             (computed in HSVC(1)).
C             If TOL1 <= 0 on entry, the used default value is
C             TOL1 = NCS*EPS*S1, where NCS is the number of
C             ALPHA-stable eigenvalues of Ac and EPS is the machine
C             precision (see LAPACK Library Routine DLAMCH).
C             If ORDSEL = 'F', the value of TOL1 is ignored.
C
C     TOL2    DOUBLE PRECISION
C             The tolerance for determining the order of a minimal
C             realization of the ALPHA-stable part of the given
C             controller. The recommended value is TOL2 = NCS*EPS*S1.
C             This value is used by default if TOL2 <= 0 on entry.
C             If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (MAX(1,LIWRK1,LIWRK2))
C             LIWRK1 = 0,       if JOBMR  = 'B';
C             LIWRK1 = NC,      if JOBMR  = 'F';
C             LIWRK1 = 2*NC,    if JOBMR  = 'S' or 'P';
C             LIWRK2 = 0,       if WEIGHT = 'N';
C             LIWRK2 = 2*(M+P), if WEIGHT = 'O', 'I', or 'P'.
C             On exit, if INFO = 0, IWORK(1) contains NCMIN, the order
C             of the computed minimal realization of the stable part of
C             the controller.
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.
C             LDWORK >= 2*NC*NC + MAX( 1, LFREQ, LSQRED ),
C             where
C             LFREQ = (N+NC)*(N+NC+2*M+2*P)+
C                     MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4))
C                                      if WEIGHT = 'I' or 'O' or 'P';
C             LFREQ  = NC*(MAX(M,P)+5) if WEIGHT = 'N' and EQUIL = 'N';
C             LFREQ  = MAX(N,NC*(MAX(M,P)+5)) if WEIGHT = 'N' and
C                                                EQUIL  = 'S';
C             LSQRED = MAX( 1, 2*NC*NC+5*NC );
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  with ORDSEL = 'F', the selected order NCR is greater
C                   than NSMIN, the sum of the order of the
C                   ALPHA-unstable part and the order of a minimal
C                   realization of the ALPHA-stable part of the given
C                   controller; in this case, the resulting NCR is set
C                   equal to NSMIN;
C             = 2:  with ORDSEL = 'F', the selected order NCR
C                   corresponds to repeated singular values for the
C                   ALPHA-stable part of the controller, which are
C                   neither all included nor all excluded from the
C                   reduced model; in this case, the resulting NCR is
C                   automatically decreased to exclude all repeated
C                   singular values;
C             = 3:  with ORDSEL = 'F', the selected order NCR is less
C                   than the order of the ALPHA-unstable part of the
C                   given controller. In this case NCR is set equal to
C                   the order of the ALPHA-unstable part.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the closed-loop system is not well-posed;
C                   its feedthrough matrix is (numerically) singular;
C             = 2:  the computation of the real Schur form of the
C                   closed-loop state matrix failed;
C             = 3:  the closed-loop state matrix is not stable;
C             = 4:  the solution of a symmetric eigenproblem failed;
C             = 5:  the computation of the ordered real Schur form of Ac
C                   failed;
C             = 6:  the separation of the ALPHA-stable/unstable
C                   diagonal blocks failed because of very close
C                   eigenvalues;
C             = 7:  the computation of Hankel singular values failed.
C
C     METHOD
C
C     Let K be the transfer-function matrix of the original linear
C     controller
C
C          d[xc(t)] = Ac*xc(t) + Bc*y(t)
C          u(t)     = Cc*xc(t) + Dc*y(t),                      (1)
C
C     where d[xc(t)] is dxc(t)/dt for a continuous-time system and
C     xc(t+1) for a discrete-time system. The subroutine SB16AD
C     determines the matrices of a reduced order controller
C
C          d[z(t)] = Acr*z(t) + Bcr*y(t)
C          u(t)    = Ccr*z(t) + Dcr*y(t),                      (2)
C
C     such that the corresponding transfer-function matrix Kr minimizes
C     the norm of the frequency-weighted error
C
C             V*(K-Kr)*W,                                      (3)
C
C     where V and W are special stable transfer-function matrices
C     chosen to enforce stability and/or performance of the closed-loop
C     system [3] (see description of the parameter WEIGHT).
C
C     The following procedure is used to reduce K in conjunction
C     with the frequency-weighted balancing approach of [2]
C     (see also [3]):
C
C     1) Decompose additively K, of order NC, as
C
C          K = K1 + K2,
C
C        such that K1 has only ALPHA-stable poles and K2, of order NCU,
C        has only ALPHA-unstable poles.
C
C     2) Compute for K1 a B&T or SPA frequency-weighted approximation
C        K1r of order NCR-NCU using the frequency-weighted balancing
C        approach of [1] in conjunction with accuracy enhancing
C        techniques specified by the parameter JOBMR.
C
C     3) Assemble the reduced model Kr as
C
C           Kr = K1r + K2.
C
C     For the reduction of the ALPHA-stable part, several accuracy
C     enhancing techniques can be employed (see [2] for details).
C
C     If JOBMR = 'B', the square-root B&T method of [1] is used.
C
C     If JOBMR = 'F', the balancing-free square-root version of the
C     B&T method [1] is used.
C
C     If JOBMR = 'S', the square-root version of the SPA method [2,3]
C     is used.
C
C     If JOBMR = 'P', the balancing-free square-root version of the
C     SPA method [2,3] is used.
C
C     For each of these methods, two left and right truncation matrices
C     are determined using the Cholesky factors of an input
C     frequency-weighted controllability Grammian P and an output
C     frequency-weighted observability Grammian Q.
C     P and Q are determined as the leading NC-by-NC diagonal blocks
C     of the controllability Grammian of K*W and of the
C     observability Grammian of V*K. Special techniques developed in [2]
C     are used to compute the Cholesky factors of P and Q directly
C     (see also SLICOT Library routine SB16AY).
C     The frequency-weighted Hankel singular values HSVC(1), ....,
C     HSVC(NC) are computed as the square roots of the eigenvalues
C     of the product P*Q.
C
C     REFERENCES
C
C     [1] Enns, D.
C         Model reduction with balanced realizations: An error bound
C         and a frequency weighted generalization.
C         Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984.
C
C     [2] Varga, A. and Anderson, B.D.O.
C         Square-root balancing-free methods for frequency-weighted
C         balancing related model reduction.
C         (report in preparation)
C
C     [3] Anderson, B.D.O and Liu, Y.
C         Controller reduction: concepts and approaches.
C         IEEE Trans. Autom. Control, Vol. 34, pp. 802-812, 1989.
C
C     NUMERICAL ASPECTS
C
C     The implemented methods rely on accuracy enhancing square-root
C     techniques.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, Sept. 2000.
C     D. Sima, University of Bucharest, Sept. 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Sept.2000.
C
C     REVISIONS
C
C     A. Varga, Australian National University, Canberra, November 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000,
C              Sep. 2001.
C
C     KEYWORDS
C
C     Controller reduction, frequency weighting, multivariable system,
C     state-space model, state-space representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  C100, ONE, ZERO
      PARAMETER         ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, EQUIL, JOBC, JOBO, JOBMR, ORDSEL, WEIGHT
      INTEGER           INFO, IWARN, LDA, LDAC, LDB, LDBC, LDC, LDCC,
     $                  LDD, LDDC, LDWORK, M, N, NC, NCR, NCS, P
      DOUBLE PRECISION  ALPHA, TOL1, TOL2
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*),
     $                  C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*),
     $                  DWORK(*), HSVC(*)
C     .. Local Scalars ..
      LOGICAL           BTA, DISCR, FIXORD, FRWGHT, ISTAB, LEFTW, OSTAB,
     $                  PERF, RIGHTW, SPA
      INTEGER           IERR, IWARNL, KI, KR, KT, KTI, KU, KW, LW, MP,
     $                  NCU, NCU1, NMR, NNC, NRA, WRKOPT
      DOUBLE PRECISION  ALPWRK, MAXRED, SCALEC, SCALEO
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          AB09IX, SB16AY, TB01ID, TB01KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      INFO   = 0
      IWARN  = 0
      DISCR  = LSAME( DICO,   'D' )
      BTA    = LSAME( JOBMR,  'B' ) .OR. LSAME( JOBMR, 'F' )
      SPA    = LSAME( JOBMR,  'S' ) .OR. LSAME( JOBMR, 'P' )
      FIXORD = LSAME( ORDSEL, 'F' )
      ISTAB  = LSAME( WEIGHT, 'I' )
      OSTAB  = LSAME( WEIGHT, 'O' )
      PERF   = LSAME( WEIGHT, 'P' )
      LEFTW  = OSTAB .OR. PERF
      RIGHTW = ISTAB .OR. PERF
      FRWGHT = LEFTW .OR. RIGHTW
C
      LW  = 1
      NNC = N + NC
      MP  = M + P
      IF( FRWGHT ) THEN
         LW = NNC*( NNC + 2*MP ) +
     $        MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) )
      ELSE
         LW = NC*( MAX( M, P ) + 5 )
         IF ( LSAME( EQUIL, 'S' ) )
     $      LW = MAX( N, LW )
      END IF
      LW = 2*NC*NC + MAX( 1, LW, NC*( 2*NC + 5 ) )
C
C     Check the input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) )
     $     THEN
         INFO = -2
      ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) )
     $     THEN
         INFO = -3
      ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN
         INFO = -4
      ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN
         INFO = -5
      ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR.
     $                 LSAME( EQUIL, 'N' ) ) ) THEN
         INFO = -6
      ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN
         INFO = -7
      ELSE IF( N.LT.0 ) THEN
         INFO = -8
      ELSE IF( M.LT.0 ) THEN
         INFO = -9
      ELSE IF( P.LT.0 ) THEN
         INFO = -10
      ELSE IF( NC.LT.0 ) THEN
         INFO = -11
      ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.NC ) ) THEN
         INFO = -12
      ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR.
     $    ( .NOT.DISCR .AND.   ALPHA.GT.ZERO ) ) THEN
         INFO = -13
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -19
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -21
      ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN
         INFO = -23
      ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN
         INFO = -25
      ELSE IF( LDCC.LT.MAX( 1, M  ) ) THEN
         INFO = -27
      ELSE IF( LDDC.LT.MAX( 1, M  ) ) THEN
         INFO = -29
      ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN
         INFO = -33
      ELSE IF( LDWORK.LT.LW ) THEN
         INFO = -36
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB16AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( NC, M, P ).EQ.0 ) THEN
         NCR = 0
         NCS = 0
         IWORK(1) = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF( LSAME( EQUIL, 'S' ) ) THEN
C
C        Scale simultaneously the matrices A, B and C and AC, BC and CC;
C        A <- inv(T1)*A*T1, B <- inv(T1)*B and C <- C*T1, where T1 is a
C        diagonal matrix;
C        AC <- inv(T2)*AC*T2, BC <- inv(T2)*BC and CC <- CC*T2, where T2
C        is a diagonal matrix.
C
C        Real workspace: need MAX(N,NC).
C
         MAXRED = C100
         CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                DWORK, INFO )
         MAXRED = C100
         CALL TB01ID( 'All', NC, P, M, MAXRED, AC, LDAC, BC, LDBC,
     $                CC, LDCC, DWORK, INFO )
      END IF
C
C     Correct the value of ALPHA to ensure stability.
C
      ALPWRK = ALPHA
      IF( DISCR ) THEN
         IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) )
      ELSE
         IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) )
      END IF
C
C     Reduce Ac to a block-diagonal real Schur form, with the
C     ALPHA-unstable part in the leading diagonal position, using a
C     non-orthogonal similarity transformation, AC <- inv(T)*AC*T, and
C     apply the transformation to BC and CC:
C     BC <- inv(T)*BC and CC <- CC*T.
C
C     Workspace:  need   NC*(NC+5);
C                 prefer larger.
C
      WRKOPT = 1
      KU = 1
      KR = KU + NC*NC
      KI = KR + NC
      KW = KI + NC
C
      CALL TB01KD( DICO, 'Unstable', 'General', NC, P, M, ALPWRK,
     $             AC, LDAC, BC, LDBC, CC, LDCC, NCU, DWORK(KU), NC,
     $             DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR )
C
      IF( IERR.NE.0 ) THEN
         IF( IERR.NE.3 ) THEN
            INFO = 5
         ELSE
            INFO = 6
         END IF
         RETURN
      END IF
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
      IWARNL = 0
      NCS = NC - NCU
      IF( FIXORD ) THEN
         NRA = MAX( 0, NCR-NCU )
         IF( NCR.LT.NCU )
     $      IWARNL = 3
      ELSE
         NRA = 0
      END IF
C
C     Finish if only unstable part is present.
C
      IF( NCS.EQ.0 ) THEN
         NCR = NCU
         IWORK(1) = 0
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Allocate working storage.
C
      KT  = 1
      KTI = KT  + NC*NC
      KW  = KTI + NC*NC
C
C     Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R
C     of the frequency-weighted controllability and observability
C     Grammians, respectively.
C
C     Real workspace:  need  2*NC*NC + MAX( 1, LFREQ ),
C                      where
C                      LFREQ = (N+NC)*(N+NC+2*M+2*P)+
C                              MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7),
C                                  (M+P)*(M+P+4))
C                                         if WEIGHT = 'I' or 'O' or 'P';
C                      LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N';
C                      prefer larger.
C     Integer workspace:      2*(M+P) if WEIGHT = 'I' or 'O' or 'P';
C                             0,      if WEIGHT = 'N'.
C
      CALL SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS,
     $             A, LDA, B, LDB, C, LDC, D, LDD,
     $             AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC,
     $             SCALEC, SCALEO, DWORK(KTI), NC, DWORK(KT), NC,
     $             IWORK, DWORK(KW), LDWORK-KW+1, INFO )
      IF( INFO.NE.0 )
     $   RETURN
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Compute a BTA or SPA of the stable part.
C     Real workspace:  need   2*NC*NC + MAX( 1, 2*NC*NC+5*NC,
C                                               NC*MAX(M,P) );
C                      prefer larger.
C     Integer workspace:      0,     if JOBMR = 'B';
C                             NC,    if JOBMR = 'F';
C                             2*NC,  if JOBMR = 'S' or 'P'.
C
      NCU1 = NCU + 1
      CALL AB09IX( DICO, JOBMR, 'Schur', ORDSEL, NCS, P, M, NRA, SCALEC,
     $             SCALEO, AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC,
     $             CC(1,NCU1), LDCC, DC, LDDC, DWORK(KTI), NC,
     $             DWORK(KT), NC, NMR, HSVC, TOL1, TOL2, IWORK,
     $             DWORK(KW), LDWORK-KW+1, IWARN, IERR )
      IWARN = MAX( IWARN, IWARNL )
      IF( IERR.NE.0 ) THEN
         INFO = 7
         RETURN
      END IF
      NCR = NRA + NCU
      IWORK(1) = NMR
C
      DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
      RETURN
C *** Last line of SB16AD ***
      END


      program gaussfit

c***********************************************************************
c
c     program to fit a lennard jones potential with a sum of gaussians
c
c     author k. singer (modified by w. smith)
c
c***********************************************************************

      implicit none

      integer i,k,l,m
      real(8) varm,r,rr,f1,f2,dr1,dr2,a11,dr3,a12,a22,a21,a31,a32,a33
      real(8) a13,a23,b1,b2,b3,det,absd,var,ca1,ca2,ca3,da1,da2,da3
      real(8) c1,c2,c3
      real(8) f(200),g1(200),g2(200),g3(200),gg(200),dd(3),dx(3),d(3)

      varm=1.0d+25
      write(6,"(1x,'gaussian potential fitting program',//)")

c     set up array for standard potential

      r=0.91d0
      do i=1,163

        r=r+0.01d0
        rr=r*r
        f1=1.d0/rr
        f2=f1*f1*f1
        f1=f2*f2
        f(i)=4.d0*(f1-f2)

      enddo

c     set initial guesses for exponents

      dx(1)=0.443d0
      dx(2)=1.544d0
      dx(3)=8.502d0
      dd(1)=3.889d-3
      dd(2)=3.889d-3
      dd(3)=7.779d-3

c     adjustment of first exponent

      do k=0,5

        d(1)=dx(1)+dble(k-3)*dd(1)

c     adjustment of second exponent

        do l=0,5

          d(2)=dx(2)+dble(l-3)*dd(2)

c     adjustment of third exponent

          do m=0,5

            d(3)=dx(3)+float(m-3)*dd(3)

c     store current exponents

            dr1=d(1)
            dr2=d(2)
            dr3=d(3)

c     initialise least squares parameters

            a11=0.d0
            a12=0.d0
            a22=0.d0
            a21=0.d0
            a31=0.d0
            a32=0.d0
            a33=0.d0
            a13=0.d0
            a23=0.d0
            b1=0.d0
            b2=0.d0
            b3=0.d0

c     calculate least squares parameters

            r=0.91d0
            do i=1,163

              r=r+0.01d0
              rr=r*r
              g1(i)=exp(-rr*dr1)
              g2(i)=exp(-rr*dr2)
              g3(i)=exp(-rr*dr3)
              a11=a11+g1(i)**2
              a12=a12+g1(i)*g2(i)
              a22=a22+g2(i)**2
              a13=a13+g1(i)*g3(i)
              a23=a23+g2(i)*g3(i)
              a33=a33+g3(i)**2
              b1=b1+g1(i)*f(i)
              b2=b2+g2(i)*f(i)
              b3=b3+g3(i)*f(i)

            enddo

            det=a11*(a22*a33-a23*a23)
     x        +a12*(a23*a13-a12*a33)
     x        +a13*(a12*a23-a22*a13)
            absd=abs(det)
            if(absd.le.2.0d-20)then
              write(6,"(1x,'error - determinant too small')")
            else

c     calculate coefficients

              c1=(b1*(a22*a33-a23*a23)+b2*(a13*a23-a12*a33)+
     x          b3*(a12*a23-a13*a22))/det
              c2=(b1*(a23*a13-a12*a33)+b2*(a11*a33-a13*a13)+
     x          b3*(a12*a13-a11*a23))/det
              c3=(b1*(a12*a23-a22*a13)+b2*(a12*a13-a11*a23)+
     x          b3*(a11*a22-a12*a12))/det

            endif

c     construct approximating potential array

            var=0.d0
            r=0.91d0
            do i=1,163

              r=r+0.01d0
              gg(i)=c1*g1(i)+c2*g2(i)+c3*g3(i)
              var=var+r*(f(i)-gg(i))**2

            enddo

            if(var.le.varm)then

c     update potential parameters

              write(6,'(1x,3i5)')k,l,m
              varm=var
              ca1=c1
              ca2=c2
              ca3=c3
              da1=d(1)
              da2=d(2)
              da3=d(3)

c     print out current values

              write(6,"(1x,'var = ',e15.6,/,1x,'c(l)= ',3e15.6,/,
     x          1x,'d(l)= ',3e15.6)")var,ca1,ca2,ca3,da1,da2,da3

            endif

          enddo

          dx(3)=da3

        enddo

        dx(2)=da2

      enddo

      dx(1)=da1

c     print out best parameters

      write(6,"(1x,'best coefficients',5x,3e15.6,/,
     x  1x,'best exponents   ',5x,3e15.6,/,/,
     x  1x,10x,'rad',11x,'f(i)',10x,'gg(i)',/)")
     x  ca1,ca2,ca3,da1,da2,da3

c     print out potential arrays for comparison

      r=0.91d0
      do i=1,163

        r=r+0.01d0
        write(6,'(3e15.6)')r,f(i),gg(i)

      enddo

      end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Name   : CQZ (Nb, UL, UR, ZZ, uk)
c     Purpuse: driver for solving the GEP, UL Bk = uk UR Bk
c     Inputs : Nb define the dimension of UR and UL
c              on return UL is destroyed, UR is not changed.
c     Ouputs : ZZ contains the normalized eigenvector
c              uk contains the eigenvalues
c     Author : Jianhan Chen (jianhanc@uci.edu)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine CQZ(Nb, UL, UR, ZZ, uk)
      implicit none
      integer Nb, i, j, k, n, ierr
      complex*16 UL(Nb,Nb), UR(Nb,Nb), U0(Nb,Nb), ZZ(Nb,Nb),
     &     uk(Nb), alf(Nb), cc, uu
      real*8 beta(Nb)
c
      do i=1,Nb
         do j=1,Nb
            U0(i,j)=UR(i,j)
         enddo
      enddo
      call CQZHES(Nb,Nb,UL,U0,.true.,ZZ)
      call CQZVAL(Nb,Nb,UL,U0,0d0,alf,beta,.true.,ZZ,IERR)
      if(IERR.ne.0) then
         write(6,*) '#########################'
         write(6,*) '###  IERR=',IERR
         write(6,*) '#########################'
      endif
      call CQZVEC(Nb,Nb,UL,U0,alf,beta,ZZ)
c
      do k=1,Nb
         if(beta(k).le.1d-8) then
            uk(k)=cdexp(dcmplx(-10,-10))
            do j=1, Nb
               ZZ(j,k)=(0,0d0)
            enddo
         else
            uk(k)=alf(k)/beta(k)
            cc=(0,0d0)
            do j=1,Nb
               uu=0.0d0
               do n=1,Nb
                  uu=uu+UR(j,n)*ZZ(n,k)
               enddo
               cc=cc+ZZ(j,k)*uu
            enddo
            cc=(1d0,0)/cdsqrt(cc)
            do j=1,Nb
               ZZ(j,k)=cc*ZZ(j,k)
            enddo
         endif
      enddo
      return
      end
C
C     ------------------------------------------------------------------
C
      SUBROUTINE CQZHES(NM,N,A,B,MATZ,Z)
!!
!! This and the two following subroutines
!! were modified by V.Mandelshtam (Sep.1/1998)
!! to change the real arrays by complex
!!
      implicit none
      INTEGER I,J,K,L,N,K1,LB,L1,NM,NK1,NM1
      COMPLEX*16 A(NM,N),B(NM,N),Z(NM,N)
      REAL*8 R,S,U2,XR,RHO
      REAL*8 DSQRT,CDABS,DABS
      LOGICAL MATZ
      COMPLEX*16 DCMPLX,U1,T,X,Y
C
C     THIS SUBROUTINE IS A COMPLEX ANALOGUE OF THE FIRST STEP OF THE
C     QZ ALGORITHM FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C     SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
C
C     THIS SUBROUTINE ACCEPTS A PAIR OF COMPLEX GENERAL MATRICES AND
C     REDUCES ONE OF THEM TO UPPER HESSENBERG FORM WITH REAL (AND NON-
C     NEGATIVE) SUBDIAGONAL ELEMENTS AND THE OTHER TO UPPER TRIANGULAR
C     FORM USING UNITARY TRANSFORMATIONS.  IT IS USUALLY FOLLOWED BY
C     CQZVAL  AND POSSIBLY  CQZVEC.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRICES,
C
C        A=(AR,AI) CONTAINS A COMPLEX GENERAL MATRIX,
C
C        B=(BR,BI) CONTAINS A COMPLEX GENERAL MATRIX,
C
C        MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
C          ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
C          EIGENVECTORS, AND TO .FALSE. OTHERWISE.
C
C     ON OUTPUT-
C
C        A HAS BEEN REDUCED TO UPPER HESSENBERG FORM.  THE ELEMENTS
C          BELOW THE FIRST SUBDIAGONAL HAVE BEEN SET TO ZERO, AND THE
C          SUBDIAGONAL ELEMENTS HAVE BEEN MADE REAL (AND NON-NEGATIVE),
C
C        B HAS BEEN REDUCED TO UPPER TRIANGULAR FORM.  THE ELEMENTS
C          BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO,
C
C        Z=(ZR,ZI) CONTAINS THE PRODUCT OF THE RIGHT HAND
C          TRANSFORMATIONS IF MATZ HAS BEEN SET TO .TRUE.
C          OTHERWISE, Z IS NOT REFERENCED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C     ********** INITIALIZE Z **********
      IF (.NOT. MATZ) GO TO 10
C
      DO 3 I = 1, N
C
         DO 2 J = 1, N
            Z(I,J) = 0d0
    2    CONTINUE
C
         Z(I,I) = (1d0,0)
    3 CONTINUE
C     ********** REDUCE B TO UPPER TRIANGULAR FORM WITH
C                TEMPORARILY REAL DIAGONAL ELEMENTS **********
   10 IF (N .LE. 1) GO TO 170
      NM1 = N - 1
C
      DO 100 L = 1, NM1
         L1 = L + 1
         S = 0d0
C
         DO 20 I = L, N
            S = S + DABS(dreal(B(I,L))) + DABS(dimag(B(I,L)))
   20    CONTINUE
C
         IF (S .EQ. 0d0) GO TO 100
         RHO = 0d0
C
         DO 25 I = L, N
            B(I,L) = B(I,L) / S
            RHO = RHO + dreal(B(I,L))**2 + dimag(B(I,L))**2
   25    CONTINUE
C
         R = DSQRT(RHO)
         XR = CDABS(B(L,L))
         IF (XR .EQ. 0d0) GO TO 27
         RHO = RHO + XR * R
         U1 = -B(L,L) / XR
         B(L,L) = (R / XR + 1.0) * B(L,L)
         GO TO 28
C
   27    B(L,L) = dcmplx(R,dimag(B(L,L)))
         U1 = (-1d0,0)
C
   28    DO 50 J = L1, N
            T = (0d0,0d0)
C
            DO 30 I = L, N
               T = T + dconjg(B(I,L)) * B(I,J)
   30       CONTINUE
C
            T = T / RHO
C
            DO 40 I = L, N
               B(I,J) = B(I,J) - T * B(I,L)
   40       CONTINUE
C
            B(L,J) = dconjg(U1) * B(L,J)
   50    CONTINUE
C
         DO 80 J = 1, N
            T = (0,0d0)
C
            DO 60 I = L, N
               T = T + dconjg(B(I,L)) * A(I,J)
   60       CONTINUE
C
            T = T / RHO
C
            DO 70 I = L, N
               A(I,J) = A(I,J) - T * B(I,L)
   70       CONTINUE
C
            A(L,J) = dconjg(U1) * A(L,J)
   80    CONTINUE
C
         B(L,L) = dcmplx(R * S,0d0)
C
         DO 90 I = L1, N
            B(I,L) = (0,0d0)
   90    CONTINUE
C
  100 CONTINUE
C     ********** REDUCE A TO UPPER HESSENBERG FORM WITH REAL SUBDIAGONAL
C                ELEMENTS, WHILE KEEPING B TRIANGULAR **********
      DO 160 K = 1, NM1
         K1 = K + 1
C     ********** SET BOTTOM ELEMENT IN K-TH COLUMN OF A REAL **********
         IF (dimag(A(N,K)) .EQ. 0d0) GO TO 105
         R = CDABS(A(N,K))
         U1 = A(N,K) / R
         A(N,K) = dcmplx(R,0d0)
C
         DO 103 J = K1, N
            A(N,J) = dconjg(U1) * A(N,J)
  103    CONTINUE
C
         B(N,N) = dconjg(U1) * B(N,N)
  105    IF (K .EQ. NM1) GO TO 170
         NK1 = NM1 - K
C     ********** FOR L=N-1 STEP -1 UNTIL K+1 DO -- **********
         DO 150 LB = 1, NK1
            L = N - LB
            L1 = L + 1
C     ********** ZERO A(L+1,K) **********
            S = DABS(dreal(A(L,K))) + DABS(dimag(A(L,K)))
     &           + dreal(A(L1,K))
            IF (S .EQ. 0d0) GO TO 150
            U1 = A(L,K) / S
            U2 = dreal(A(L1,K)) / S
            R = DSQRT(dreal(U1)**2+dimag(U1)**2+U2*U2)
            U1 = U1 / R
            U2 = U2 / R
            A(L,K) = dcmplx(R * S,0d0)
            A(L1,K) = dcmplx(0d0,dimag(A(L1,K)))  !  ???????
C
            DO 110 J = K1, N
               X = A(L,J)
               Y = A(L1,J)
               A(L,J) = dconjg(U1) * X + U2 * Y
               A(L1,J) = U1 * Y  - U2 * X
  110       CONTINUE
C
            XR = dreal(B(L,L))
            B(L,L) = dconjg(U1) * XR
            B(L1,L) = dcmplx(-U2 * XR,dimag(B(L1,L)))
C
            DO 120 J = L1, N
               X = B(L,J)
               Y = B(L1,J)
               B(L,J) = dconjg(U1) * X + U2 * Y
               B(L1,J) = U1 * Y  - U2 * X
  120       CONTINUE
C     ********** ZERO B(L+1,L) **********
            S = DABS(dreal(B(L1,L1))) + DABS(dimag(B(L1,L1)))
     &           + DABS(dreal(B(L1,L)))
            IF (S .EQ. 0d0) GO TO 150
            U1 = B(L1,L1) / S
            U2 = dreal(B(L1,L)) / S
            R = DSQRT(dreal(U1)**2+dimag(U1)**2+U2**2)
            U1 = U1 / R
            U2 = U2 / R
            B(L1,L1) = dcmplx(R * S,0d0)
            B(L1,L) = dcmplx(0d0,dimag(B(L1,L)))   ! ???????
C
            DO 130 I = 1, L
               X = B(I,L1)
               Y = B(I,L)
               B(I,L1) = dconjg(U1) * X + U2 * Y
               B(I,L) = U1 * Y - U2 * X
  130       CONTINUE
C
            DO 140 I = 1, N
               X = A(I,L1)
               Y = A(I,L)
               A(I,L1) = dconjg(U1) * X + U2 * Y
               A(I,L) = U1 * Y - U2 * X
  140       CONTINUE
C
            IF (.NOT. MATZ) GO TO 150
C
            DO 145 I = 1, N
               X = Z(I,L1)
               Y = Z(I,L)
               Z(I,L1) = dconjg(U1) * X + U2 * Y
               Z(I,L) = U1 * Y - U2 * X
  145       CONTINUE
C
  150    CONTINUE
C
  160 CONTINUE
C
  170 RETURN
C     ********** LAST CARD OF CQZHES **********
      END
C
C     ------------------------------------------------------------------
C
      SUBROUTINE CQZVAL(NM,N,A,B,EPS1,ALF,BETA,MATZ,Z,IERR)
C
      implicit none
      INTEGER I,J,K,L,N,EN,K1,K2,LL,L1,NA,NM,ITS,KM1,LM1,
     X        ENM2,IERR,LOR1,ENORN,outer,inner
      COMPLEX*16 A(NM,N),B(NM,N),ALF(N),Z(NM,N)
      REAL*8 BETA(N)
      REAL*8 R,S,A2,EP,U2,ANI,BNI,B11,XR,
     X       EPSA,EPSB,EPS1,ANORM,BNORM
      REAL*8 DSQRT,CDABS,DABS
      INTEGER MAX0
      LOGICAL MATZ
      COMPLEX*16 X,Y,Z3,U1,B33,B44,B3344,A1,A33,A34,A43,A44,SH
      COMPLEX*16 CDSQRT,DCMPLX
      REAL*8 DREAL,DIMAG
C
C     THIS SUBROUTINE IS A COMPLEX ANALOGUE OF STEPS 2 AND 3 OF THE
C     QZ ALGORITHM FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C     SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART,
C     AS MODIFIED IN TECHNICAL NOTE NASA TN E-7305(1973) BY WARD.
C
C     THIS SUBROUTINE ACCEPTS A PAIR OF COMPLEX MATRICES, ONE OF THEM
C     IN UPPER HESSENBERG FORM AND THE OTHER IN UPPER TRIANGULAR FORM,
C     THE HESSENBERG MATRIX MUST FURTHER HAVE REAL SUBDIAGONAL ELEMENTS.
C     IT REDUCES THE HESSENBERG MATRIX TO TRIANGULAR FORM USING
C     UNITARY TRANSFORMATIONS WHILE MAINTAINING THE TRIANGULAR FORM
C     OF THE OTHER MATRIX AND FURTHER MAKING ITS DIAGONAL ELEMENTS
C     REAL AND NON-NEGATIVE.  IT THEN RETURNS QUANTITIES WHOSE RATIOS
C     GIVE THE GENERALIZED EIGENVALUES.  IT IS USUALLY PRECEDED BY
C     CQZHES  AND POSSIBLY FOLLOWED BY  CQZVEC.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRICES,
C
C        A=(AR,AI) CONTAINS A COMPLEX UPPER HESSENBERG MATRIX
C          WITH REAL SUBDIAGONAL ELEMENTS,
C
C        B=(BR,BI) CONTAINS A COMPLEX UPPER TRIANGULAR MATRIX,
C
C        EPS1 IS A TOLERANCE USED TO DETERMINE NEGLIGIBLE ELEMENTS.
C          EPS1 = 0d0 (OR NEGATIVE) MAY BE INPUT, IN WHICH CASE AN
C          ELEMENT WILL BE NEGLECTED ONLY IF IT IS LESS THAN ROUNDOFF
C          ERROR TIMES THE NORM OF ITS MATRIX.  IF THE INPUT EPS1 IS
C          POSITIVE, THEN AN ELEMENT WILL BE CONSIDERED NEGLIGIBLE
C          IF IT IS LESS THAN EPS1 TIMES THE NORM OF ITS MATRIX.  A
C          POSITIVE VALUE OF EPS1 MAY RESULT IN FASTER EXECUTION,
C          BUT LESS ACCURATE RESULTS,
C
C        MATZ SHOULD BE SET TO .TRUE. IF THE RIGHT HAND TRANSFORMATIONS
C          ARE TO BE ACCUMULATED FOR LATER USE IN COMPUTING
C          EIGENVECTORS, AND TO .FALSE. OTHERWISE,
C
C        Z=(ZR,ZI) CONTAINS, IF MATZ HAS BEEN SET TO .TRUE., THE
C          TRANSFORMATION MATRIX PRODUCED IN THE REDUCTION
C          BY  CQZHES, IF PERFORMED, OR ELSE THE IDENTITY MATRIX.
C          IF MATZ HAS BEEN SET TO .FALSE., Z IS NOT REFERENCED.
C
C     ON OUTPUT-
C
C        A HAS BEEN REDUCED TO UPPER TRIANGULAR FORM.  THE ELEMENTS
C          BELOW THE MAIN DIAGONAL HAVE BEEN SET TO ZERO,
C
C        B IS STILL IN UPPER TRIANGULAR FORM, ALTHOUGH ITS ELEMENTS
C          HAVE BEEN ALTERED.  IN PARTICULAR, ITS DIAGONAL HAS BEEN SET
C          REAL AND NON-NEGATIVE.  THE LOCATION BR(N,1) IS USED TO
C          STORE EPS1 TIMES THE NORM OF B FOR LATER USE BY  CQZVEC,
C
C        ALFR AND ALFI CONTAIN THE REAL AND IMAGINARY PARTS OF THE
C          DIAGONAL ELEMENTS OF THE TRIANGULARIZED A MATRIX,
C
C        BETA CONTAINS THE REAL NON-NEGATIVE DIAGONAL ELEMENTS OF THE
C          CORRESPONDING B.  THE GENERALIZED EIGENVALUES ARE THEN
C          THE RATIOS ((ALFR+I*ALFI)/BETA),
C
C        Z CONTAINS THE PRODUCT OF THE RIGHT HAND TRANSFORMATIONS
C          (FOR BOTH STEPS) IF MATZ HAS BEEN SET TO .TRUE.,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF AR(J,J-1) HAS NOT BECOME
C                     ZERO AFTER 50 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
      IERR = 0
      outer = 0
      inner = 0
C     ********** COMPUTE EPSA,EPSB **********
      ANORM = 0d0
      BNORM = 0d0
C
      DO 30 I = 1, N
         ANI = 0d0
         IF (I .NE. 1) ANI = DABS(dreal(A(I,I-1)))
         BNI = 0d0
C
         DO 20 J = I, N
            ANI = ANI + DABS(dreal(A(I,J))) + DABS(dimag(A(I,J)))
            BNI = BNI + DABS(dreal(B(I,J))) + DABS(dimag(B(I,J)))
   20    CONTINUE
C
         IF (ANI .GT. ANORM) ANORM = ANI
         IF (BNI .GT. BNORM) BNORM = BNI
   30 CONTINUE
C
      IF (ANORM .EQ. 0d0) ANORM = 1.0
      IF (BNORM .EQ. 0d0) BNORM = 1.0
      EP = EPS1
      IF (EP .GT. 0d0) GO TO 50
C     ********** COMPUTE ROUNDOFF LEVEL IF EPS1 IS ZERO **********
      EP = 1.0
   40 EP = EP / 2.0
      IF (1.0 + EP .GT. 1.0) GO TO 40
   50 EPSA = EP * ANORM
      EPSB = EP * BNORM
C     ********** REDUCE A TO TRIANGULAR FORM, WHILE
C                KEEPING B TRIANGULAR **********
      LOR1 = 1
      ENORN = N
      EN = N
C     ********** BEGIN QZ STEP **********
   60 IF (EN .EQ. 0) GO TO 1001
      IF (.NOT. MATZ) ENORN = EN
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
C     ********** CHECK FOR CONVERGENCE OR REDUCIBILITY.
C                FOR L=EN STEP -1 UNTIL 1 DO -- **********
   70 DO 80 LL = 1, EN
         LM1 = EN - LL
         L = LM1 + 1
         IF (L .EQ. 1) GO TO 95
         IF (DABS(dreal(A(L,LM1))) .LE. EPSA) GO TO 90
   80 CONTINUE
C
   90 A(L,LM1) = dcmplx(0d0,dimag(A(L,LM1)))   !   ??????
C     ********** SET DIAGONAL ELEMENT AT TOP OF B REAL **********
   95 B11 = CDABS(B(L,L))
      IF (B11     .EQ. 0d0) GO TO 98
      U1 = B(L,L) / B11
C
      DO 97 J = L, ENORN
         A(L,J) = dconjg(U1) * A(L,J)
         B(L,J) = dconjg(U1) * B(L,J)
   97 CONTINUE
C
      B(L,L) = dcmplx(dreal(B(L,L)),0d0)           ! ??????
   98 IF (L .NE. EN) GO TO 100
C     ********** 1-BY-1 BLOCK ISOLATED **********
      ALF(EN) = A(EN,EN)
      BETA(EN) = B11
      EN = NA
      GO TO 60
C     ********** CHECK FOR SMALL TOP OF B **********
  100 L1 = L + 1
      IF (B11 .GT. EPSB) GO TO 120
      B(L,L) = dcmplx(0d0,dimag(B(L,L)))           ! ??????
      S = DABS(dreal(A(L,L))) + DABS(dimag(A(L,L)))
     &     + DABS(dreal(A(L1,L)))
      U1 = A(L,L) / S
      U2 = dreal(A(L1,L)) / S
      R = DSQRT(dreal(U1)**2+dimag(U1)**2+U2**2)
      U1 = U1 / R
      U2 = U2 / R
      A(L,L) = dcmplx(R * S,0d0)
C
      DO 110 J = L1, ENORN
         X = A(L,J)
         Y = A(L1,J)
         A(L,J) = dconjg(U1) * X + U2 * Y
         A(L1,J) = U1 * Y - U2 * X
         X = B(L,J)
         Y = B(L1,J)
         B(L,J) = dconjg(U1) * X + U2 * Y
         B(L1,J) = U1 * Y - U2 * X
  110 CONTINUE
C
      LM1 = L
      L = L1
      GO TO 90
C     ********** ITERATION STRATEGY **********
  120 IF (ITS .EQ. 50) GO TO 1000
      IF (ITS .EQ. 10) GO TO 135
C     ********** DETERMINE SHIFT **********
      B33 = B(NA,NA)
      IF (CDABS(B33) .GE. EPSB) GO TO 122
      B33 = dcmplx(EPSB,0d0)
  122 B44 = B(EN,EN)
      IF (CDABS(B44) .GE. EPSB) GO TO 124
      B44 = dcmplx(EPSB,0d0)
  124 B3344 = B33 * B44
      A33 = A(NA,NA) * B44
      A34 = A(NA,EN) * B33 - A(NA,NA) * B(NA,EN)
      A43 = dreal(A(EN,NA)) * B44
      A44 = A(EN,EN) * B33 - dreal(A(EN,NA)) * B(NA,EN)
      SH = A44
      X = A34 * A43
      IF (X .EQ. (0d0,0d0)) GO TO 140
      Y = (A33 - SH) * 0.5d0
      Z3 = CDSQRT(Y**2+X)
      U1 = Z3
      IF (dreal(Y)*dreal(U1)+dimag(Y)*dimag(U1).GE.0d0) GO TO 125
      U1 = -U1
  125 Z3 = (SH - X / (Y+U1)) / B3344
      SH = Z3
      GO TO 140
C     ********** AD HOC SHIFT **********
  135 SH = dcmplx(dreal(A(EN,NA)) + dreal(A(NA,ENM2)),0d0)
C     ********** DETERMINE ZEROTH COLUMN OF A **********
  140 A1 = A(L,L) / B11 - SH
      A2 = dreal(A(L1,L)) / B11
      ITS = ITS + 1
      IF (.NOT. MATZ) LOR1 = L
C     ********** MAIN LOOP **********
C      write(6,*) 'Outer Loop=>',L, 'to', NA
C      write(6,*) 'Inner Loop=>',KM1, 'to', ENORN

      DO 260 K = L, NA
         outer=outer+1
C         write(6,*) outer
         K1 = K + 1
         K2 = K + 2
         KM1 = MAX0(K-1,L)
C     ********** ZERO A(K+1,K-1) **********
         IF (K .EQ. L) GO TO 170
         A1 = A(K,KM1)
         A2 = dreal(A(K1,KM1))
  170    S = DABS(dreal(A1)) + DABS(dimag(A1)) + DABS(A2)
         U1 = A1 / S
         U2 = A2 / S
         R = DSQRT(dreal(U1)**2+dimag(U1)**2+U2**2)
         U1 = U1 / R
         U2 = U2 / R
C
         DO 180 J = KM1, ENORN
            inner=inner+1
C            write(6,*) 'i'
            X = A(K,J)
            Y = A(K1,J)
            A(K,J) = dconjg(U1) * X + U2 * Y
            A(K1,J) = U1 * Y - U2 * X
            X = B(K,J)
            Y = B(K1,J)
            B(K,J) = dconjg(U1) * X + U2 * Y
            B(K1,J) = U1 * Y - U2 * X
  180    CONTINUE
C
         IF (K .EQ. L) GO TO 240
         A(K,KM1) = dcmplx(dreal(A(K,KM1)),0d0)        !   ??????
         A(K1,KM1) = (0d0,0d0)
C     ********** ZERO B(K+1,K) **********
  240    S = DABS(dreal(B(K1,K1))) + DABS(dimag(B(K1,K1)))
     &        + DABS(dreal(B(K1,K)))
         U1 = B(K1,K1) / S
         U2 = dreal(B(K1,K)) / S
         R = DSQRT(dreal(U1)**2+dimag(U1)**2+U2**2)
         U1 = U1 / R
         U2 = U2 / R
         IF (K .EQ. NA) GO TO 245
         XR = dreal(A(K2,K1))
         A(K2,K1) = dconjg(U1) * XR
         A(K2,K) = dcmplx(-U2 * XR,dimag(A(K2,K)))
C
  245    DO 250 I = LOR1, K1
            X = A(I,K1)
            Y = A(I,K)
            A(I,K1) = dconjg(U1) * X + U2 * Y
            A(I,K) = U1 * Y - U2 * X
            X = B(I,K1)
            Y = B(I,K)
            B(I,K1) = dconjg(U1) * X + U2 * Y
            B(I,K) = U1 * Y - U2 * X
  250    CONTINUE
C
         B(K1,K1) = dcmplx(dreal(B(K1,K1)),0d0)
         B(K1,K) = (0d0,0d0)
         IF (.NOT. MATZ) GO TO 260
C
         DO 255 I = 1, N
            X = Z(I,K1)
            Y = Z(I,K)
            Z(I,K1) = dconjg(U1) * X + U2 * Y
            Z(I,K) = U1 * Y - U2 * X
  255    CONTINUE
C
  260 CONTINUE
C     ********** SET LAST A SUBDIAGONAL REAL AND END QZ STEP **********
      IF (dimag(A(EN,NA)) .EQ. 0d0) GO TO 70
      R = CDABS(A(EN,NA))
      U1 = A(EN,NA) / R
      A(EN,NA) = dcmplx(R,0d0)
C
      DO 270 J = EN, ENORN
         A(EN,J) = dconjg(U1) * A(EN,J)
         B(EN,J) = dconjg(U1) * B(EN,J)
  270 CONTINUE
C
      GO TO 70
C     ********** SET ERROR -- BOTTOM SUBDIAGONAL ELEMENT HAS NOT
C                BECOME NEGLIGIBLE AFTER 50 ITERATIONS **********
 1000 IERR = EN
      write(6,*) 'Outer loops= ', outer,' Inner loops= ', inner
C     ********** SAVE EPSB FOR USE BY CQZVEC **********
 1001 IF (N .GT. 1) B(N,1) = dcmplx(EPSB,dimag(B(N,1)))
      RETURN
C     ********** LAST CARD OF CQZVAL **********
      END
C
C     ------------------------------------------------------------------
C
      SUBROUTINE CQZVEC(NM,N,A,B,ALF,BETA,Z)
C
      implicit none
      INTEGER I,J,K,M,N,EN,II,JJ,NA,NM,NN
      COMPLEX*16 A(NM,N),B(NM,N),ALF(N),Z(NM,N)
      REAL*8 BETA(N),BETM,EPSB
      COMPLEX*16 Z3,ALM,R,T
      REAL*8 DREAL
C
C     THIS SUBROUTINE IS A COMPLEX ANALOGUE OF THE FOURTH STEP OF THE
C     QZ ALGORITHM FOR SOLVING GENERALIZED MATRIX EIGENVALUE PROBLEMS,
C     SIAM J. NUMER. ANAL. 10, 241-256(1973) BY MOLER AND STEWART.
C
C     THIS SUBROUTINE ACCEPTS A PAIR OF COMPLEX MATRICES IN UPPER
C     TRIANGULAR FORM, WHERE ONE OF THEM FURTHER MUST HAVE REAL DIAGONAL
C     ELEMENTS.  IT COMPUTES THE EIGENVECTORS OF THE TRIANGULAR PROBLEM
C     AND TRANSFORMS THE RESULTS BACK TO THE ORIGINAL COORDINATE SYSTEM.
C     IT IS USUALLY PRECEDED BY  CQZHES  AND  CQZVAL.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRICES,
C
C        A=(AR,AI) CONTAINS A COMPLEX UPPER TRIANGULAR MATRIX,
C
C        B=(BR,BI) CONTAINS A COMPLEX UPPER TRIANGULAR MATRIX WITH REAL
C          DIAGONAL ELEMENTS.  IN ADDITION, LOCATION BR(N,1) CONTAINS
C          THE TOLERANCE QUANTITY (EPSB) COMPUTED AND SAVED IN  CQZVAL,
C
C        ALFR, ALFI, AND BETA ARE VECTORS WITH COMPONENTS WHOSE
C          RATIOS ((ALFR+I*ALFI)/BETA) ARE THE GENERALIZED
C          EIGENVALUES.  THEY ARE USUALLY OBTAINED FROM  CQZVAL,
C
C        Z=(ZR,ZI) CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTIONS BY  CQZHES  AND  CQZVAL, IF PERFORMED.
C          IF THE EIGENVECTORS OF THE TRIANGULAR PROBLEM ARE
C          DESIRED, Z MUST CONTAIN THE IDENTITY MATRIX.
C
C     ON OUTPUT-
C
C        A IS UNALTERED,
C
C        B HAS BEEN DESTROYED,
C
C        ALFR, ALFI, AND BETA ARE UNALTERED,
C
C        Z CONTAINS THE EIGENVECTORS.  EACH EIGENVECTOR IS NORMALIZED
C          SO THAT THE MODULUS OF ITS LARGEST COMPONENT IS 1.0 .
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
      IF (N .LE. 1) GO TO 1001
      EPSB = dreal(B(N,1))
C     ********** FOR EN=N STEP -1 UNTIL 2 DO -- **********
      DO 800 NN = 2, N
         EN = N + 2 - NN
         NA = EN - 1
         ALM = ALF(EN)
         BETM = BETA(EN)
C     ********** FOR I=EN-1 STEP -1 UNTIL 1 DO -- **********
         DO 700 II = 1, NA
            I = EN - II
            R = (0,0d0)
            M = I + 1
C
            DO 610 J = M, EN
               T = BETM * A(I,J) - ALM * B(I,J)
               IF (J .EQ. EN) GO TO 605
               T = T * B(J,EN)
  605          R = R + T
  610       CONTINUE
C
            T = ALM * BETA(I) - BETM * ALF(I)
            IF (T .EQ. (0,0d0)) T = EPSB
            Z3 = R / T
            B(I,EN) = Z3
  700    CONTINUE
C
  800 CONTINUE
C     ********** END BACK SUBSTITUTION.
C                TRANSFORM TO ORIGINAL COORDINATE SYSTEM.
C                FOR J=N STEP -1 UNTIL 2 DO -- **********
      DO 880 JJ = 2, N
         J = N + 2 - JJ
         M = J - 1
C
         DO 880 I = 1, N
C
            DO 860 K = 1, M
               Z(I,J) = Z(I,J) + Z(I,K) * B(K,J)
  860       CONTINUE
C
  880 CONTINUE
C     ********** DO NOT NORMALIZE THE EIGENVECTORS ***********
C
 1001 RETURN
C     ********** LAST CARD OF CQZVEC **********
      END
c


*----------------------------------------------------------------------|
      subroutine DGPADM( ideg,m,t,H,ldh,wsp,lwsp,ipiv,iexph,ns,iflag )

      implicit none
      integer ideg, m, ldh, lwsp, iexph, ns, iflag, ipiv(m)
      double precision t, H(ldh,m), wsp(lwsp)

*-----Purpose----------------------------------------------------------|
*
*     Computes exp(t*H), the matrix exponential of a general matrix in
*     full, using the irreducible rational Pade approximation to the
*     exponential function exp(x) = r(x) = (+/-)( I + 2*(q(x)/p(x)) ),
*     combined with scaling-and-squaring.
*
*-----Arguments--------------------------------------------------------|
*
*     ideg      : (input) the degre of the diagonal Pade to be used.
*                 a value of 6 is generally satisfactory.
*
*     m         : (input) order of H.
*
*     H(ldh,m)  : (input) argument matrix.
*
*     t         : (input) time-scale (can be < 0).
*
*     wsp(lwsp) : (workspace/output) lwsp .ge. 4*m*m+ideg+1.
*
*     ipiv(m)   : (workspace)
*
*>>>> iexph     : (output) number such that wsp(iexph) points to exp(tH)
*                 i.e., exp(tH) is located at wsp(iexph ... iexph+m*m-1)
*                       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
*                 NOTE: if the routine was called with wsp(iptr),
*                       then exp(tH) will start at wsp(iptr+iexph-1).
*
*     ns        : (output) number of scaling-squaring used.
*
*     iflag     : (output) exit flag.
*                      0 - no problem
*                     <0 - problem
*
*----------------------------------------------------------------------|
*     Roger B. Sidje (rbs@maths.uq.edu.au)
*     EXPOKIT: Software Package for Computing Matrix Exponentials.
*     ACM - Transactions On Mathematical Software, 24(1):130-156, 1998
*----------------------------------------------------------------------|
*
      integer mm,i,j,k,ih2,ip,iq,iused,ifree,iodd,icoef,iput,iget
      double precision hnorm,scale,scale2,cp,cq

      intrinsic INT,ABS,DBLE,LOG,MAX

*---  check restrictions on input parameters ...
      mm = m*m
      iflag = 0
      if ( ldh.lt.m ) iflag = -1
      if ( lwsp.lt.4*mm+ideg+1 ) iflag = -2
      if ( iflag.ne.0 ) stop 'bad sizes (in input of DGPADM)'
*
*---  initialise pointers ...
*
      icoef = 1
      ih2 = icoef + (ideg+1)
      ip  = ih2 + mm
      iq  = ip + mm
      ifree = iq + mm
*
*---  scaling: seek ns such that ||t*H/2^ns|| < 1/2;
*     and set scale = t/2^ns ...
*
      do i = 1,m
         wsp(i) = 0.0d0
      enddo
      do j = 1,m
         do i = 1,m
            wsp(i) = wsp(i) + ABS( H(i,j) )
         enddo
      enddo
      hnorm = 0.0d0
      do i = 1,m
         hnorm = MAX( hnorm,wsp(i) )
      enddo
      hnorm = ABS( t*hnorm )
      if ( hnorm.eq.0.0d0 ) stop 'Error - null H in input of DGPADM.'
      ns = MAX( 0,INT(LOG(hnorm)/LOG(2.0d0))+2 )
      scale = t / DBLE(2**ns)
      scale2 = scale*scale
*
*---  compute Pade coefficients ...
*
      i = ideg+1
      j = 2*ideg+1
      wsp(icoef) = 1.0d0
      do k = 1,ideg
         wsp(icoef+k) = (wsp(icoef+k-1)*DBLE( i-k ))/DBLE( k*(j-k) )
      enddo
*
*---  H2 = scale2*H*H ...
*
      call DGEMM( 'n','n',m,m,m,scale2,H,ldh,H,ldh,0.0d0,wsp(ih2),m )
*
*---  initialize p (numerator) and q (denominator) ...
*
      cp = wsp(icoef+ideg-1)
      cq = wsp(icoef+ideg)
      do j = 1,m
         do i = 1,m
            wsp(ip + (j-1)*m + i-1) = 0.0d0
            wsp(iq + (j-1)*m + i-1) = 0.0d0
         enddo
         wsp(ip + (j-1)*(m+1)) = cp
         wsp(iq + (j-1)*(m+1)) = cq
      enddo
*
*---  Apply Horner rule ...
*
      iodd = 1
      k = ideg - 1
 100  continue
      iused = iodd*iq + (1-iodd)*ip
      call DGEMM( 'n','n',m,m,m, 1.0d0,wsp(iused),m,
     .             wsp(ih2),m, 0.0d0,wsp(ifree),m )
      do j = 1,m
         wsp(ifree+(j-1)*(m+1)) = wsp(ifree+(j-1)*(m+1))+wsp(icoef+k-1)
      enddo
      ip = (1-iodd)*ifree + iodd*ip
      iq = iodd*ifree + (1-iodd)*iq
      ifree = iused
      iodd = 1-iodd
      k = k-1
      if ( k.gt.0 )  goto 100
*
*---  Obtain (+/-)(I + 2*(p\q)) ...
*
      if ( iodd .eq. 1 ) then
         call DGEMM( 'n','n',m,m,m, scale,wsp(iq),m,
     .                H,ldh, 0.0d0,wsp(ifree),m )
         iq = ifree
      else
         call DGEMM( 'n','n',m,m,m, scale,wsp(ip),m,
     .                H,ldh, 0.0d0,wsp(ifree),m )
         ip = ifree
      endif
      call DAXPY( mm, -1.0d0,wsp(ip),1, wsp(iq),1 )
      call DGESV( m,m, wsp(iq),m, ipiv, wsp(ip),m, iflag )
      if ( iflag.ne.0 ) stop 'Problem in DGESV (within DGPADM)'
      call DSCAL( mm, 2.0d0, wsp(ip), 1 )
      do j = 1,m
         wsp(ip+(j-1)*(m+1)) = wsp(ip+(j-1)*(m+1)) + 1.0d0
      enddo
      iput = ip
      if ( ns.eq.0 .and. iodd.eq.1 ) then
         call DSCAL( mm, -1.0d0, wsp(ip), 1 )
         goto 200
      endif
*
*--   squaring : exp(t*H) = (exp(t*H))^(2^ns) ...
*
      iodd = 1
      do k = 1,ns
         iget = iodd*ip + (1-iodd)*iq
         iput = (1-iodd)*ip + iodd*iq
         call DGEMM( 'n','n',m,m,m, 1.0d0,wsp(iget),m, wsp(iget),m,
     .                0.0d0,wsp(iput),m )
         iodd = 1-iodd
      enddo
 200  continue
      iexph = iput
      END
*----------------------------------------------------------------------|
      subroutine DGPADMnorm( ideg,m,t,H,ldh,wsp,lwsp,ipiv,iexph,ns,iflag
     .                        ,hnorm )

      implicit none
      integer ideg, m, ldh, lwsp, iexph, ns, iflag, ipiv(m)
      double precision t, H(ldh,m), wsp(lwsp)

*-----Purpose----------------------------------------------------------|
*
*     Computes exp(t*H), the matrix exponential of a general matrix in
*     full, using the irreducible rational Pade approximation to the
*     exponential function exp(x) = r(x) = (+/-)( I + 2*(q(x)/p(x)) ),
*     combined with scaling-and-squaring.
*
*-----Arguments--------------------------------------------------------|
*
*     ideg      : (input) the degre of the diagonal Pade to be used.
*                 a value of 6 is generally satisfactory.
*
*     m         : (input) order of H.
*
*     H(ldh,m)  : (input) argument matrix.
*
*     t         : (input) time-scale (can be < 0).
*
*     wsp(lwsp) : (workspace/output) lwsp .ge. 4*m*m+ideg+1.
*
*     ipiv(m)   : (workspace)
*
*>>>> iexph     : (output) number such that wsp(iexph) points to exp(tH)
*                 i.e., exp(tH) is located at wsp(iexph ... iexph+m*m-1)
*                       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
*                 NOTE: if the routine was called with wsp(iptr),
*                       then exp(tH) will start at wsp(iptr+iexph-1).
*
*     ns        : (output) number of scaling-squaring used.
*
*     iflag     : (output) exit flag.
*                      0 - no problem
*                     <0 - problem
*
*----------------------------------------------------------------------|
*     Roger B. Sidje (rbs@maths.uq.edu.au)
*     EXPOKIT: Software Package for Computing Matrix Exponentials.
*     ACM - Transactions On Mathematical Software, 24(1):130-156, 1998
*----------------------------------------------------------------------|
*
      integer mm,i,j,k,ih2,ip,iq,iused,ifree,iodd,icoef,iput,iget
      double precision hnorm,scale,scale2,cp,cq

      intrinsic INT,ABS,DBLE,LOG,MAX

*---  check restrictions on input parameters ...
      mm = m*m
      iflag = 0
      if ( ldh.lt.m ) iflag = -1
      if ( lwsp.lt.4*mm+ideg+1 ) iflag = -2
      if ( iflag.ne.0 ) stop 'bad sizes (in input of DGPADM)'
*
*---  initialise pointers ...
*
      icoef = 1
      ih2 = icoef + (ideg+1)
      ip  = ih2 + mm
      iq  = ip + mm
      ifree = iq + mm
*
*---  scaling: seek ns such that ||t*H/2^ns|| < 1/2;
*     and set scale = t/2^ns ...
*
      do i = 1,m
         wsp(i) = 0.0d0
      enddo
      do j = 1,m
         do i = 1,m
            wsp(i) = wsp(i) + ABS( H(i,j) )
         enddo
      enddo
      hnorm = 0.0d0
      do i = 1,m
         hnorm = MAX( hnorm,wsp(i) )
      enddo
      hnorm = ABS( t*hnorm )
      if ( hnorm.eq.0.0d0 ) stop 'Error - null H in input of DGPADM.'
      ns = MAX( 0,INT(LOG(hnorm)/LOG(2.0d0))+2 )
      scale = t / DBLE(2**ns)
      scale2 = scale*scale
*
*---  compute Pade coefficients ...
*
      i = ideg+1
      j = 2*ideg+1
      wsp(icoef) = 1.0d0
      do k = 1,ideg
         wsp(icoef+k) = (wsp(icoef+k-1)*DBLE( i-k ))/DBLE( k*(j-k) )
      enddo
*
*---  H2 = scale2*H*H ...
*
      call DGEMM( 'n','n',m,m,m,scale2,H,ldh,H,ldh,0.0d0,wsp(ih2),m )
*
*---  initialize p (numerator) and q (denominator) ...
*
      cp = wsp(icoef+ideg-1)
      cq = wsp(icoef+ideg)
      do j = 1,m
         do i = 1,m
            wsp(ip + (j-1)*m + i-1) = 0.0d0
            wsp(iq + (j-1)*m + i-1) = 0.0d0
         enddo
         wsp(ip + (j-1)*(m+1)) = cp
         wsp(iq + (j-1)*(m+1)) = cq
      enddo
*
*---  Apply Horner rule ...
*
      iodd = 1
      k = ideg - 1
 100  continue
      iused = iodd*iq + (1-iodd)*ip
      call DGEMM( 'n','n',m,m,m, 1.0d0,wsp(iused),m,
     .             wsp(ih2),m, 0.0d0,wsp(ifree),m )
      do j = 1,m
         wsp(ifree+(j-1)*(m+1)) = wsp(ifree+(j-1)*(m+1))+wsp(icoef+k-1)
      enddo
      ip = (1-iodd)*ifree + iodd*ip
      iq = iodd*ifree + (1-iodd)*iq
      ifree = iused
      iodd = 1-iodd
      k = k-1
      if ( k.gt.0 )  goto 100
*
*---  Obtain (+/-)(I + 2*(p\q)) ...
*
      if ( iodd .eq. 1 ) then
         call DGEMM( 'n','n',m,m,m, scale,wsp(iq),m,
     .                H,ldh, 0.0d0,wsp(ifree),m )
         iq = ifree
      else
         call DGEMM( 'n','n',m,m,m, scale,wsp(ip),m,
     .                H,ldh, 0.0d0,wsp(ifree),m )
         ip = ifree
      endif
      call DAXPY( mm, -1.0d0,wsp(ip),1, wsp(iq),1 )
      call DGESV( m,m, wsp(iq),m, ipiv, wsp(ip),m, iflag )
      if ( iflag.ne.0 ) stop 'Problem in DGESV (within DGPADM)'
      call DSCAL( mm, 2.0d0, wsp(ip), 1 )
      do j = 1,m
         wsp(ip+(j-1)*(m+1)) = wsp(ip+(j-1)*(m+1)) + 1.0d0
      enddo
      iput = ip
      if ( ns.eq.0 .and. iodd.eq.1 ) then
         call DSCAL( mm, -1.0d0, wsp(ip), 1 )
         goto 200
      endif
*
*--   squaring : exp(t*H) = (exp(t*H))^(2^ns) ...
*
      iodd = 1
      do k = 1,ns
         iget = iodd*ip + (1-iodd)*iq
         iput = (1-iodd)*ip + iodd*iq
         call DGEMM( 'n','n',m,m,m, 1.0d0,wsp(iget),m, wsp(iget),m,
     .                0.0d0,wsp(iput),m )
         iodd = 1-iodd
      enddo
 200  continue
      iexph = iput
      END
*----------------------------------------------------------------------|


      subroutine minmax (name, f, m, n, l)

      implicit         none

      character*(*)      name

      integer          m, n, l
      integer          i, j, k

      real             f(m,n,l)
      real             fmax
      real             fmin
      real mean
      real big
      parameter (big = 1.e14)
      integer count
      real mean
      logical hasmiss

      hasmiss = .false.
      fmax = - big
      fmin = + big
      mean = 0.
      count = 0

      do k = 1, l
        do j = 1, n
          do i = 1, m
            if( abs(f(i,j,k)) .lt. big ) then
                fmax = max(fmax,f(i,j,k))
                fmin = min(fmin,f(i,j,k))
                mean = mean + f(i,j,k)
                count = count + 1
            else
                hasmiss = .true.
            endif
          end do
        end do
      end do

      if( count .ne. 0 ) mean = mean / count

      if ( hasmiss ) then
      write(6,*) name // ' max, min, mean = ', fmax, fmin, mean, ' M'
      else
      write(6,*) name // ' max, min, mean = ', fmax, fmin, mean
      endif

      return
      end


*> \brief \b CLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix, B and C are rectangular matrices, and α and β are scalars, which may be 0, 1, or -1.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CLAGTM + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
*                          B, LDB )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANS
*       INTEGER            LDB, LDX, N, NRHS
*       REAL               ALPHA, BETA
*       ..
*       .. Array Arguments ..
*       COMPLEX            B( LDB, * ), D( * ), DL( * ), DU( * ),
*      $                   X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CLAGTM performs a matrix-vector product of the form
*>
*>    B := alpha * A * X + beta * B
*>
*> where A is a tridiagonal matrix of order N, B and X are N by NRHS
*> matrices, and alpha and beta are real scalars, each of which may be
*> 0., 1., or -1.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies the operation applied to A.
*>          = 'N':  No transpose, B := alpha * A * X + beta * B
*>          = 'T':  Transpose,    B := alpha * A**T * X + beta * B
*>          = 'C':  Conjugate transpose, B := alpha * A**H * X + beta * B
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrices X and B.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*>          ALPHA is REAL
*>          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,
*>          it is assumed to be 0.
*> \endverbatim
*>
*> \param[in] DL
*> \verbatim
*>          DL is COMPLEX array, dimension (N-1)
*>          The (n-1) sub-diagonal elements of T.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is COMPLEX array, dimension (N)
*>          The diagonal elements of T.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*>          DU is COMPLEX array, dimension (N-1)
*>          The (n-1) super-diagonal elements of T.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is COMPLEX array, dimension (LDX,NRHS)
*>          The N by NRHS matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(N,1).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*>          BETA is REAL
*>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
*>          it is assumed to be 1.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX array, dimension (LDB,NRHS)
*>          On entry, the N by NRHS matrix B.
*>          On exit, B is overwritten by the matrix expression
*>          B := alpha * A * X + beta * B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(N,1).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complexOTHERauxiliary
*
*  =====================================================================
      SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
     $                   B, LDB )
*
*  -- LAPACK auxiliary routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            LDB, LDX, N, NRHS
      REAL               ALPHA, BETA
*     ..
*     .. Array Arguments ..
      COMPLEX            B( LDB, * ), D( * ), DL( * ), DU( * ),
     $                   X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG
*     ..
*     .. Executable Statements ..
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Multiply B by BETA if BETA.NE.1.
*
      IF( BETA.EQ.ZERO ) THEN
         DO 20 J = 1, NRHS
            DO 10 I = 1, N
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
      ELSE IF( BETA.EQ.-ONE ) THEN
         DO 40 J = 1, NRHS
            DO 30 I = 1, N
               B( I, J ) = -B( I, J )
   30       CONTINUE
   40    CONTINUE
      END IF
*
      IF( ALPHA.EQ.ONE ) THEN
         IF( LSAME( TRANS, 'N' ) ) THEN
*
*           Compute B := B + A*X
*
            DO 60 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
     $                        DU( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
     $                        D( N )*X( N, J )
                  DO 50 I = 2, N - 1
                     B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
     $                           D( I )*X( I, J ) + DU( I )*X( I+1, J )
   50             CONTINUE
               END IF
   60       CONTINUE
         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
*           Compute B := B + A**T * X
*
            DO 80 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
     $                        DL( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
     $                        D( N )*X( N, J )
                  DO 70 I = 2, N - 1
                     B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
     $                           D( I )*X( I, J ) + DL( I )*X( I+1, J )
   70             CONTINUE
               END IF
   80       CONTINUE
         ELSE IF( LSAME( TRANS, 'C' ) ) THEN
*
*           Compute B := B + A**H * X
*
            DO 100 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) + CONJG( D( 1 ) )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) + CONJG( D( 1 ) )*X( 1, J ) +
     $                        CONJG( DL( 1 ) )*X( 2, J )
                  B( N, J ) = B( N, J ) + CONJG( DU( N-1 ) )*
     $                        X( N-1, J ) + CONJG( D( N ) )*X( N, J )
                  DO 90 I = 2, N - 1
                     B( I, J ) = B( I, J ) + CONJG( DU( I-1 ) )*
     $                           X( I-1, J ) + CONJG( D( I ) )*
     $                           X( I, J ) + CONJG( DL( I ) )*
     $                           X( I+1, J )
   90             CONTINUE
               END IF
  100       CONTINUE
         END IF
      ELSE IF( ALPHA.EQ.-ONE ) THEN
         IF( LSAME( TRANS, 'N' ) ) THEN
*
*           Compute B := B - A*X
*
            DO 120 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
     $                        DU( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
     $                        D( N )*X( N, J )
                  DO 110 I = 2, N - 1
                     B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
     $                           D( I )*X( I, J ) - DU( I )*X( I+1, J )
  110             CONTINUE
               END IF
  120       CONTINUE
         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
*           Compute B := B - A**T*X
*
            DO 140 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
     $                        DL( 1 )*X( 2, J )
                  B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
     $                        D( N )*X( N, J )
                  DO 130 I = 2, N - 1
                     B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
     $                           D( I )*X( I, J ) - DL( I )*X( I+1, J )
  130             CONTINUE
               END IF
  140       CONTINUE
         ELSE IF( LSAME( TRANS, 'C' ) ) THEN
*
*           Compute B := B - A**H*X
*
            DO 160 J = 1, NRHS
               IF( N.EQ.1 ) THEN
                  B( 1, J ) = B( 1, J ) - CONJG( D( 1 ) )*X( 1, J )
               ELSE
                  B( 1, J ) = B( 1, J ) - CONJG( D( 1 ) )*X( 1, J ) -
     $                        CONJG( DL( 1 ) )*X( 2, J )
                  B( N, J ) = B( N, J ) - CONJG( DU( N-1 ) )*
     $                        X( N-1, J ) - CONJG( D( N ) )*X( N, J )
                  DO 150 I = 2, N - 1
                     B( I, J ) = B( I, J ) - CONJG( DU( I-1 ) )*
     $                           X( I-1, J ) - CONJG( D( I ) )*
     $                           X( I, J ) - CONJG( DL( I ) )*
     $                           X( I+1, J )
  150             CONTINUE
               END IF
  160       CONTINUE
         END IF
      END IF
      RETURN
*
*     End of CLAGTM
*
      END


*DECK CBESY
      SUBROUTINE CBESY (Z, FNU, KODE, N, CY, NZ, CWRK, IERR)
C***BEGIN PROLOGUE  CBESY
C***PURPOSE  Compute a sequence of the Bessel functions Y(a,z) for
C            complex argument z and real nonnegative orders a=b,b+1,
C            b+2,... where b>0.  A scaling option is available to
C            help avoid overflow.
C***LIBRARY   SLATEC
C***CATEGORY  C10A4
C***TYPE      COMPLEX (CBESY-C, ZBESY-C)
C***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
C             BESSEL FUNCTIONS OF SECOND KIND, WEBER'S FUNCTION,
C             Y BESSEL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C         On KODE=1, CBESY computes an N member sequence of complex
C         Bessel functions CY(L)=Y(FNU+L-1,Z) for real nonnegative
C         orders FNU+L-1, L=1,...,N and complex Z in the cut plane
C         -pi<arg(Z)<=pi.  On KODE=2, CBESY returns the scaled
C         functions
C
C            CY(L) = exp(-abs(Y))*Y(FNU+L-1,Z),  L=1,...,N, Y=Im(Z)
C
C         which remove the exponential growth in both the upper and
C         lower half planes as Z goes to infinity.  Definitions and
C         notation are found in the NBS Handbook of Mathematical
C         Functions (Ref. 1).
C
C         Input
C           Z      - Nonzero argument of type COMPLEX
C           FNU    - Initial order of type REAL, FNU>=0
C           KODE   - A parameter to indicate the scaling option
C                    KODE=1  returns
C                            CY(L)=Y(FNU+L-1,Z), L=1,...,N
C                        =2  returns
C                            CY(L)=Y(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N
C                            where Y=Im(Z)
C           N      - Number of terms in the sequence, N>=1
C           CWRK   - A work vector of type COMPLEX and dimension N
C
C         Output
C           CY     - Result vector of type COMPLEX
C           NZ     - Number of underflows set to zero
C                    NZ=0    Normal return
C                    NZ>0    CY(L)=0 for NZ values of L, usually on
C                            KODE=2 (the underflows may not be in an
C                            uninterrupted sequence)
C           IERR   - Error flag
C                    IERR=0  Normal return     - COMPUTATION COMPLETED
C                    IERR=1  Input error       - NO COMPUTATION
C                    IERR=2  Overflow          - NO COMPUTATION
C                            (abs(Z) too small and/or FNU+N-1
C                            too large)
C                    IERR=3  Precision warning - COMPUTATION COMPLETED
C                            (Result has half precision or less
C                            because abs(Z) or FNU+N-1 is large)
C                    IERR=4  Precision error   - NO COMPUTATION
C                            (Result has no precision because
C                            abs(Z) or FNU+N-1 is too large)
C                    IERR=5  Algorithmic error - NO COMPUTATION
C                            (Termination condition not met)
C
C *Long Description:
C
C         The computation is carried out by the formula
C
C            Y(a,z) = (H(1,a,z) - H(2,a,z))/(2*i)
C
C         where the Hankel functions are computed as described in CBESH.
C
C         For negative orders, the formula
C
C            Y(-a,z) = Y(a,z)*cos(a*pi) + J(a,z)*sin(a*pi)
C
C         can be used.  However, for large orders close to half odd
C         integers the function changes radically.  When a is a large
C         positive half odd integer, the magnitude of Y(-a,z)=J(a,z)*
C         sin(a*pi) is a large negative power of ten.  But when a is
C         not a half odd integer, Y(a,z) dominates in magnitude with a
C         large positive power of ten and the most that the second term
C         can be reduced is by unit roundoff from the coefficient.
C         Thus,  wide changes can occur within unit roundoff of a large
C         half odd integer.  Here, large means a>abs(z).
C
C         In most complex variable computation, one must evaluate ele-
C         mentary functions.  When the magnitude of Z or FNU+N-1 is
C         large, losses of significance by argument reduction occur.
C         Consequently, if either one exceeds U1=SQRT(0.5/UR), then
C         losses exceeding half precision are likely and an error flag
C         IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF.  Also,
C         if either is larger than U2=0.5/UR, then all significance is
C         lost and IERR=4.  In order to use the INT function, arguments
C         must be further restricted not to exceed the largest machine
C         integer, U3=I1MACH(9).  Thus, the magnitude of Z and FNU+N-1
C         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
C         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
C         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
C         makes U2 limiting in single precision and U3 limiting in
C         double precision.  This means that one can expect to retain,
C         in the worst cases on IEEE machines, no digits in single pre-
C         cision and only 6 digits in double precision.  Similar con-
C         siderations hold for other machines.
C
C         The approximate relative error in the magnitude of a complex
C         Bessel function can be expressed as P*10**S where P=MAX(UNIT
C         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
C         sents the increase in error due to argument reduction in the
C         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
C         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
C         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
C         have only absolute accuracy.  This is most likely to occur
C         when one component (in magnitude) is larger than the other by
C         several orders of magnitude.  If one component is 10**K larger
C         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
C         0) significant digits; or, stated another way, when K exceeds
C         the exponent of P, no significant digits remain in the smaller
C         component.  However, the phase angle retains absolute accuracy
C         because, in complex arithmetic with precision P, the smaller
C         component will not (as a rule) decrease below P times the
C         magnitude of the larger component.  In these extreme cases,
C         the principal phase angle is on the order of +P, -P, PI/2-P,
C         or -PI/2+P.
C
C***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
C                 matical Functions, National Bureau of Standards
C                 Applied Mathematics Series 55, U. S. Department
C                 of Commerce, Tenth Printing (1972) or later.
C               2. D. E. Amos, Computation of Bessel Functions of
C                 Complex Argument, Report SAND83-0086, Sandia National
C                 Laboratories, Albuquerque, NM, May 1983.
C               3. D. E. Amos, Computation of Bessel Functions of
C                 Complex Argument and Large Order, Report SAND83-0643,
C                 Sandia National Laboratories, Albuquerque, NM, May
C                 1983.
C               4. D. E. Amos, A Subroutine Package for Bessel Functions
C                 of a Complex Argument and Nonnegative Order, Report
C                 SAND85-1018, Sandia National Laboratory, Albuquerque,
C                 NM, May 1985.
C               5. D. E. Amos, A portable package for Bessel functions
C                 of a complex argument and nonnegative order, ACM
C                 Transactions on Mathematical Software, 12 (September
C                 1986), pp. 265-273.
C
C***ROUTINES CALLED  CBESH, I1MACH, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   890801  REVISION DATE from Version 3.2
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C   920128  Category corrected.  (WRB)
C   920811  Prologue revised.  (DWL)
C***END PROLOGUE  CBESY
C
      COMPLEX CWRK, CY, C1, C2, EX, HCI, Z, ZU, ZV
      REAL ELIM, EY, FNU, R1, R2, TAY, XX, YY, R1MACH, R1M5, ASCLE,
     *  RTOL, ATOL, TOL, AA, BB
      INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH
      DIMENSION CY(N), CWRK(N)
C***FIRST EXECUTABLE STATEMENT  CBESY
      XX = REAL(Z)
      YY = AIMAG(Z)
      IERR = 0
      NZ=0
      IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1
      IF (FNU.LT.0.0E0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (N.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
      HCI = CMPLX(0.0E0,0.5E0)
      CALL CBESH(Z, FNU, KODE, 1, N, CY, NZ1, IERR)
      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
      CALL CBESH(Z, FNU, KODE, 2, N, CWRK, NZ2, IERR)
      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
      NZ = MIN(NZ1,NZ2)
      IF (KODE.EQ.2) GO TO 60
      DO 50 I=1,N
        CY(I) = HCI*(CWRK(I)-CY(I))
   50 CONTINUE
      RETURN
   60 CONTINUE
      TOL = MAX(R1MACH(4),1.0E-18)
      K1 = I1MACH(12)
      K2 = I1MACH(13)
      K = MIN(ABS(K1),ABS(K2))
      R1M5 = R1MACH(5)
C-----------------------------------------------------------------------
C     ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT
C-----------------------------------------------------------------------
      ELIM = 2.303E0*(K*R1M5-3.0E0)
      R1 = COS(XX)
      R2 = SIN(XX)
      EX = CMPLX(R1,R2)
      EY = 0.0E0
      TAY = ABS(YY+YY)
      IF (TAY.LT.ELIM) EY = EXP(-TAY)
      IF (YY.LT.0.0E0) GO TO 90
      C1 = EX*CMPLX(EY,0.0E0)
      C2 = CONJG(EX)
   70 CONTINUE
      NZ = 0
      RTOL = 1.0E0/TOL
      ASCLE = R1MACH(1)*RTOL*1.0E+3
      DO 80 I=1,N
C       CY(I) = HCI*(C2*CWRK(I)-C1*CY(I))
        ZV = CWRK(I)
        AA=REAL(ZV)
        BB=AIMAG(ZV)
        ATOL=1.0E0
        IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 75
          ZV = ZV*CMPLX(RTOL,0.0E0)
          ATOL = TOL
   75   CONTINUE
        ZV = ZV*C2*HCI
        ZV = ZV*CMPLX(ATOL,0.0E0)
        ZU=CY(I)
        AA=REAL(ZU)
        BB=AIMAG(ZU)
        ATOL=1.0E0
        IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 85
          ZU = ZU*CMPLX(RTOL,0.0E0)
          ATOL = TOL
   85   CONTINUE
        ZU = ZU*C1*HCI
        ZU = ZU*CMPLX(ATOL,0.0E0)
        CY(I) = ZV - ZU
        IF (CY(I).EQ.CMPLX(0.0E0,0.0E0) .AND. EY.EQ.0.0E0) NZ = NZ + 1
   80 CONTINUE
      RETURN
   90 CONTINUE
      C1 = EX
      C2 = CONJG(EX)*CMPLX(EY,0.0E0)
      GO TO 70
  170 CONTINUE
      NZ = 0
      RETURN
      END