      SUBROUTINE NODAG(N, SIGMA, A, LAMBD, EPS, ALPHA, MAXITR)
c     NODAG routine (version 0.0.3)
c     gherardo varando (2020) <gherardo.varando[at]gmail.com>
c
c     Find a sparse parametrization of the inverse covariance
c     matrix as  A A**t using a proximal gradient algorithm
c     for the problem
c      minimize   -2log(det(A)) + trace(A^t Sigma A) + LAMBD * ||A||_1
c      A invertible
c
c     integer variables
      INTEGER N,MAXITR
c     double precision variables
      DOUBLE PRECISION SIGMA(N,N),A(N,N),LAMBD,EPS,ALPHA
ccccc  comment block f2py
cf2py intent(in)  n
cf2py intent(in)  sigma
cf2py intent(out) a
cf2py double precision intent(in)  lambd
cf2py double precision intent(in,out)  :: eps = 0.0001
cf2py double precision intent(in,out)  :: alpha = 0.5
cf2py integer intent(in,out)  :: maxitr = 100
ccccc end comment block f2py
c     on entry
c        N      integer
c               size of the problem
c        SIGMA  double precision (N,N)
c               empirical covariance matrix
c        A      double precision (N,N)
c        LAMBD double precision
c               penalization coefficient
c        EPS    double precision
c               tollerance for termination
c        ALPHA  double precision
c               coefficient for line search
c        MAXITR integer
c               maximum number of iterations
c     on exit
c        A      results of the optimization
c        EPS    last difference in objective function
c        ALPHA  minus log-likelhood on exit
c        MAXITR number of iterations
c
c
c     external subroutine from LAPACK
      EXTERNAL DGETRI, DGETRF, DSYMM
c     intrinsic functions
      INTRINSIC ABS, LOG, SIGN
c     internal variables
      INTEGER I,J,ITR, IPIV(N),INFO
      DOUBLE PRECISION F,FNW,TMP(N,N),GRD(N,N), D(N,N),
     *                 ONE, ZERO, STEP, G, GNW, AOLD(N,N), DIFF
      PARAMETER ( ONE = 1.0E+0 )
      PARAMETER ( ZERO = 0.0E+0 )
      ITR = 0
      F = 0.0E+0
c     initialize penalty for A = identity
      G = LAMBD * N
c     initialize matrices and F = trace(SIGMA)
      DO 20 J = 1,N
         DO 10 I = 1,N
            A(I,J) = 0.0E+0
            TMP(I,J) = 0.0E+0
            D(I,J) = SIGMA(I,J)
  10     CONTINUE
         A(J,J) = 1.0E+0
         TMP(J,J) = 1.0E+0
         IPIV(J) = J
         F = F + SIGMA(J,J)
  20  CONTINUE
c     compute initial objective function in A = identity
c     compute TMP = PLU
c     main loop here, increase iteration counter
 500  CONTINUE
      ITR = ITR + 1
c     compute TMP = TMP**-1
      CALL DGETRI(N, TMP, N, IPIV, AOLD, N**2, INFO)
c     compute GRD = 2*(D - TMP**t)
c     and copy A before starting line search
      DO 40 J=1,N
         DO 30 I=1,N
            GRD(I,J) = 2*(D(I,J) - TMP(J,I))
            AOLD(I,J) = A(I,J)
  30     CONTINUE
  40  CONTINUE
      STEP = 1
c     line search loop
  600 CONTINUE
c     gradient step
c     and soft thresholding
      DO 110 J =1,N
         DO 100 I=1,N
            A(I,J) = AOLD(I,J) - STEP * GRD(I,J)
            A(I,J) = SIGN(ONE,A(I,J))*(ABS(A(I,J))-STEP*LAMBD)
            IF (ABS(A(I,J)) .LE. STEP*LAMBD) THEN
               A(I,J) = 0.0E+0
            ENDIF
            TMP(I,J) = A(I,J)
 100     CONTINUE
 110  CONTINUE
c     compute TMP = PLU
      CALL DGETRF(N, N, TMP, N, IPIV,INFO)
      IF (INFO .GT. 0) THEN
          STEP = ALPHA * STEP
          GOTO 600
      ENDIF
c     compute D = SIGMA * A
      CALL DSYMM("L","U", N, N, ONE, SIGMA, N, A, N, ZERO, D, N)
c     compute FNW, GNW in new A
      FNW = 0.0E+0
      GNW = 0.0E+0
      DIFF = 0.0E+0
c     compute F = -2*LOG(DET(A)) + trace(A**t SIGMA A)
c             and G = ||A||_1
      DO 150 J=1,N
         FNW = FNW -  2 * LOG(ABS(TMP(J,J)))
         DO 140 I=1,N
            DIFF = DIFF + ((A(I,J) - AOLD(I,J))**2)/(2*STEP) +
     *             (A(I,J) - AOLD(I,J)) * GRD(I,J)
            FNW = FNW + A(I,J)*D(I,J)
            GNW = GNW + LAMBD * ABS(A(I,J))
  140    CONTINUE
  150  CONTINUE
c     line search condition
      IF (FNW .GT. F + DIFF .OR. FNW  + GNW .GT. F + G ) THEN
         STEP = STEP * ALPHA
         GOTO 600
      ENDIF
c     check stopping criteria
      IF (((F+G-FNW-GNW).LE.EPS).OR.(ITR.GE.MAXITR))THEN
c     terminate and save additional outputs
         ALPHA = FNW
         EPS = F + G - FNW - GNW
         MAXITR = ITR
         GOTO 900
      ENDIF
c     update value of objective function and repeat
      F = FNW
      G = GNW
      GOTO 500
 900  CONTINUE
      RETURN
c     last line of NODAG
      END


program main
	implicit none
	real,external :: freeFall
    open(unit=1, file='out.txt')
	write (1, "('There are some ball''s velocity when they free fall to ground.')")
	write (1, "('high    velocity')")
	write (1, "('1       ', F0.6)") freeFall(1.0)
	write (1, "('10      ', F0.6)") freeFall(10.0)
	write (1, "('100     ', F0.6)") freeFall(100.0)
	close(11)
	stop
end program main

function freeFall(high)
	implicit none
	real,parameter :: g = 9.80665
    real :: high
	real :: freeFall
	freeFall = (2 * g * high) ** 0.5
	return
end function


! This routine performs a cubic interpolation of the curve that
! passes through x,y to xx,yy
!
Subroutine Cubic_interp(nn, x, y, xx, yy)
  Implicit None
  Integer :: nn, i
  Real, dimension (4) :: x, y
  Real, dimension (nn) :: xx, yy
  Real :: den, a, b, c, d, x1, x2, x3, x4, y1, y2, y3, y4
!
  x1=x(1)
  x2=x(2)
  x3=x(3)
  x4=x(4)
  y1=y(1)
  y2=y(2)
  y3=y(3)
  y4=y(4)
  den = (x1 - x2)*(x1 - x3)*(x2 - x3)*(x1 - x4)*(x2 - x4)*(x3 - x4)
  a=(x1*x4*(x1-x4)*(y2-y3) + x3*x3*(x4*(y1-y2)+x1*(y2-y4))+x2* &
       (x4*x4*(y1-y3)+x1*x1*(y3-y4)+x3*x3*(y4-y1))+ &
       x3*(x4*x4*(y2-y1)+x1*x1*(y4-y2))+ x2*x2* &
       (x4*(y3-y1)+x3*(y1-y4)+x1*(y4-y3)))/den

  b=(-x1*x4*(x1*x1-x4*x4)*(y2-y3)+x3*(x4*x4*x4*(y1-y2)+ &
       x1*x1*x1*(y2-y4))+x2*x2*x2*(x4*(y1-y3)+x1*(y3-y4)+ &
       x3*(y4-y1))+x3*x3*x3*(x4*(y2-y1)+x1*(y4-y2))+ &
       x2*(x4*x4*x4*(y3-y1)+x3*x3*x3*(y1-y1)+x1*x1*x1*(y4-y3)))/den

  c=(x1*x1*(x1-x4)*x4*x4*(y2-y3)+x3*x3*x3*(x4*x4*(y1-y2)+x1*x1*(y2-y4))+ &
       x2*x2*(x4*x4*x4*(y1-y3)+x1*x1*x1*(y3-y4)+x3*x3*x3*(y4-y1))+ &
       x3*x3*(x4*x4*x4*(y2-y1)+x1*x1*x1*(y4-y2))+ &
       x2*x2*x2*(x4*x4*(y3-y1)+x3*x3*(y1-y4)+x1*x1*(y4-y3)))/den

  d=(x1*(x1-x3)*x3*(x1-x4)*(x3-x4)*x4*y2+x2*x2*x2*(x1*(x1-x4)*x4*y3+ &
       x3*x3*(x1*y4-x4*y1)+x3*(x4*x4*y1-x1*x1*y4))+ &
       x2*(x1*x1*(x1-x4)*x4*x4*y3+x3*x3*x3*(x1*x1*y4-x4*x4*y1)+ &
       x3*x3*(x4*x4*x4*y1-x1*x1*x1*y4))+ &
       x2*x2*(x1*x4*(x4*x4-x1*x1)*y3+x3*x3*x3*(x4*y1-x1*y4)+ &
       x3*(x1*x1*x1*y4-x4*x4*x4*y1)))/den

  yy = a*(xx**3) + b*(xx**2) + c*xx + d

  Return
End Subroutine Cubic_interp


submodule(euler_interface_m) euler_prob_0023_m
    implicit none

contains

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

    function ans() result(ret)
        integer, allocatable :: abundant(:)
        integer, parameter :: min_ = 12, max_ = 28123
        logical, allocatable :: cannot_be_written(:)
        integer :: i, j, ret

        gen_abundant_arr: do i = min_, max_
            if (is_abundant(i)) call append(abundant, i)
        end do gen_abundant_arr

        allocate (cannot_be_written(max_))
        cannot_be_written = .true.
        do i = 1, size(abundant)
            do j = i, size(abundant)
                associate (x => abundant(i) + abundant(j))
                    if (x <= max_) cannot_be_written(x) = .false.
                end associate
            end do
        end do
        ret = sum(pack([(i, i=1, max_)], cannot_be_written))
    end function ans

    function is_abundant(val) result(ret)
        integer, intent(in) :: val
        logical :: ret

        ret = .false.
        if (sum_of_proper_divisors(val) > val) ret = .true.
    end function is_abundant

    function sum_of_proper_divisors(val) result(ret)
        integer, intent(in) :: val
        integer :: ret, i

        ret = 1
        do i = 2, int(sqrt(real(val)))
            if (mod(val, i) == 0) then
                if (val/i == i) then
                    ret = ret + i
                else
                    ret = ret + i + val/i
                end if
            end if
        end do
    end function sum_of_proper_divisors

end submodule euler_prob_0023_m


      program prog
      parameter(val=1.2**3.4)
      write(6, '(f5.3)') val
      x = 1.2 + 3.4**5.6 / 7.8
      write(6, '(f5.1)') x
      x = (1.2 + 3.4)**5.6 / 7.8
      write(6, '(f5.1)') x
      x = (1.2 + 3.4)**(5.6 / 7.8)
      write(6, '(f5.3)') x
      x = -1.3**2
      write(6, '(f5.2)') x
      x = (-1.3)**2
      write(6, '(f4.2)') x
      x = (-1.4)**1
      write(6, '(f5.2)') x
      x = (-1.5)**3
      write(6, '(f5.2)') x
      x = (-1.6)**4
      write(6, '(f4.2)') x
      end


      SUBROUTINE AB13DD( DICO, JOBE, EQUIL, JOBD, N, M, P, FPEAK,
     $                   A, LDA, E, LDE, B, LDB, C, LDC, D, LDD, GPEAK,
     $                   TOL, IWORK, DWORK, LDWORK, CWORK, LCWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the L-infinity norm of a continuous-time or
C     discrete-time system, either standard or in the descriptor form,
C
C                                     -1
C        G(lambda) = C*( lambda*E - A ) *B + D .
C
C     The norm is finite if and only if the matrix pair (A,E) has no
C     eigenvalue on the boundary of the stability domain, i.e., the
C     imaginary axis, or the unit circle, respectively. It is assumed
C     that the matrix E is nonsingular.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system, as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     JOBE    CHARACTER*1
C             Specifies whether E is a general square or an identity
C             matrix, as follows:
C             = 'G':  E is a general square matrix;
C             = 'I':  E is the identity matrix.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to preliminarily
C             equilibrate the system (A,E,B,C) or (A,B,C), as follows:
C             = 'S':  perform equilibration (scaling);
C             = 'N':  do not perform equilibration.
C
C     JOBD    CHARACTER*1
C             Specifies whether or not a non-zero matrix D appears in
C             the given state space model:
C             = 'D':  D is present;
C             = 'Z':  D is assumed a zero matrix.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The row size of the matrix C.  P >= 0.
C
C     FPEAK   (input/output) DOUBLE PRECISION array, dimension (2)
C             On entry, this parameter must contain an estimate of the
C             frequency where the gain of the frequency response would
C             achieve its peak value. Setting FPEAK(2) = 0 indicates an
C             infinite frequency. An accurate estimate could reduce the
C             number of iterations of the iterative algorithm. If no
C             estimate is available, set FPEAK(1) = 0, and FPEAK(2) = 1.
C             FPEAK(1) >= 0, FPEAK(2) >= 0.
C             On exit, if INFO = 0, this array contains the frequency
C             OMEGA, where the gain of the frequency response achieves
C             its peak value GPEAK, i.e.,
C
C                 || G ( j*OMEGA ) || = GPEAK ,  if DICO = 'C', or
C
C                         j*OMEGA
C                 || G ( e       ) || = GPEAK ,  if DICO = 'D',
C
C             where OMEGA = FPEAK(1), if FPEAK(2) > 0, and OMEGA is
C             infinite, if FPEAK(2) = 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             state dynamics matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,N)
C             If JOBE = 'G', the leading N-by-N part of this array must
C             contain the descriptor matrix E of the system.
C             If JOBE = 'I', then E is assumed to be the identity
C             matrix and is not referenced.
C
C     LDE     INTEGER
C             The leading dimension of the array E.
C             LDE >= MAX(1,N), if JOBE = 'G';
C             LDE >= 1,        if JOBE = 'I'.
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             system output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             If JOBD = 'D', the leading P-by-M part of this array must
C             contain the direct transmission matrix D.
C             The array D is not referenced if JOBD = 'Z'.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P), if JOBD = 'D';
C             LDD >= 1,        if JOBD = 'Z'.
C
C     GPEAK   (output) DOUBLE PRECISION array, dimension (2)
C             The L-infinity norm of the system, i.e., the peak gain
C             of the frequency response (as measured by the largest
C             singular value in the MIMO case), coded in the same way
C             as FPEAK.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             Tolerance used to set the accuracy in determining the
C             norm.  0 <= TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= K, where K can be computed using the following
C             pseudo-code (or the Fortran code included in the routine)
C
C                d = 6*MIN(P,M);
C                c = MAX( 4*MIN(P,M) + MAX(P,M), d );
C                if ( MIN(P,M) = 0 ) then
C                   K = 1;
C                else if( N = 0 or B = 0 or C = 0 ) then
C                   if( JOBD = 'D' ) then
C                      K = P*M + c;
C                   else
C                      K = 1;
C                   end
C                else
C                   if ( DICO = 'D' ) then
C                      b = 0;  e = d;
C                   else
C                      b = N*(N+M);  e = c;
C                      if ( JOBD = Z' ) then  b = b + P*M;  end
C                   end
C                   if ( JOBD = 'D' ) then
C                      r = P*M;
C                      if ( JOBE = 'I', DICO = 'C',
C                           N > 0, B <> 0, C <> 0 ) then
C                         K = P*P + M*M;
C                         r = r + N*(P+M);
C                      else
C                         K = 0;
C                      end
C                      K = K + r + c;  r = r + MIN(P,M);
C                   else
C                      r = 0;  K = 0;
C                   end
C                   r = r + N*(N+P+M);
C                   if ( JOBE = 'G' ) then
C                      r = r + N*N;
C                      if ( EQUIL = 'S' ) then
C                         K = MAX( K, r + 9*N );
C                      end
C                      K = MAX( K, r + 4*N + MAX( M, 2*N*N, N+b+e ) );
C                   else
C                      K = MAX( K, r + N +
C                                  MAX( M, P, N*N+2*N, 3*N+b+e ) );
C                   end
C                   w = 0;
C                   if ( JOBE = 'I', DICO = 'C' ) then
C                      w = r + 4*N*N + 11*N;
C                      if ( JOBD = 'D' ) then
C                         w = w + MAX(M,P) + N*(P+M);
C                      end
C                   end
C                   if ( JOBE = 'E' or DICO = 'D' or JOBD = 'D' ) then
C                      w = MAX( w, r + 6*N + (2*N+P+M)*(2*N+P+M) +
C                               MAX( 2*(N+P+M), 8*N*N + 16*N ) );
C                   end
C                   K = MAX( 1, K, w, r + 2*N + e );
C                end
C
C             For good performance, LDWORK must generally be larger.
C
C             An easily computable upper bound is
C
C             K = MAX( 1, 15*N*N + P*P + M*M + (6*N+3)*(P+M) + 4*P*M +
C                         N*M + 22*N + 7*MIN(P,M) ).
C
C             The smallest workspace is obtained for DICO = 'C',
C             JOBE = 'I', and JOBD = 'Z', namely
C
C             K = MAX( 1, N*N + N*P + N*M + N +
C                         MAX( N*N + N*M + P*M + 3*N + c,
C                              4*N*N + 10*N ) ).
C
C             for which an upper bound is
C
C             K = MAX( 1, 6*N*N + N*P + 2*N*M + P*M + 11*N + MAX(P,M) +
C                         6*MIN(P,M) ).
C
C     CWORK   COMPLEX*16 array, dimension (LCWORK)
C             On exit, if INFO = 0, CWORK(1) contains the optimal
C             LCWORK.
C
C     LCWORK  INTEGER
C             The dimension of the array CWORK.
C             LCWORK >= 1,  if N = 0, or B = 0, or C = 0;
C             LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)),
C                           otherwise.
C             For good performance, LCWORK must generally be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the matrix E is (numerically) singular;
C             = 2:  the (periodic) QR (or QZ) algorithm for computing
C                   eigenvalues did not converge;
C             = 3:  the SVD algorithm for computing singular values did
C                   not converge;
C             = 4:  the tolerance is too small and the algorithm did
C                   not converge.
C
C     METHOD
C
C     The routine implements the method presented in [1], with
C     extensions and refinements for improving numerical robustness and
C     efficiency. Structure-exploiting eigenvalue computations for
C     Hamiltonian matrices are used if JOBE = 'I', DICO = 'C', and the
C     symmetric matrices to be implicitly inverted are not too ill-
C     conditioned. Otherwise, generalized eigenvalue computations are
C     used in the iterative algorithm of [1].
C
C     REFERENCES
C
C     [1] Bruinsma, N.A. and Steinbuch, M.
C         A fast algorithm to compute the Hinfinity-norm of a transfer
C         function matrix.
C         Systems & Control Letters, vol. 14, pp. 287-293, 1990.
C
C     NUMERICAL ASPECTS
C
C     If the algorithm does not converge in MAXIT = 30 iterations
C     (INFO = 4), the tolerance must be increased.
C
C     FURTHER COMMENTS
C
C     If the matrix E is singular, other SLICOT Library routines
C     could be used before calling AB13DD, for removing the singular
C     part of the system.
C
C     CONTRIBUTORS
C
C     D. Sima, University of Bucharest, May 2001.
C     V. Sima, Research Institute for Informatics, Bucharest, May 2001.
C     Partly based on SLICOT Library routine AB13CD by P.Hr. Petkov,
C     D.W. Gu and M.M. Konstantinov.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, June 2001,
C     May 2003, Aug. 2005, March 2008, May 2009, Sep. 2009.
C
C     KEYWORDS
C
C     H-infinity optimal control, robust control, system norm.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER            MAXIT
      PARAMETER          ( MAXIT = 30 )
      DOUBLE PRECISION   ZERO, ONE, TWO, FOUR, P25
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
     $                     FOUR = 4.0D+0, P25 = 0.25D+0 )
      DOUBLE PRECISION   TEN, HUNDRD, THOUSD
      PARAMETER          ( TEN    = 1.0D+1, HUNDRD = 1.0D+2,
     $                     THOUSD = 1.0D+3 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          DICO, EQUIL, JOBD, JOBE
      INTEGER            INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK,
     $                   M, N, P
      DOUBLE PRECISION   TOL
C     ..
C     .. Array Arguments ..
      COMPLEX*16         CWORK(  * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK(  * ), E( LDE, * ),
     $                   FPEAK(  2 ), GPEAK(  2 )
      INTEGER            IWORK(  * )
C     ..
C     .. Local Scalars ..
      CHARACTER          VECT
      LOGICAL            DISCR, FULLE, ILASCL, ILESCL, LEQUIL, NODYN,
     $                   USEPEN, WITHD
      INTEGER            I, IA, IAR, IAS, IB, IBS, IBT, IBV, IC, ICU,
     $                   ID, IE, IERR, IES, IH, IH12, IHI, II, ILO, IM,
     $                   IMIN, IPA, IPE, IR, IS, ISB, ISC, ISL, ITAU,
     $                   ITER, IU, IV, IWRK, J, K, LW, MAXCWK, MAXWRK,
     $                   MINCWR, MINPM, MINWRK, N2, N2PM, NEI, NN, NWS,
     $                   NY, PM
      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNORM, BOUND, CNORM,
     $                   ENRM, ENRMTO, EPS, FPEAKI, FPEAKS, GAMMA,
     $                   GAMMAL, GAMMAS, MAXRED, OMEGA, PI, RAT, RCOND,
     $                   RTOL, SAFMAX, SAFMIN, SMLNUM, TM, TOLER, WMAX,
     $                   WRMIN
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION   TEMP( 1 )
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   AB13DX, DLAMCH, DLANGE, DLAPY2
      LOGICAL            LSAME
      EXTERNAL           AB13DX, DLAMCH, DLANGE, DLAPY2, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEBAL, DGEHRD, DGEMM, DGEQRF, DGESVD,
     $                   DGGBAL, DGGEV, DHGEQZ, DHSEQR, DLABAD, DLACPY,
     $                   DLASCL, DLASRT, DORGQR, DORMHR, DSWAP, DSYRK,
     $                   DTRCON, MA02AD, MB01SD, MB03XD, TB01ID, TG01AD,
     $                   TG01BD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, ATAN, ATAN2, COS, DBLE, INT, LOG, MAX,
     $                   MIN, SIN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar parameters.
C
      N2     = 2*N
      NN     = N*N
      PM     = P  + M
      N2PM   = N2 + PM
      MINPM  = MIN( P, M )
      INFO   = 0
      DISCR  = LSAME( DICO,  'D' )
      FULLE  = LSAME( JOBE,  'G' )
      LEQUIL = LSAME( EQUIL, 'S' )
      WITHD  = LSAME( JOBD,  'D' )
C
      IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( FULLE  .OR. LSAME( JOBE,  'I' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT. ( WITHD  .OR. LSAME( JOBD,  'Z' ) ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( P.LT.0 ) THEN
         INFO = -7
      ELSE IF( MIN( FPEAK( 1 ), FPEAK( 2 ) ).LT.ZERO ) THEN
         INFO = -8
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -16
      ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN
         INFO = -18
      ELSE IF( TOL.LT.ZERO .OR. TOL.GE.ONE ) THEN
         INFO = -20
      ELSE
         BNORM  = DLANGE( '1-norm', N, M, B, LDB, DWORK )
         CNORM  = DLANGE( '1-norm', P, N, C, LDC, DWORK )
         NODYN  = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO
         USEPEN = FULLE .OR. DISCR
C
C        Compute workspace.
C
         ID = 6*MINPM
         IC = MAX( 4*MINPM + MAX( P, M ), ID )
         IF( MINPM.EQ.0 ) THEN
            MINWRK = 1
         ELSE IF( NODYN ) THEN
            IF( WITHD ) THEN
               MINWRK = P*M + IC
            ELSE
               MINWRK = 1
            END IF
         ELSE
            IF ( DISCR ) THEN
               IB = 0
               IE = ID
            ELSE
               IB = N*( N + M )
               IF ( .NOT.WITHD )
     $            IB = IB + P*M
               IE = IC
            END IF
            IF ( WITHD ) THEN
               IR = P*M
               IF ( .NOT.USEPEN ) THEN
                  MINWRK = P*P + M*M
                  IR = IR + N*PM
               ELSE
                  MINWRK = 0
               END IF
               MINWRK = MINWRK + IR + IC
               IR = IR + MINPM
            ELSE
               IR = 0
               MINWRK = 0
            END IF
            IR = IR + N*( N + PM )
            IF ( FULLE ) THEN
               IR = IR + NN
               IF ( LEQUIL )
     $            MINWRK = MAX( MINWRK, IR + 9*N )
               MINWRK = MAX( MINWRK, IR + 4*N + MAX( M, 2*NN,
     $                                               N + IB + IE ) )
            ELSE
               MINWRK = MAX( MINWRK, IR + N + MAX( M, P, NN + N2,
     $                                             3*N + IB + IE ) )
            END IF
            LW = 0
            IF ( .NOT.USEPEN ) THEN
               LW = IR + 4*NN + 11*N
               IF ( WITHD )
     $            LW = LW + MAX( M, P ) + N*PM
            END IF
            IF ( USEPEN .OR. WITHD )
     $         LW = MAX( LW, IR + 6*N + N2PM*N2PM +
     $                       MAX( N2PM + PM, 8*( NN + N2 ) ) )
            MINWRK = MAX( 1, MINWRK, LW, IR + N2 + IE )
         END IF
C
         IF( LDWORK.LT.MINWRK ) THEN
            INFO = -23
         ELSE
            IF ( NODYN ) THEN
               MINCWR = 1
            ELSE
               MINCWR = MAX( 1, ( N + M )*( N + P ) +
     $                          2*MINPM + MAX( P, M ) )
            END IF
            IF( LCWORK.LT.MINCWR )
     $         INFO = -25
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'AB13DD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( M.EQ.0 .OR. P.EQ.0 ) THEN
         GPEAK( 1 ) = ZERO
         FPEAK( 1 ) = ZERO
         GPEAK( 2 ) = ONE
         FPEAK( 2 ) = ONE
         DWORK( 1 ) = ONE
         CWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Determine the maximum singular value of G(infinity) = D .
C     If JOBE = 'I' and DICO = 'C', the full SVD of D, D = U*S*V', is
C     computed and saved for later use.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      ID = 1
      IF ( WITHD ) THEN
         IS = ID + P*M
         IF ( USEPEN .OR. NODYN ) THEN
            IU   = IS + MINPM
            IV   = IU
            IWRK = IV
            VECT = 'N'
         ELSE
            IBV  = IS  + MINPM
            ICU  = IBV + N*M
            IU   = ICU + P*N
            IV   = IU  + P*P
            IWRK = IV  + M*M
            VECT = 'A'
         END IF
C
C        Workspace: need   P*M + MIN(P,M) + V +
C                          MAX( 3*MIN(P,M) + MAX(P,M), 5*MIN(P,M) ),
C                          where V = N*(M+P) + P*P + M*M,
C                                        if JOBE = 'I' and DICO = 'C',
C                                        and N > 0, B <> 0, C <> 0,
C                                V = 0,  otherwise;
C                   prefer larger.
C
         CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P )
         CALL DGESVD( VECT, VECT, P, M, DWORK( ID ), P, DWORK( IS ),
     $                DWORK( IU ), P, DWORK( IV ), M, DWORK( IWRK ),
     $                LDWORK-IWRK+1, IERR )
         IF( IERR.GT.0 ) THEN
            INFO = 3
            RETURN
         END IF
         GAMMAL = DWORK( IS )
         MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1
C
C        Restore D for later calculations.
C
         CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P )
      ELSE
         IWRK   = 1
         GAMMAL = ZERO
         MAXWRK = 1
      END IF
C
C     Quick return if possible.
C
      IF( NODYN ) THEN
         GPEAK( 1 ) = GAMMAL
         FPEAK( 1 ) = ZERO
         GPEAK( 2 ) = ONE
         FPEAK( 2 ) = ONE
         DWORK( 1 ) = MAXWRK
         CWORK( 1 ) = ONE
         RETURN
      END IF
C
      IF ( .NOT.USEPEN .AND. WITHD ) THEN
C
C        Standard continuous-time case, D <> 0: Compute B*V and C'*U .
C
         CALL DGEMM( 'No Transpose', 'Transpose', N, M, M, ONE, B, LDB,
     $               DWORK( IV ), M, ZERO, DWORK( IBV ), N )
         CALL DGEMM( 'Transpose', 'No Transpose', N, P, P, ONE, C,
     $               LDC, DWORK( IU ), P, ZERO, DWORK( ICU ), N )
C
C        U and V are no longer needed: free their memory space.
C        Total workspace here: need   P*M + MIN(P,M) + N*(M+P)
C        (JOBE = 'I', DICO = 'C', JOBD = 'D').
C
         IWRK = IU
      END IF
C
C     Get machine constants.
C
      EPS    = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFMAX = ONE / SAFMIN
      CALL DLABAD( SAFMIN, SAFMAX )
      SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' )
      BIGNUM = ONE / SMLNUM
      TOLER  = SQRT( EPS )
C
C     Initiate the transformation of the system to an equivalent one,
C     to be used for eigenvalue computations.
C
C     Additional workspace: need   N*N + N*M + P*N + 2*N, if JOBE = 'I';
C                                2*N*N + N*M + P*N + 2*N, if JOBE = 'G'.
C
      IA = IWRK
      IE = IA + NN
      IF ( FULLE ) THEN
         IB = IE + NN
      ELSE
         IB = IE
      END IF
      IC  = IB + N*M
      IR  = IC + P*N
      II  = IR + N
      IBT = II + N
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IA ), N )
      CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IB ), N )
      CALL DLACPY( 'Full', P, N, C, LDC, DWORK( IC ), P )
C
C     Scale A if maximum element is outside the range [SMLNUM,BIGNUM].
C
      ANRM = DLANGE( 'Max', N, N, DWORK( IA ), N, DWORK )
      ILASCL = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ANRMTO = SMLNUM
         ILASCL = .TRUE.
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ANRMTO = BIGNUM
         ILASCL = .TRUE.
      END IF
      IF( ILASCL )
     $   CALL DLASCL( 'General', 0, 0, ANRM, ANRMTO, N, N, DWORK( IA ),
     $                N, IERR )
C
      IF ( FULLE ) THEN
C
C        Descriptor system.
C
C        Additional workspace: need   N.
C
         IWRK = IBT + N
         CALL DLACPY( 'Full', N, N, E, LDE, DWORK( IE ), N )
C
C        Scale E if maximum element is outside the range
C        [SMLNUM,BIGNUM].
C
         ENRM = DLANGE( 'Max', N, N, DWORK( IE ), N, DWORK )
         ILESCL = .FALSE.
         IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN
            ENRMTO = SMLNUM
            ILESCL = .TRUE.
         ELSE IF( ENRM.GT.BIGNUM ) THEN
            ENRMTO = BIGNUM
            ILESCL = .TRUE.
         ELSE IF( ENRM.EQ.ZERO ) THEN
C
C           Error return: Matrix E is 0.
C
            INFO = 1
            RETURN
         END IF
         IF( ILESCL )
     $      CALL DLASCL( 'General', 0, 0, ENRM, ENRMTO, N, N,
     $                   DWORK( IE ), N, IERR )
C
C        Equilibrate the system, if required.
C
C        Additional workspace: need   6*N.
C
         IF( LEQUIL )
     $      CALL TG01AD( 'All', N, N, M, P, ZERO, DWORK( IA ), N,
     $                   DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), P,
     $                   DWORK( II ), DWORK( IR ), DWORK( IWRK ),
     $                   IERR )
C
C        For efficiency of later calculations, the system (A,E,B,C) is
C        reduced to an equivalent one with the state matrix A in
C        Hessenberg form, and E upper triangular.
C        First, permute (A,E) to make it more nearly triangular.
C
         CALL DGGBAL( 'Permute', N, DWORK( IA ), N, DWORK( IE ), N, ILO,
     $                IHI, DWORK( II ), DWORK( IR ), DWORK( IWRK ),
     $                IERR )
C
C        Apply the permutations to (the copies of) B and C.
C
         DO 10 I = N, IHI + 1, -1
            K = DWORK( II+I-1 )
            IF( K.NE.I )
     $         CALL DSWAP( M, DWORK( IB+I-1 ), N,
     $                        DWORK( IB+K-1 ), N )
            K = DWORK( IR+I-1 )
            IF( K.NE.I )
     $         CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1,
     $                        DWORK( IC+(K-1)*P ), 1 )
   10    CONTINUE
C
         DO 20 I = 1, ILO - 1
            K = DWORK( II+I-1 )
            IF( K.NE.I )
     $         CALL DSWAP( M, DWORK( IB+I-1 ), N,
     $                        DWORK( IB+K-1 ), N )
            K = DWORK( IR+I-1 )
            IF( K.NE.I )
     $         CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1,
     $                        DWORK( IC+(K-1)*P ), 1 )
   20    CONTINUE
C
C        Reduce (A,E) to generalized Hessenberg form and apply the
C        transformations to B and C.
C        Additional workspace: need   N + MAX(N,M);
C                              prefer N + MAX(N,M)*NB.
C
         CALL TG01BD( 'General', 'No Q', 'No Z', N, M, P, ILO, IHI,
     $                DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), N,
     $                DWORK( IC ), P, DWORK, 1, DWORK, 1, DWORK( IWRK ),
     $                LDWORK-IWRK+1, IERR )
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
C        Check whether matrix E is nonsingular.
C        Additional workspace: need   3*N.
C
         CALL DTRCON( '1-norm', 'Upper', 'Non Unit', N, DWORK( IE ), N,
     $                RCOND, DWORK( IWRK ), IWORK, IERR )
         IF( RCOND.LE.TEN*DBLE( N )*EPS ) THEN
C
C           Error return: Matrix E is numerically singular.
C
            INFO = 1
            RETURN
         END IF
C
C        Perform QZ algorithm, computing eigenvalues. The generalized
C        Hessenberg form is saved for later use.
C        Additional workspace: need   2*N*N + N;
C                              prefer larger.
C
         IAS  = IWRK
         IES  = IAS + NN
         IWRK = IES + NN
         CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N )
         CALL DLACPY( 'Full', N, N, DWORK( IE ), N, DWORK( IES ), N )
         CALL DHGEQZ( 'Eigenvalues', 'No Vectors', 'No Vectors', N, ILO,
     $                IHI, DWORK( IAS ), N, DWORK( IES ), N,
     $                DWORK( IR ), DWORK( II ), DWORK( IBT ), DWORK, N,
     $                DWORK, N, DWORK( IWRK ), LDWORK-IWRK+1, IERR )
         IF( IERR.NE.0 ) THEN
            INFO = 2
            RETURN
         END IF
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
C        Check if unscaling would cause over/underflow; if so, rescale
C        eigenvalues (DWORK( IR+I-1 ),DWORK( II+I-1 ),DWORK( IBT+I-1 ))
C        so DWORK( IBT+I-1 ) is on the order of E(I,I) and
C        DWORK( IR+I-1 ) and DWORK( II+I-1 ) are on the order of A(I,I).
C
         IF( ILASCL ) THEN
C
            DO 30 I = 1, N
               IF( DWORK( II+I-1 ).NE.ZERO ) THEN
                  IF( ( DWORK( IR+I-1 ) / SAFMAX ).GT.( ANRMTO / ANRM )
     $                                                              .OR.
     $                ( SAFMIN / DWORK( IR+I-1 ) ).GT.( ANRM / ANRMTO )
     $              ) THEN
                     TM = ABS( DWORK( IA+(I-1)*N+I ) / DWORK( IR+I-1 ) )
                     DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM
                     DWORK(  IR+I-1 ) = DWORK(  IR+I-1 )*TM
                     DWORK(  II+I-1 ) = DWORK(  II+I-1 )*TM
                  ELSE IF( ( DWORK( II+I-1 ) / SAFMAX ).GT.
     $                     ( ANRMTO / ANRM ) .OR.
     $               ( SAFMIN / DWORK( II+I-1 ) ).GT.( ANRM / ANRMTO ) )
     $                     THEN
                     TM = ABS( DWORK( IA+I*N+I ) / DWORK( II+I-1 ) )
                     DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM
                     DWORK(  IR+I-1 ) = DWORK(  IR+I-1 )*TM
                     DWORK(  II+I-1 ) = DWORK(  II+I-1 )*TM
                  END IF
               END IF
   30       CONTINUE
C
         END IF
C
         IF( ILESCL ) THEN
C
            DO 40 I = 1, N
               IF( DWORK( II+I-1 ).NE.ZERO ) THEN
                  IF( ( DWORK( IBT+I-1 ) / SAFMAX ).GT.( ENRMTO / ENRM )
     $                                                              .OR.
     $                ( SAFMIN / DWORK( IBT+I-1 ) ).GT.( ENRM / ENRMTO )
     $              ) THEN
                     TM = ABS( DWORK( IE+(I-1)*N+I ) / DWORK( IBT+I-1 ))
                     DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM
                     DWORK(  IR+I-1 ) = DWORK(  IR+I-1 )*TM
                     DWORK(  II+I-1 ) = DWORK(  II+I-1 )*TM
                  END IF
               END IF
   40       CONTINUE
C
         END IF
C
C        Undo scaling.
C
         IF( ILASCL ) THEN
            CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N,
     $                   DWORK( IA ), N, IERR )
            CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1,
     $                   DWORK( IR ), N, IERR )
            CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1,
     $                   DWORK( II ), N, IERR )
         END IF
C
         IF( ILESCL ) THEN
            CALL DLASCL( 'Upper', 0, 0, ENRMTO, ENRM, N, N,
     $                   DWORK( IE ), N, IERR )
            CALL DLASCL( 'General', 0, 0, ENRMTO, ENRM, N, 1,
     $                   DWORK( IBT ), N, IERR )
         END IF
C
      ELSE
C
C        Standard state-space system.
C
         IF( LEQUIL ) THEN
C
C           Equilibrate the system.
C
            MAXRED = HUNDRD
            CALL TB01ID( 'All', N, M, P, MAXRED, DWORK( IA ), N,
     $                   DWORK( IB ), N,  DWORK( IC ), P, DWORK( II ),
     $                   IERR )
         END IF
C
C        For efficiency of later calculations, the system (A,B,C) is
C        reduced to a similar one with the state matrix in Hessenberg
C        form.
C
C        First, permute the matrix A to make it more nearly triangular
C        and apply the permutations to B and C.
C
         CALL DGEBAL( 'Permute', N, DWORK( IA ), N, ILO, IHI,
     $                DWORK( IR ), IERR )
C
         DO 50 I = N, IHI + 1, -1
            K = DWORK( IR+I-1 )
            IF( K.NE.I ) THEN
               CALL DSWAP( M, DWORK( IB+I-1 ), N,
     $                        DWORK( IB+K-1 ), N )
               CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1,
     $                        DWORK( IC+(K-1)*P ), 1 )
            END IF
   50    CONTINUE
C
         DO 60 I = 1, ILO - 1
            K = DWORK( IR+I-1 )
            IF( K.NE.I ) THEN
               CALL DSWAP( M, DWORK( IB+I-1 ), N,
     $                        DWORK( IB+K-1 ), N )
               CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1,
     $                        DWORK( IC+(K-1)*P ), 1 )
            END IF
   60    CONTINUE
C
C        Reduce A to upper Hessenberg form and apply the transformations
C        to B and C.
C        Additional workspace: need   N;   (from II)
C                              prefer N*NB.
C
         ITAU = IR
         IWRK = ITAU + N
         CALL DGEHRD( N, ILO, IHI, DWORK( IA ), N, DWORK( ITAU ),
     $                DWORK( IWRK ), LDWORK-IWRK+1, IERR )
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
C        Additional workspace: need   M;
C                              prefer M*NB.
C
         CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, DWORK( IA ),
     $                N, DWORK( ITAU ), DWORK( IB ), N, DWORK( IWRK ),
     $                LDWORK-IWRK+1, IERR )
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
C        Additional workspace: need   P;
C                              prefer P*NB.
C
         CALL DORMHR( 'Right', 'NoTranspose', P, N, ILO, IHI,
     $                DWORK( IA ), N, DWORK( ITAU ), DWORK( IC ), P,
     $                DWORK( IWRK ), LDWORK-IWRK+1, IERR )
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
C        Compute the eigenvalues. The Hessenberg form is saved for
C        later use.
C        Additional workspace:  need   N*N + N;   (from IBT)
C                               prefer larger.
C
         IAS  = IBT
         IWRK = IAS + NN
         CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N )
         CALL DHSEQR( 'Eigenvalues', 'No Vectors', N, ILO, IHI,
     $                DWORK( IAS ), N, DWORK( IR ), DWORK( II ), DWORK,
     $                N, DWORK( IWRK ), LDWORK-IWRK+1, IERR )
         IF( IERR.GT.0 ) THEN
            INFO = 2
            RETURN
         END IF
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
         IF( ILASCL ) THEN
C
C           Undo scaling for the Hessenberg form of A and eigenvalues.
C
            CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N,
     $                   DWORK( IA ), N, IERR )
            CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1,
     $                   DWORK( IR ), N, IERR )
            CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1,
     $                   DWORK( II ), N, IERR )
         END IF
C
      END IF
C
C     Look for (generalized) eigenvalues on the boundary of the
C     stability domain. (Their existence implies an infinite norm.)
C     Additional workspace:  need   2*N.   (from IAS)
C
      IM    = IAS
      IAR   = IM + N
      IMIN  = II
      WRMIN = SAFMAX
      BOUND = EPS*THOUSD
C
      IF ( DISCR ) THEN
         GAMMAL = ZERO
C
C        For discrete-time case, compute the logarithm of the non-zero
C        eigenvalues and save their moduli and absolute real parts.
C        (The logarithms are overwritten on the eigenvalues.)
C        Also, find the minimum distance to the unit circle.
C
         IF ( FULLE ) THEN
C
            DO 70 I = 0, N - 1
               TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) )
               IF ( ( DWORK( IBT+I ).GE.ONE ) .OR.
     $              ( DWORK( IBT+I ).LT.ONE  .AND.
     $                TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN
                  TM = TM / DWORK( IBT+I )
               ELSE
C
C                 The pencil has too large eigenvalues. SAFMAX is used.
C
                  TM = SAFMAX
               END IF
               IF ( TM.NE.ZERO ) THEN
                  DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) )
                  DWORK( IR+I ) = LOG( TM )
               END IF
               DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) )
               TM = ABS( ONE - TM )
               IF( TM.LT.WRMIN ) THEN
                  IMIN  = II + I
                  WRMIN = TM
               END IF
               IM = IM + 1
               DWORK( IAR+I ) = ABS( DWORK( IR+I ) )
   70       CONTINUE
C
         ELSE
C
            DO 80 I = 0, N - 1
               TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) )
               IF ( TM.NE.ZERO ) THEN
                  DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) )
                  DWORK( IR+I ) = LOG( TM )
               END IF
               DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) )
               TM = ABS( ONE - TM )
               IF( TM.LT.WRMIN ) THEN
                  IMIN  = II + I
                  WRMIN = TM
               END IF
               IM = IM + 1
               DWORK( IAR+I ) = ABS( DWORK( IR+I ) )
   80       CONTINUE
C
         END IF
C
      ELSE
C
C        For continuous-time case, save moduli of eigenvalues and
C        absolute real parts and find the maximum modulus and minimum
C        absolute real part.
C
         WMAX = ZERO
C
         IF ( FULLE ) THEN
C
            DO 90 I = 0, N - 1
               TM = ABS( DWORK( IR+I ) )
               DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) )
               IF ( ( DWORK( IBT+I ).GE.ONE ) .OR.
     $              ( DWORK( IBT+I ).LT.ONE  .AND.
     $                DWORK( IM ).LT.SAFMAX*DWORK( IBT+I ) ) )
     $                   THEN
                  TM = TM / DWORK( IBT+I )
                  DWORK( IM ) = DWORK( IM ) / DWORK( IBT+I )
               ELSE
                  IF ( TM.LT.SAFMAX*DWORK( IBT+I ) ) THEN
                     TM = TM / DWORK( IBT+I )
                  ELSE
C
C                    The pencil has too large eigenvalues.
C                    SAFMAX is used.
C
                     TM = SAFMAX
                  END IF
                  DWORK( IM ) = SAFMAX
               END IF
               IF( TM.LT.WRMIN ) THEN
                  IMIN  = II + I
                  WRMIN = TM
               END IF
               DWORK( IAR+I ) = TM
               IF( DWORK( IM ).GT.WMAX )
     $            WMAX = DWORK( IM )
               IM = IM + 1
   90       CONTINUE
C
         ELSE
C
            DO 100 I = 0, N - 1
               TM = ABS( DWORK( IR+I ) )
               IF( TM.LT.WRMIN ) THEN
                  IMIN  = II + I
                  WRMIN = TM
               END IF
               DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) )
               IF( DWORK( IM ).GT.WMAX )
     $            WMAX = DWORK( IM )
               IM = IM + 1
               DWORK( IAR+I ) = TM
  100       CONTINUE
C
         END IF
C
         BOUND = BOUND + EPS*WMAX
C
      END IF
C
      IM = IM - N
C
      IF( WRMIN.LT.BOUND ) THEN
C
C        The L-infinity norm was found as infinite.
C
         GPEAK( 1 ) = ONE
         GPEAK( 2 ) = ZERO
         TM = ABS( DWORK( IMIN ) )
         IF ( DISCR )
     $      TM = ABS( ATAN2( SIN( TM ), COS( TM ) ) )
         FPEAK( 1 ) = TM
         IF ( TM.LT.SAFMAX ) THEN
            FPEAK( 2 ) = ONE
         ELSE
            FPEAK( 2 ) = ZERO
         END IF
C
         DWORK( 1 ) = MAXWRK
         CWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Determine the maximum singular value of
C        G(lambda) = C*inv(lambda*E - A)*B + D,
C     over a selected set of frequencies. Besides the frequencies w = 0,
C     w = pi (if DICO = 'D'), and the given value FPEAK, this test set
C     contains the peak frequency for each mode (or an approximation
C     of it). The (generalized) Hessenberg form of the system is used.
C
C     First, determine the maximum singular value of G(0) and set FPEAK
C     accordingly.
C     Additional workspace:
C           complex: need   1, if DICO = 'C';
C                           (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)), otherwise;
C                    prefer larger;
C           real:    need   LDW0+LDW1+LDW2, where
C                           LDW0 = N*N+N*M, if DICO = 'C';
C                           LDW0 = 0,       if DICO = 'D';
C                           LDW1 = P*M,     if DICO = 'C', JOBD = 'Z';
C                           LDW1 = 0,       otherwise;
C                           LDW2 = MIN(P,M)+MAX(3*MIN(P,M)+MAX(P,M),
C                                               5*MIN(P,M)),
C                                              if DICO = 'C';
C                           LDW2 = 6*MIN(P,M), otherwise.
C                    prefer larger.
C
      IF ( DISCR ) THEN
         IAS  = IA
         IBS  = IB
         IWRK = IAR + N
      ELSE
         IAS  = IAR + N
         IBS  = IAS + NN
         IWRK = IBS + N*M
         CALL DLACPY( 'Upper', N, N, DWORK( IA ), N, DWORK( IAS ), N )
         CALL DCOPY(  N-1, DWORK( IA+1 ), N+1, DWORK( IAS+1 ), N+1 )
         CALL DLACPY( 'Full', N, M, DWORK( IB ), N, DWORK( IBS ), N )
      END IF
      GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, ZERO, DWORK( IAS ), N,
     $                DWORK( IE ), N, DWORK( IBS ), N, DWORK( IC ), P,
     $                DWORK( ID ), P, IWORK, DWORK( IWRK ),
     $                LDWORK-IWRK+1, CWORK, LCWORK, IERR )
      MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
      IF( IERR.GE.1 .AND. IERR.LE.N ) THEN
         GPEAK( 1 ) = ONE
         FPEAK( 1 ) = ZERO
         GPEAK( 2 ) = ZERO
         FPEAK( 2 ) = ONE
         GO TO 340
      ELSE IF( IERR.EQ.N+1 ) THEN
         INFO = 3
         RETURN
      END IF
C
      FPEAKS = FPEAK( 1 )
      FPEAKI = FPEAK( 2 )
      IF( GAMMAL.LT.GAMMA ) THEN
         GAMMAL     = GAMMA
         FPEAK( 1 ) = ZERO
         FPEAK( 2 ) = ONE
      ELSE IF( .NOT.DISCR ) THEN
         FPEAK( 1 ) = ONE
         FPEAK( 2 ) = ZERO
      END IF
C
      MAXCWK = INT( CWORK( 1 ) )
C
      IF( DISCR ) THEN
C
C        Try the frequency w = pi.
C
         PI    = FOUR*ATAN( ONE )
         GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, PI, DWORK( IA ),
     $                   N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ),
     $                   P, DWORK( ID ), P, IWORK, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, CWORK, LCWORK, IERR )
         MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK )
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
         IF( IERR.GE.1 .AND. IERR.LE.N ) THEN
            GPEAK( 1 ) = ONE
            FPEAK( 1 ) = PI
            GPEAK( 2 ) = ZERO
            FPEAK( 2 ) = ONE
            GO TO 340
         ELSE IF( IERR.EQ.N+1 ) THEN
            INFO = 3
            RETURN
         END IF
C
         IF( GAMMAL.LT.GAMMA ) THEN
            GAMMAL     = GAMMA
            FPEAK( 1 ) = PI
            FPEAK( 2 ) = ONE
         END IF
C
      ELSE
         IWRK = IAS
C
C        Restore D, if needed.
C
         IF ( WITHD )
     $      CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P )
      END IF
C
C     Build the remaining set of frequencies.
C     Complex workspace:  need   (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M));
C                         prefer larger.
C     Real workspace:     need   LDW2, see above;
C                         prefer larger.
C
      IF ( MIN( FPEAKS, FPEAKI ).NE.ZERO ) THEN
C
C        Compute also the norm at the given (finite) frequency.
C
         GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, FPEAKS, DWORK( IA ),
     $                   N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ),
     $                   P, DWORK( ID ), P, IWORK, DWORK( IWRK ),
     $                   LDWORK-IWRK+1, CWORK, LCWORK, IERR )
         MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK )
         MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
         IF ( DISCR ) THEN
            TM = ABS( ATAN2( SIN( FPEAKS ), COS( FPEAKS ) ) )
         ELSE
            TM = FPEAKS
         END IF
         IF( IERR.GE.1 .AND. IERR.LE.N ) THEN
            GPEAK( 1 ) = ONE
            FPEAK( 1 ) = TM
            GPEAK( 2 ) = ZERO
            FPEAK( 2 ) = ONE
            GO TO 340
         ELSE IF( IERR.EQ.N+1 ) THEN
            INFO = 3
            RETURN
         END IF
C
         IF( GAMMAL.LT.GAMMA ) THEN
            GAMMAL     = GAMMA
            FPEAK( 1 ) = TM
            FPEAK( 2 ) = ONE
         END IF
C
      END IF
C
      DO 110 I = 0, N - 1
         IF( DWORK( II+I ).GE.ZERO .AND. DWORK( IM+I ).GT.ZERO ) THEN
            IF ( ( DWORK( IM+I ).GE.ONE ) .OR. ( DWORK( IM+I ).LT.ONE
     $            .AND. DWORK( IAR+I ).LT.SAFMAX*DWORK( IM+I ) ) ) THEN
               RAT = DWORK( IAR+I ) / DWORK( IM+I )
            ELSE
               RAT = ONE
            END IF
            OMEGA = DWORK( IM+I )*SQRT( MAX( P25, ONE - TWO*RAT**2 ) )
C
            GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA,
     $                      DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ),
     $                      N, DWORK( IC ), P, DWORK( ID ), P, IWORK,
     $                      DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK,
     $                      IERR )
            MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK )
            MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
            IF ( DISCR ) THEN
               TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) )
            ELSE
               TM = OMEGA
            END IF
            IF( IERR.GE.1 .AND. IERR.LE.N ) THEN
               GPEAK( 1 ) = ONE
               FPEAK( 1 ) = TM
               GPEAK( 2 ) = ZERO
               FPEAK( 2 ) = ONE
               GO TO 340
            ELSE IF( IERR.EQ.N+1 ) THEN
               INFO = 3
               RETURN
            END IF
C
            IF( GAMMAL.LT.GAMMA ) THEN
               GAMMAL     = GAMMA
               FPEAK( 1 ) = TM
               FPEAK( 2 ) = ONE
            END IF
C
         END IF
  110 CONTINUE
C
C     Return if the lower bound is zero.
C
      IF( GAMMAL.EQ.ZERO ) THEN
         GPEAK( 1 ) = ZERO
         FPEAK( 1 ) = ZERO
         GPEAK( 2 ) = ONE
         FPEAK( 2 ) = ONE
         GO TO 340
      END IF
C
C     Start the modified gamma iteration for the Bruinsma-Steinbuch
C     algorithm.
C
      IF ( .NOT.DISCR )
     $   RTOL = HUNDRD*TOLER
      ITER = 0
C
C     WHILE ( Iteration may continue ) DO
C
  120 CONTINUE
C
         ITER   = ITER + 1
         GAMMA  = ( ONE + TOL )*GAMMAL
         USEPEN = FULLE .OR. DISCR
         IF ( .NOT.USEPEN .AND. WITHD ) THEN
C
C           Check whether one can use an explicit Hamiltonian matrix:
C           compute
C           min(rcond(GAMMA**2*Im - S'*S), rcond(GAMMA**2*Ip - S*S')).
C           If P = M = 1, then GAMMA**2 - S(1)**2 is used instead.
C
            IF ( M.NE.P ) THEN
               RCOND = ONE - ( DWORK( IS ) / GAMMA )**2
            ELSE IF ( MINPM.GT.1 ) THEN
               RCOND = ( GAMMA**2 - DWORK( IS )**2 ) /
     $                 ( GAMMA**2 - DWORK( IS+P-1 )**2 )
            ELSE
               RCOND = GAMMA**2 - DWORK( IS )**2
            END IF
C
            USEPEN = RCOND.LT.RTOL
         END IF
C
         IF ( USEPEN ) THEN
C
C           Use the QZ algorithm on a pencil.
C           Additional workspace here:  need   6*N.   (from IR)
C
            II   = IR  + N2
            IBT  = II  + N2
            IH12 = IBT + N2
            IM   = IH12
C
C           Set up the needed parts of the Hamiltonian pencil (H,J),
C
C                  ( H11  H12 )
C              H = (          ) ,
C                  ( H21  H22 )
C
C           with
C
C                 ( A  0  )            ( 0  B )            ( E  0  )
C           H11 = (       ),     H12 = (      )/nB,  J11 = (       ),
C                 ( 0 -A' )            ( C' 0 )            ( 0  E' )
C
C                 ( C  0  )            ( Ip  D/g )
C           H21 = (       )*nB,  H22 = (         ),
C                 ( 0 -B' )            ( D'/g Im )
C
C           if DICO = 'C', and
C
C                 ( A  0  )            ( B  0  )            ( E  0 )
C           H11 = (       ),     H12 = (       )/nB,  J11 = (      ),
C                 ( 0  E' )            ( 0  C' )            ( 0  A')
C
C                 ( 0  0  )            ( Im  D'/g )         ( 0  B')
C           H21 = (       )*nB,  H22 = (          ),  J21 = (      )*nB,
C                 ( C  0  )            ( D/g  Ip  )         ( 0  0 )
C
C           if DICO = 'D', where g = GAMMA, and nB = norm(B,1).
C           First build [H12; H22].
C
            TEMP( 1 ) = ZERO
            IH = IH12
C
            IF ( DISCR ) THEN
C
               DO 150 J = 1, M
C
                  DO 130 I = 1, N
                     DWORK( IH ) = B( I, J ) / BNORM
                     IH = IH + 1
  130             CONTINUE
C
                  CALL DCOPY( N+M, TEMP, 0, DWORK( IH ), 1 )
                  DWORK( IH+N+J-1 ) = ONE
                  IH = IH + N + M
C
                  DO 140 I = 1, P
                     DWORK( IH ) = D( I, J ) / GAMMA
                     IH = IH + 1
  140             CONTINUE
C
  150          CONTINUE
C
               DO 180 J = 1, P
                  CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 )
                  IH = IH + N
C
                  DO 160 I = 1, N
                     DWORK( IH ) = C( J, I ) / BNORM
                     IH = IH + 1
  160             CONTINUE
C
                  DO 170 I = 1, M
                     DWORK( IH ) = D( J, I ) / GAMMA
                     IH = IH + 1
  170             CONTINUE
C
                  CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 )
                  DWORK( IH+J-1 ) = ONE
                  IH = IH + P
  180          CONTINUE
C
            ELSE
C
               DO 210 J = 1, P
                  CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 )
                  IH = IH + N
C
                  DO 190 I = 1, N
                     DWORK( IH ) = C( J, I ) / BNORM
                     IH = IH + 1
  190             CONTINUE
C
                  CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 )
                  DWORK( IH+J-1 ) = ONE
                  IH = IH + P
C
                  DO 200 I = 1, M
                     DWORK( IH ) = D( J, I ) / GAMMA
                     IH = IH + 1
  200             CONTINUE
C
  210          CONTINUE
C
               DO 240 J = 1, M
C
                  DO 220 I = 1, N
                     DWORK( IH ) = B( I, J ) / BNORM
                     IH = IH + 1
  220             CONTINUE
C
                  CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 )
                  IH = IH + N
C
                  DO 230 I = 1, P
                     DWORK( IH ) = D( I, J ) / GAMMA
                     IH = IH + 1
  230             CONTINUE
C
                  CALL DCOPY( M, TEMP, 0, DWORK( IH ), 1 )
                  DWORK( IH+J-1 ) = ONE
                  IH = IH + M
  240          CONTINUE
C
            END IF
C
C           Compute the QR factorization of [H12; H22].
C           For large P and M, it could be more efficient to exploit the
C           structure of [H12; H22] and use the factored form of Q.
C           Additional workspace: need   (2*N+P+M)*(2*N+P+M)+2*(P+M);
C                                 prefer (2*N+P+M)*(2*N+P+M)+P+M+
C                                                           (P+M)*NB.
C
            ITAU = IH12 + N2PM*N2PM
            IWRK = ITAU + PM
            CALL DGEQRF( N2PM, PM, DWORK( IH12 ), N2PM, DWORK( ITAU ),
     $                   DWORK( IWRK ), LDWORK-IWRK+1, IERR )
            MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
C           Apply part of the orthogonal transformation:
C           Q1 = Q(:,P+M+(1:2*N))' to the matrix [H11; H21/GAMMA].
C           If DICO = 'C', apply Q(1:2*N,P+M+(1:2*N))' to the
C           matrix J11.
C           If DICO = 'D', apply Q1 to the matrix [J11; J21/GAMMA].
C           H11, H21, J11, and J21 are not fully built.
C           First, build the (2*N+P+M)-by-(2*N+P+M) matrix Q.
C           Using Q will often provide better efficiency than the direct
C           use of the factored form of Q, especially when P+M < N.
C           Additional workspace: need   P+M+2*N+P+M;
C                                 prefer P+M+(2*N+P+M)*NB.
C
            CALL DORGQR( N2PM, N2PM, PM, DWORK( IH12 ), N2PM,
     $                   DWORK( ITAU ), DWORK( IWRK ), LDWORK-IWRK+1,
     $                   IERR )
            MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
C           Additional workspace: need   8*N*N.
C
            IPA  = ITAU
            IPE  = IPA + 4*NN
            IWRK = IPE + 4*NN
            CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE,
     $                  DWORK( IH12+PM*N2PM ), N2PM, A, LDA, ZERO,
     $                  DWORK( IPA ), N2 )
            IF ( DISCR ) THEN
               CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P,
     $                     BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+M), N2PM,
     $                     C, LDC, ONE, DWORK( IPA ), N2 )
               IF ( FULLE ) THEN
                  CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE,
     $                        DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE,
     $                        ZERO, DWORK( IPA+2*NN ), N2 )
               ELSE
                  CALL MA02AD( 'Full', N, N2, DWORK( IH12+PM*N2PM+N ),
     $                         N2PM, DWORK( IPA+2*NN ), N2 )
                  NY = N
               END IF
            ELSE
               CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P,
     $                     BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2), N2PM,
     $                     C, LDC, ONE, DWORK( IPA ), N2 )
               CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, -ONE,
     $                     DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, ZERO,
     $                     DWORK( IPA+2*NN ), N2 )
               CALL DGEMM( 'Transpose', 'Transpose', N2, N, M,
     $                     -BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+P),
     $                     N2PM, B, LDB, ONE, DWORK( IPA+2*NN ), N2 )
               NY = N2
            END IF
C
            IF ( FULLE ) THEN
               CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE,
     $                     DWORK( IH12+PM*N2PM ), N2PM, E, LDE, ZERO,
     $                     DWORK( IPE ), N2 )
            ELSE
               CALL MA02AD( 'Full', NY, N2, DWORK( IH12+PM*N2PM ),
     $                      N2PM, DWORK( IPE ), N2 )
            END IF
            IF ( DISCR ) THEN
               CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE,
     $                     DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA,
     $                     ZERO, DWORK( IPE+2*NN ), N2 )
               CALL DGEMM( 'Transpose', 'Transpose', N2, N, M,
     $                     BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2 ), N2PM,
     $                     B, LDB, ONE, DWORK( IPE+2*NN ), N2 )
            ELSE
               IF ( FULLE )
     $            CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE,
     $                        DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE,
     $                        ZERO, DWORK( IPE+2*NN ), N2 )
            END IF
C
C           Compute the eigenvalues of the Hamiltonian pencil.
C           Additional workspace: need   16*N;
C                                 prefer larger.
C
            CALL DGGEV( 'No Vectors', 'No Vectors', N2, DWORK( IPA ),
     $                  N2, DWORK( IPE ), N2, DWORK( IR ), DWORK( II ),
     $                  DWORK( IBT ), DWORK, N2, DWORK, N2,
     $                  DWORK( IWRK ), LDWORK-IWRK+1, IERR )
            IF( IERR.GT.0 ) THEN
               INFO = 2
               RETURN
            END IF
            MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
C
         ELSE IF ( .NOT.WITHD ) THEN
C
C           Standard continuous-time case with D = 0.
C           Form the needed part of the Hamiltonian matrix explicitly:
C              H = H11 - H12*inv(H22)*H21/g.
C           Additional workspace: need   2*N*N+N.   (from IBT)
C
            IH   = IBT
            IH12 = IH   + NN
            ISL  = IH12 + NN + N
            CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N )
C
C           Compute triangles of -C'*C/GAMMA and B*B'/GAMMA.
C
            CALL DSYRK( 'Lower', 'Transpose', N, P, -ONE/GAMMA, C, LDC,
     $                  ZERO, DWORK( IH12 ), N )
            CALL DSYRK( 'Upper', 'No Transpose', N, M, ONE/GAMMA, B,
     $                  LDB, ZERO, DWORK( IH12+N ), N )
C
         ELSE
C
C           Standard continuous-time case with D <> 0 and the SVD of D
C           can be used. Compute explicitly the needed part of the
C           Hamiltonian matrix:
C
C               (A+B1*S'*inv(g^2*Ip-S*S')*C1' g*B1*inv(g^2*Im-S'*S)*B1')
C           H = (                                                      )
C               (  -g*C1*inv(g^2*Ip-S*S')*C1'            -H11'         )
C
C           where g = GAMMA, B1 = B*V, C1 = C'*U, and H11 is the first
C           block of H.
C           Primary additional workspace: need   2*N*N+N   (from IBT)
C           (for building the relevant part of the Hamiltonian matrix).
C
C           Compute C1*sqrt(inv(g^2*Ip-S*S')) .
C           Additional workspace: need   MAX(M,P)+N*P.
C
            IH   = IBT
            IH12 = IH   + NN
            ISL  = IH12 + NN + N
C
            DO 250 I = 0, MINPM - 1
               DWORK( ISL+I ) = ONE/SQRT( GAMMA**2 - DWORK( IS+I )**2 )
  250       CONTINUE
C
            IF ( M.LT.P ) THEN
               DWORK( ISL+M ) = ONE / GAMMA
               CALL DCOPY( P-M-1, DWORK( ISL+M ), 0, DWORK( ISL+M+1 ),
     $                     1 )
            END IF
            ISC = ISL + MAX( M, P )
            CALL DLACPY( 'Full', N, P, DWORK( ICU ), N, DWORK( ISC ),
     $                   N )
            CALL MB01SD( 'Column', N, P, DWORK( ISC ), N, DWORK,
     $                   DWORK( ISL ) )
C
C           Compute B1*S' .
C           Additional workspace: need   N*M.
C
            ISB = ISC + P*N
            CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ),
     $                   N )
            CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK,
     $                   DWORK( IS ) )
C
C           Compute B1*S'*sqrt(inv(g^2*Ip-S*S')) .
C
            CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK,
     $                   DWORK( ISL ) )
C
C           Compute H11 .
C
            CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N )
            CALL DGEMM( 'No Transpose', 'Transpose', N, N, MINPM, ONE,
     $                  DWORK( ISB ), N, DWORK( ISC ), N, ONE,
     $                  DWORK( IH ), N )
C
C           Compute B1*sqrt(inv(g^2*Im-S'*S)) .
C
            IF ( P.LT.M ) THEN
               DWORK( ISL+P ) = ONE / GAMMA
               CALL DCOPY( M-P-1, DWORK( ISL+P ), 0, DWORK( ISL+P+1 ),
     $                     1 )
            END IF
            CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ),
     $                   N )
            CALL MB01SD( 'Column', N, M, DWORK( ISB ), N, DWORK,
     $                   DWORK( ISL ) )
C
C           Compute the lower triangle of H21 and the upper triangle
C           of H12.
C
            CALL DSYRK( 'Lower', 'No Transpose', N, P, -GAMMA,
     $                  DWORK( ISC ), N, ZERO, DWORK( IH12 ), N )
            CALL DSYRK( 'Upper', 'No Transpose', N, M, GAMMA,
     $                  DWORK( ISB ), N, ZERO, DWORK( IH12+N ), N )
         END IF
C
         IF ( .NOT.USEPEN ) THEN
C
C           Compute the eigenvalues of the Hamiltonian matrix by the
C           symplectic URV and the periodic Schur decompositions.
C           Additional workspace: need   (2*N+8)*N;
C                                 prefer larger.
C
            IWRK = ISL + NN
            CALL MB03XD( 'Both',  'Eigenvalues', 'No vectors',
     $                   'No vectors', N, DWORK( IH ), N, DWORK( IH12 ),
     $                   N, DWORK( ISL ), N, TEMP, 1, TEMP, 1, TEMP, 1,
     $                   TEMP, 1, DWORK( IR ), DWORK( II ), ILO,
     $                   DWORK( IWRK ), DWORK( IWRK+N ),
     $                   LDWORK-IWRK-N+1, IERR )
            IF( IERR.GT.0 ) THEN
               INFO = 2
               RETURN
            END IF
            MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK + N - 1, MAXWRK )
         END IF
C
C        Detect eigenvalues on the boundary of the stability domain,
C        if any. The test is based on a round-off level of eps*rho(H)
C        (after balancing) resulting in worst-case perturbations of
C        order sqrt(eps*rho(H)), for continuous-time systems, on the
C        real part of poles of multiplicity two (typical as GAMMA
C        approaches the infinity norm). Similarly, in the discrete-time
C        case. Above, rho(H) is the maximum modulus of eigenvalues
C        (continuous-time case).
C
C        Compute maximum eigenvalue modulus and check the absolute real
C        parts (if DICO = 'C'), or moduli (if DICO = 'D').
C
         WMAX = ZERO
C
         IF ( USEPEN ) THEN
C
C           Additional workspace: need   2*N, if DICO = 'D';   (from IM)
C                                        0,   if DICO = 'C'.
C
            DO 260 I = 0, N2 - 1
               TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) )
               IF ( ( DWORK( IBT+I ).GE.ONE ) .OR.
     $              ( DWORK( IBT+I ).LT.ONE  .AND.
     $               TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN
                  TM = TM / DWORK( IBT+I )
               ELSE
C
C                 The pencil has too large eigenvalues. SAFMAX is used.
C
                  TM = SAFMAX
               END IF
               WMAX = MAX( WMAX, TM )
               IF ( DISCR )
     $            DWORK( IM+I ) = TM
  260       CONTINUE
C
         ELSE
C
            DO 270 I = 0, N - 1
               TM   = DLAPY2( DWORK( IR+I ), DWORK( II+I ) )
               WMAX = MAX( WMAX, TM )
  270       CONTINUE
C
         END IF
C
         NEI = 0
C
         IF ( USEPEN ) THEN
C
            DO 280 I = 0, N2 - 1
               IF ( DISCR ) THEN
                  TM = ABS( ONE - DWORK( IM+I ) )
               ELSE
                  TM = ABS( DWORK( IR+I ) )
                  IF ( ( DWORK( IBT+I ).GE.ONE ) .OR.
     $                 ( DWORK( IBT+I ).LT.ONE  .AND.
     $                  TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN
                     TM = TM / DWORK( IBT+I )
                  ELSE
C
C                    The pencil has too large eigenvalues.
C                    SAFMAX is used.
C
                     TM = SAFMAX
                  END IF
               END IF
               IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN
                  DWORK( IR+NEI ) = DWORK( IR+I ) / DWORK( IBT+I )
                  DWORK( II+NEI ) = DWORK( II+I ) / DWORK( IBT+I )
                  NEI = NEI + 1
               END IF
  280       CONTINUE
C
         ELSE
C
            DO 290 I = 0, N - 1
               TM = ABS( DWORK( IR+I ) )
               IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN
                  DWORK( IR+NEI ) = DWORK( IR+I )
                  DWORK( II+NEI ) = DWORK( II+I )
                  NEI = NEI + 1
               END IF
  290       CONTINUE
C
         END IF
C
         IF( NEI.EQ.0 ) THEN
C
C           There is no eigenvalue on the boundary of the stability
C           domain for G = ( ONE + TOL )*GAMMAL. The norm was found.
C
            GPEAK( 1 ) = GAMMAL
            GPEAK( 2 ) = ONE
            GO TO 340
         END IF
C
C        Compute the frequencies where the gain G is attained and
C        generate new test frequencies.
C
         NWS = 0
C
         IF ( DISCR ) THEN
C
            DO 300 I = 0, NEI - 1
               TM = ATAN2( DWORK( II+I ), DWORK( IR+I ) )
               DWORK( IR+I ) = MAX( EPS, TM )
               NWS = NWS + 1
  300       CONTINUE
C
         ELSE
C
            J = 0
C
            DO 310 I = 0, NEI - 1
               IF ( DWORK( II+I ).GT.EPS ) THEN
                  DWORK( IR+NWS ) = DWORK( II+I )
                  NWS = NWS + 1
               ELSE IF ( DWORK( II+I ).EQ.EPS ) THEN
                  J = J + 1
                  IF ( J.EQ.1 ) THEN
                     DWORK( IR+NWS ) = EPS
                     NWS = NWS + 1
                  END IF
               END IF
  310       CONTINUE
C
         END IF
C
         CALL DLASRT( 'Increasing', NWS, DWORK( IR ), IERR )
         LW = 1
C
         DO 320 I = 0, NWS - 1
            IF ( DWORK( IR+LW-1 ).NE.DWORK( IR+I ) ) THEN
               DWORK( IR+LW ) = DWORK( IR+I )
               LW = LW + 1
            END IF
  320    CONTINUE
C
         IF ( LW.EQ.1 ) THEN
            IF ( ITER.EQ.1 .AND. NWS.GE.1 ) THEN
C
C              Duplicate the frequency trying to force iteration.
C
               DWORK( IR+1 ) = DWORK( IR )
               LW = LW + 1
            ELSE
C
C              The norm was found.
C
               GPEAK( 1 ) = GAMMAL
               GPEAK( 2 ) = ONE
               GO TO 340
            END IF
         END IF
C
C        Form the vector of mid-points and compute the gain at new test
C        frequencies. Save the current lower bound.
C
         IWRK   = IR + LW
         GAMMAS = GAMMAL
C
         DO 330 I = 0, LW - 2
            IF ( DISCR ) THEN
               OMEGA = ( DWORK( IR+I ) + DWORK( IR+I+1 ) ) / TWO
            ELSE
               OMEGA = SQRT( DWORK( IR+I )*DWORK( IR+I+1 ) )
            END IF
C
C           Additional workspace:  need   LDW2, see above;
C                                  prefer larger.
C
            GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA,
     $                      DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ),
     $                      N, DWORK( IC ), P, DWORK( ID ), P, IWORK,
     $                      DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK,
     $                      IERR )
            MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK )
            MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK )
            IF ( DISCR ) THEN
               TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) )
            ELSE
               TM = OMEGA
            END IF
            IF( IERR.GE.1 .AND. IERR.LE.N ) THEN
               GPEAK( 1 ) = ONE
               FPEAK( 1 ) = TM
               GPEAK( 2 ) = ZERO
               FPEAK( 2 ) = ONE
               GO TO 340
            ELSE IF( IERR.EQ.N+1 ) THEN
               INFO = 3
               RETURN
            END IF
C
            IF( GAMMAL.LT.GAMMA ) THEN
               GAMMAL     = GAMMA
               FPEAK( 1 ) = TM
               FPEAK( 2 ) = ONE
            END IF
  330    CONTINUE
C
C        If the lower bound has not been improved, return. (This is a
C        safeguard against undetected modes of Hamiltonian matrix on the
C        boundary of the stability domain.)
C
         IF ( GAMMAL.LT.GAMMAS*( ONE + TOL/TEN ) ) THEN
            GPEAK( 1 ) = GAMMAL
            GPEAK( 2 ) = ONE
            GO TO 340
         END IF
C
C     END WHILE
C
      IF ( ITER.LE.MAXIT ) THEN
         GO TO 120
      ELSE
         INFO = 4
         RETURN
      END IF
C
  340 CONTINUE
      DWORK( 1 ) = MAXWRK
      CWORK( 1 ) = MAXCWK
      RETURN
C *** Last line of AB13DD ***
      END


c=============================================================================c
      subroutine elliptic( nx, ny, x, ldx, y, ldy, eps, nmax )
c
c     This routine performs an elliptic smoothing of the input grid
c
c     Author:  Scott Collis
c
c     Date:    6-17-97
c
c=============================================================================c
      implicit none

      integer nx, ny, ldx, ldy, nmax
      real x(ldx,ny), y(ldy,ny), eps

      real zero, pt5, one, two
      parameter (zero=0.0, pt5=0.5, one=1.0, two=2.0)

      integer n, i, j
      real dxi, deta, xeta, yeta, xxi, yxi, a, b, c, xnew, ynew, err

      integer mx
      parameter (mx=1000)
      real w, rx(mx), ry(mx), ad(mx), bd(mx), cd(mx), xl(mx), yl(mx)
c=============================================================================c
      if (nx.gt.mx) then
         write(*,*) 'Increase mx in elliptic'
         stop
      end if

      dxi = one / float(nx-1)
      deta = one / float(ny-1)
c
c.... Gauss-Siedel
c
      if (.false.) then

      n = 0
 10   continue
         n = n + 1
         err = zero
         do i = 2, nx-1
            do j = 2, ny-1
               xeta = (x(i,j+1)-x(i,j-1)) / (two * deta)
               yeta = (y(i,j+1)-y(i,j-1)) / (two * deta)
               xxi  = (x(i+1,j)-x(i-1,j)) / (two * dxi)
               yxi  = (y(i+1,j)-y(i-1,j)) / (two * dxi)

               a = (xeta**2 + yeta**2) / dxi**2
               b = (xxi*xeta + yxi*yeta) / ( two * dxi * deta )
               c = (xxi**2 + yxi**2) / deta**2

               xnew = (a * (x(i+1,j) + x(i-1,j)) + c * (x(i,j+1) + x(i,j-1))
     &                - b * (x(i+1,j+1) - x(i+1,j-1) + x(i-1,j-1) -
     &                x(i-1,j+1)) ) / ( two * (a + c) )
               ynew = (a * (y(i+1,j) + y(i-1,j)) + c * (y(i,j+1) + y(i,j-1))
     &                - b * (y(i+1,j+1) - y(i+1,j-1) + y(i-1,j-1) -
     &                y(i-1,j+1)) ) / ( two * (a + c) )

               err = err + abs(x(i,j)-xnew) + abs(y(i,j)-ynew)

               x(i,j) = xnew
               y(i,j) = ynew
            end do
         end do
         err = err / real( (nx-2)*(ny-2) )
         write(*,"(i5,1x,1pe13.6)") n, err
      if ( err .gt. eps .and. n .lt. nmax) goto 10
c
c.... Line Gauss-Siedel with SOR (because of the nonlinearity, SOR is unstable
c.... for w > 1.
c
      else

      write(*,"(/,'Enter the SOR parmameter (0 < w < 2, w = 1.78) ==>',$)")
      read(*,*) w
      n = 0
 20   continue
         n = n + 1
         err = zero
         do j = 2, ny-1
            do i = 2, nx-1
               xeta = (x(i,j+1)-x(i,j-1)) / (two * deta)
               yeta = (y(i,j+1)-y(i,j-1)) / (two * deta)
               xxi  = (x(i+1,j)-x(i-1,j)) / (two * dxi)
               yxi  = (y(i+1,j)-y(i-1,j)) / (two * dxi)

               a = (xeta**2 + yeta**2) / dxi**2
               b = (xxi*xeta + yxi*yeta) / ( two * dxi * deta )
               c = (xxi**2 + yxi**2) / deta**2

               rx(i) = -two*(one-w)*(a + c) * x(i,j) + w*b*(x(i+1,j+1) -
     &                 x(i+1,j-1) + x(i-1,j-1) - x(i-1,j+1)) -
     &                 w*c*(x(i,j+1) + x(i,j-1))

               ry(i) = -two*(one-w)*(a + c) * y(i,j) + w*b*(y(i+1,j+1) -
     &                 y(i+1,j-1) + y(i-1,j-1) - y(i-1,j+1)) -
     &                 w*c*(y(i,j+1) + y(i,j-1))

               ad(i) = w * a
               bd(i) = -two * (a + c)
               cd(i) = w * a
            end do
c
c.... apply the boundary conditions
c
            rx(1)  = x(1,j)
            ry(1)  = y(1,j)
            rx(nx) = x(nx,j)
            ry(nx) = y(nx,j)

            ad(1) = zero
            bd(1) = one
            cd(1) = zero

            ad(nx) = zero
            bd(nx) = one
            cd(nx) = zero

            call tridag( ad, bd, cd, rx, xl, nx )
            call tridag( ad, bd, cd, ry, yl, nx )

            do i = 2, nx-1
               err = err + abs(x(i,j)-xl(i)) + abs(y(i,j)-yl(i))
               x(i,j) = xl(i)
               y(i,j) = yl(i)
            end do
         end do

         err = err / real( (nx-2)*(ny-2) )
         write(*,"(i5,1x,1pe13.6)") n, err
      if ( err .gt. eps .and. n .lt. nmax) goto 20

      end if

      return
      end

      SUBROUTINE TRIDAG(A,B,C,R,U,N)
      DIMENSION A(N),B(N),C(N),R(N),U(N)
      INTEGER NMAX
      PARAMETER (NMAX=1000)
      DIMENSION GAM(NMAX)
      IF(N.GT.NMAX)PAUSE
      IF(B(1).EQ.0.)PAUSE
      BET=B(1)
      U(1)=R(1)/BET
      DO 11 J=2,N
        GAM(J)=C(J-1)/BET
        BET=B(J)-A(J)*GAM(J)
        IF(BET.EQ.0.)PAUSE
        U(J)=(R(J)-A(J)*U(J-1))/BET
11    CONTINUE
      DO 12 J=N-1,1,-1
        U(J)=U(J)-GAM(J+1)*U(J+1)
12    CONTINUE
      RETURN
      END


! A Pythagorean triplet is a set of three natural numbers, a < b < c, for which,
!
!          a^2 + b^2 = c^2
!
! For example, 3^2 + 4^2 = 9 + 16 = 25 = 5^2.
! There exists exactly one Pythagorean triplet for which a + b + c = 1000.
! Find the product abc.
module Problem9

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 9. Special Pythagorean triplet.'

        write (*, '(A, I)') 'Product 1: ', product1()
    end subroutine

    pure function product1()
        integer, parameter:: limit = 1000
        integer product1
        integer a
        integer b
        integer c

        ! initial value
        product1 = 0

        do c = 1, limit
            do b = 1, c - 1
                do a = 1, b - 1
                    if (a + b + c == limit) then
                        if ((a**2) + (b**2) == (c**2)) then
                            product1 = a * b * c

                            return
                        end if
                    end if
                end do
            end do
        end do
    end function
end module


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file igradgc.f
c
c     this file includes documentation and code for
c     subroutine igradgc         i
c
c ... files which must be loaded with igradgc.f
c
c     sphcom.f, hrfft.f, shsgc.f,vhagc.f
c
c     subroutine igradgc(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,
c    +                   wshsgc,lshsgc,work,lwork,ierror)
c
c     let br,bi,cr,ci be the vector spherical harmonic coefficients
c     precomputed by vhagc for a vector field (v,w).  let (v',w') be
c     the irrotational component of (v,w) (i.e., (v',w') is generated
c     by assuming cr,ci are zero and synthesizing br,bi with vhsgs).
c     then subroutine igradgc computes a scalar field sf such that
c
c            gradient(sf) = (v',w').
c
c     i.e.,
c
C*PL*ERROR* Comment line too long
c            v'(i,j) = d(sf(i,j))/dtheta          (colatitudinal component of
c                                                 the gradient)
c     and
c
C*PL*ERROR* Comment line too long
c            w'(i,j) = 1/sint*d(sf(i,j))/dlambda  (east longitudinal component
c                                                 of the gradient)
c
c     at the gaussian colatitude theta(i) (see nlat as input parameter)
C*PL*ERROR* Comment line too long
c     and longitude lambda(j) = (j-1)*2*pi/nlon where sint = sin(theta(i)).
c
c     note:  for an irrotational vector field (v,w), subroutine igradgc
c     computes a scalar field whose gradient is (v,w).  in ay case,
c     subroutine igradgc "inverts" the gradient subroutine gradgc.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
C*PL*ERROR* Comment line too long
c            full sphere. these lie in the interval (0,pi) and are computed
C*PL*ERROR* Comment line too long
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
C*PL*ERROR* Comment line too long
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater than
c            3.  the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the scalar field sf is
c            computed on the full or half sphere as follows:
c
c      = 0
c
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in (v,w) about the equator.  in this case sf
c            is neither symmetric nor antisymmetric about the equator.
c            sf is computed on the entire sphere.  i.e., in the array
c            sf(i,j) for i=1,...,nlat and  j=1,...,nlon
c
c      = 1
c
c            w is antisymmetric and v is symmetric about the equator.
c            in this case sf is antisymmetyric about the equator and
c            is computed for the northern hemisphere only.  i.e.,
c            if nlat is odd sf is computed in the array sf(i,j) for
c            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
c            sf is computed in the array sf(i,j) for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c      = 2
c
c            w is symmetric and v is antisymmetric about the equator.
c            in this case sf is symmetyric about the equator and
c            is computed for the northern hemisphere only.  i.e.,
c            if nlat is odd sf is computed in the array sf(i,j) for
c            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
c            sf is computed in the array sf(i,j) for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c
c     nt     nt is the number of scalar and vector fields.  some
c            computational efficiency is obtained for multiple fields.
C*PL*ERROR* Comment line too long
c            the arrays br,bi, and sf can be three dimensional corresponding
c            to an indexed multiple vector field (v,w).  in this case,
c            multiple scalar synthesis will be performed to compute each
C*PL*ERROR* Comment line too long
c            scalar field.  the third index for br,bi, and sf is the synthesis
c            index which assumes the values k = 1,...,nt.  for a single
c            synthesis set nt = 1.  the description of the remaining
C*PL*ERROR* Comment line too long
c            parameters is simplified by assuming that nt=1 or that br,bi,
c            and sf are two dimensional arrays.
c
c     isf    the first dimension of the array sf as it appears in
c            the program that calls igradgc. if isym = 0 then isf
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then isf must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then isf must be at least (nlat+1)/2.
c
c     jsf    the second dimension of the array sf as it appears in
c            the program that calls igradgc. jsf must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c            that contain vector spherical harmonic coefficients
c            of the vector field (v,w) as computed by subroutine vhagc.
c     ***    br,bi must be computed by vhagc prior to calling igradgc.
c
C*PL*ERROR* Comment line too long
c     mdb    the first dimension of the arrays br and bi as it appears in
c            the program that calls igradgc (and vhagc). mdb must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
C*PL*ERROR* Comment line too long
c     ndb    the second dimension of the arrays br and bi as it appears in
c            the program that calls igradgc (and vhagc). ndb must be at
c            least nlat.
c
c
c  wshsgc    an array which must be initialized by subroutine shsgci.
c            once initialized,
c            wshsgc can be used repeatedly by igradgc as long as nlon
c            and nlat remain unchanged.  wshsgc must not be altered
c            between calls of igradgc.
c
c
c  lshsgc    the dimension of the array wshsgc as it appears in the
c            program that calls igradgc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd.
c
c
c            then lshsgc must be at least
c
c               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls igradgc  define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd

c            if isym is zero then lwork must be at least
c
c               nlat*(nlon*nt+max0(3*l2,nlon)+2*nt*l1+1)
c
c            if isym is not zero then lwork must be at least
c
c               l2*(nlon*nt+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1)
c
c
c
c     **************************************************************
c
c     output parameters
c
c
C*PL*ERROR* Comment line too long
c     sf    a two or three dimensional array (see input parameter nt) that
c           contain a scalar field whose gradient is the irrotational
c           component of the vector field (v,w).  the vector spherical
c           harmonic coefficients br,bi were precomputed by subroutine
c           vhagc.  sf(i,j) is given at the gaussian colatitude theta(i)
c           and longitude lambda(j) = (j-1)*2*pi/nlon.  the index ranges
c           are defined at input parameter isym.
c
c
c  ierror   = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of isf
c           = 6  error in the specification of jsf
c           = 7  error in the specification of mdb
c           = 8  error in the specification of ndb
c           = 9  error in the specification of lshsgc
c           = 10 error in the specification of lwork
c
c **********************************************************************
c
      SUBROUTINE DIGRADGC(NLAT,NLON,ISYM,NT,SF,ISF,JSF,BR,BI,MDB,NDB,
     +                   WSHSGC,LSHSGC,WORK,LWORK,IERROR)
      DOUBLE PRECISION SF
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION WSHSGC
      DOUBLE PRECISION WORK
      DIMENSION SF(ISF,JSF,NT)
      DIMENSION BR(MDB,NDB,NT),BI(MDB,NDB,NT)
      DIMENSION WSHSGC(LSHSGC),WORK(LWORK)
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.ISF.LT.NLAT) .OR.
     +    (ISYM.NE.0.AND.ISF.LT.IMID)) RETURN
      IERROR = 6
      IF (JSF.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+2)/2)
      IF (MDB.LT.MIN0(NLAT, (NLON+1)/2)) RETURN
      IERROR = 8
      IF (NDB.LT.NLAT) RETURN
      IERROR = 9
c
c     verify saved work space length
c
      L2 = (NLAT+MOD(NLAT,2))/2
      L1 = MIN0((NLON+2)/2,NLAT)
      IF (LSHSGC.LT.NLAT* (2*L2+3*L1-2)+3*L1* (1-L1)/2+NLON+15) RETURN
      IERROR = 10
c
c     set minimum and verify unsaved work space
c
      LS = NLAT
      IF (ISYM.GT.0) LS = IMID
      NLN = NT*LS*NLON
c
c     set first dimension for a,b (as requried by shsgc)
c
      MAB = MIN0(NLAT,NLON/2+1)
      MN = MAB*NLAT*NT
c     lwkmin = nln+ls*nlon+2*mn+nlat
      IF (ISYM.EQ.0) THEN
          LWKMIN = NLAT* (NT*NLON+MAX0(3*L2,NLON)+2*NT*L1+1)
      ELSE
          LWKMIN = L2* (NT*NLON+MAX0(3*NLAT,NLON)) + NLAT* (2*NT*L1+1)
      END IF
      IF (LWORK.LT.LWKMIN) RETURN
      IERROR = 0
c
c     set work space pointers
c
      IA = 1
      IB = IA + MN
      IS = IB + MN
      IWK = IS + NLAT
      LIWK = LWORK - 2*MN - NLAT
      CALL DIGRDGC1(NLAT,NLON,ISYM,NT,SF,ISF,JSF,WORK(IA),WORK(IB),MAB,
     +             WORK(IS),MDB,NDB,BR,BI,WSHSGC,LSHSGC,WORK(IWK),LIWK,
     +             IERROR)
      RETURN
      END

      SUBROUTINE DIGRDGC1(NLAT,NLON,ISYM,NT,SF,ISF,JSF,A,B,MAB,SQNN,MDB,
     +                   NDB,BR,BI,WSAV,LSAV,WK,LWK,IERROR)
      DOUBLE PRECISION SF
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION SQNN
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION WSAV
      DOUBLE PRECISION WK
      DOUBLE PRECISION FN
      DIMENSION SF(ISF,JSF,NT)
      DIMENSION BR(MDB,NDB,NT),BI(MDB,NDB,NT),SQNN(NLAT)
      DIMENSION A(MAB,NLAT,NT),B(MAB,NLAT,NT)
      DIMENSION WSAV(LSAV),WK(LWK)
c
c     preset coefficient multiplyers in vector
c
      DO 1 N = 2,NLAT
          FN = DBLE(N-1)
          SQNN(N) = 1.0D0/SQRT(FN* (FN+1.D0))
    1 CONTINUE
c
c     set upper limit for vector m subscript
c
      MMAX = MIN0(NLAT, (NLON+1)/2)
c
c     compute multiple scalar field coefficients
c
      DO 2 K = 1,NT
c
c     preset to 0.0
c
          DO 3 N = 1,NLAT
              DO 4 M = 1,MAB
                  A(M,N,K) = 0.0D0
                  B(M,N,K) = 0.0D0
    4         CONTINUE
    3     CONTINUE
c
c     compute m=0 coefficients
c
          DO 5 N = 2,NLAT
              A(1,N,K) = BR(1,N,K)*SQNN(N)
              B(1,N,K) = BI(1,N,K)*SQNN(N)
    5     CONTINUE
c
c     compute m>0 coefficients
c
          DO 6 M = 2,MMAX
              DO 7 N = M,NLAT
                  A(M,N,K) = SQNN(N)*BR(M,N,K)
                  B(M,N,K) = SQNN(N)*BI(M,N,K)
    7         CONTINUE
    6     CONTINUE
    2 CONTINUE
c
c     scalar sythesize a,b into sf
c
      CALL DSHSGC(NLAT,NLON,ISYM,NT,SF,ISF,JSF,A,B,MAB,NLAT,WSAV,LSAV,
     +            WK,LWK,IERROR)
      RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine set_ddeps_dkz
  use global_variables
  implicit none
  integer :: ikr,ikz

  select case(nband_type)
  case(N_PARABOLIC_BAND)
!$omp parallel do private(ikz, ikr)
    do ikz = -NKz,NKz
      do ikr = 1,NKr
        ddeps_dkz(ikr,ikz) = kz(ikz)/mass_r
      end do
    end do
  case(N_NONPARABOLIC_BAND)
!$omp parallel do private(ikz, ikr)
    do ikz = -NKz,NKz
      do ikr = 1,NKr
        ddeps_dkz(ikr,ikz)=kz(ikz)/mass_r/sqrt(1d0+(kr(ikr)**2+kz(ikz)**2)/(mass_r*eps_g))
      end do
    end do
  case default
    write(*,"(A,2x,A)")"Invalid nband_type",nband_type
    stop
  end select

end subroutine set_ddeps_dkz