MODULE TENSION_MOD

! The Tension Spline Module is use to fit a tension spline curve
! to a water column profile of water properties at the particle location.
! This module uses a modified version of Tension Spline Curve Fitting
! Package (TSPACK). TSPACK (TOMS/716) was created by Robert J. Renka
! (renka@cs.unt.edu, Department of Computer Science and Engineering,
! University of North Texas). TSPACK is copyrighted by the Association
! for Computing Machinery (ACM). With the permission of Dr. Renka and ACM,
! TSPACK was modified by Zachary Schlag for use in LTRANS by removing
! unused code and call variables and updating it to Fortran 90. If you
! would like to use LTRANS with the modified TSPACK software, please read
! and respect the ACM Software Copyright and License Agreement found at:
! http://www.acm.org/publications/policies/softwarecrnotice.

  IMPLICIT NONE
  PUBLIC
  SAVE

CONTAINS

! **************************************************************
! *                          TSPACK                            *
! **************************************************************
!
!  Created by:       Robert J. Renka
!  Date created on:  05/27/91
!  Modified by:      Zachary Schlag
!  Date modified on: 09/03/08
!  Copyright:        Association for Computing Machinery

!         TSPACK:  Tension Spline Curve Fitting Package
!
!                              Robert J. Renka
!                                  05/27/91
!
!        I.  INTRODUCTION
!
!             The primary purpose of TSPACK is to construct a smooth
!        function which interpolates a discrete set of data points.
!        The function may be required to have either one or two con-
!        tinuous derivatives, and, in the C-2 case, several options
!        are provided for selecting end conditions.  If the accuracy
!        of the data does not warrant interpolation, a smoothing func-
!        tion (which does not pass through the data points) may be
!        constructed instead.  The fitting method is designed to avoid
!        extraneous inflection points (associated with rapidly varying
!        data values) and preserve local shape properties of the data
!        (monotonicity and convexity), or to satisfy the more general
!        constraints of bounds on function values or first derivatives.
!        The package also provides a parametric representation for con-
!        structing general planar curves and space curves.
!
!             The fitting function h(x) (or each component h(t) in the
!        case of a parametric curve) is defined locally, on each
!        interval associated with a pair of adjacent abscissae (knots),
!        by its values and first derivatives at the endpoints of the
!        interval, along with a nonnegative tension factor SIGMA
!        associated with the interval (h is a Hermite interpolatory
!        tension spline).  With SIGMA = 0, h is the cubic function
!        defined by the endpoint values and derivatives, and, as SIGMA
!        increases, h approaches the linear interpolant of the endpoint
!        values.  Since the linear interpolant preserves positivity,
!        monotonicity, and convexity of the data, h can be forced to
!        preserve these properties by choosing SIGMA sufficiently
!        large.  Also, since SIGMA varies with intervals, no more
!        tension than necessary is used in each interval, resulting in
!        a better fit and greater efficiency than is achieved with a
!        single constant tension factor.
!
!
!        II.  USAGE
!
!
!             TSPACK must be linked to a driver program which re-
!        serves storage, reads a data set, and calls the appropriate
!        procedures selected from those described below in section
!        III.B.  Header comments in the software prodecures provide
!        details regarding the specification of input parameters and
!        the work space requirements.  It is recommended that curves
!        be plotted in order to assess their appropriateness for the
!        application.  This requires a user-supplied graphics package.
!
!
!        III.  SOFTWARE
!
!        A)  Code
!
!             The code was originally written in 1977 ANSI Standard
!        Fortran.  Variable and array names conform to the following
!        default typing convention:  I-N for type INTEGER and A-H or
!        O-Z for type REAL.  There are no conventions used for LOGICAL
!        or DOUBLE PRECISION variables.  There are many procedures.
!        Each consists of the following sections:
!
!            1)  the procedure name and parameter list with spaces sepa-
!                rating the parameters into one to three subsets:
!                input parameters, I/O parameters, and output parame-
!                ters (in that order);
!            2)  type statements in which all parameters are typed
!                and arrays are dimensioned;
!            3)  a heading with the name of the package, identifica-
!                tion of the author, and date of the author's most
!                recent modification to the procedure;
!            4)  a description of the procedure's purpose and other rel-
!                evant information for the user;
!            5)  input parameter descriptions and output parameter
!                descriptions in the same order as the parameter
!                list;
!            6)  a list of other procedures required (called either
!                directly or indirectly);
!            7)  a list of intrinsic functions called, if any; and
!            8)  the code, including comments.
!
!             Note that it is assumed that floating point underflow
!        results in assignment of the value zero.  If not the default,
!        this may be specified as either a compiler option or an
!        operating system option.  Also, overflow is avoided by re-
!        stricting arguments to the exponential function EXP to have
!        value at most SBIG=85.  SBIG, which appears in DATA statements
!        in the evaluation functions, HVAL, and HPVAL, must be decreased
!        if it is necessary to accomodate a floating point number system
!        with fewer than 8 bits in the exponent. No other system
!        dependencies are present in the code.
!
!            The procedure that solves nonlinear equations, SIGS,
!        includes diagnostic print capability which allows the iteration
!        to be traced.  This can be enabled by altering logical unit
!        number LUN in a DATA statement in the relevant procedure.
!
!        B)  Procedure Descriptions
!
!             The software procedures are divided into three categories,
!        referred to as level 1, level 2, and level 3, corresponding to
!        the hierarchy of calling sequences:  level 1 procedures call
!        level 2 procedures which call level 3 procedures.  For most
!        applications, the driver need only call two level 1 prodedures
!        -- one from each of groups (a) and (b).  However, additional
!        control over various options can be obtained by directly
!        calling level 2 procedures.  Also, additional fitting methods,
!        such as parametric smoothing, can be obtained by calling
!        level 2 procedures.  Note that, in the case of smoothing or C-2
!        interpolation with automatically selected tension, the use
!        of level 2 procedures requires that an iteration be placed
!        around the computation of knot derivatives and tension factors.
!
!        1) Level 1 procedures
!
!         a) The following procedure returns knots (in the parametric
!            case), knot derivatives, tension factors, and, in the
!            case of smoothing, knot function values, which define
!            the fitting function (or functions in the parametric
!            case).
!
!          TSPSI   Subroutine which constructs a shape-preserving or
!                    unconstrained interpolatory function.
!
!        2) Level 2 procedures
!
!             These are divided into three groups.
!
!         a) The following procedures are called by the level 1, group (a)
!            procedures to obtain knot derivatives (and values in the case
!            of SMCRV).
!
!          YPC1    Subroutine which employs a monotonicity-constrained
!                    quadratic interpolation method to compute locally
!                    defined derivative estimates, resulting in a C-1
!                    fit.
!
!         b) The following procedures are called by the level 1, group (a)
!            procedures to obtain tension factors associated with knot
!            intervals.
!
!          SIGS    Subroutine which, given a sequence of abscissae,
!                    function values, and first derivative values,
!                    determines the set of minimum tension factors for
!                    which the Hermite interpolatory tension spline
!                    preserves local shape properties (monotonicity
!                    and convexity) of the data.  SIGS is called by
!                    TSPSI.
!
!         c) The following functions are called by the level 1, group
!            (b) procedures to obtain values and derivatives.  These pro-
!            vide a more convenient alternative to the level 1 routines
!            when a single value is needed.
!
!          HVAL    Function which evaluates a Hermite interpolatory ten-
!                     sion spline at a specified point.
!
!          HPVAL   Function which evaluates the first derivative of a
!                    Hermite interpolatory tension spline at a specified
!                    point.
!
!
!       3) Level 3 procedures
!
!        a)  The following procedures are of general utility.
!
!
!          INTRVL  Function which, given an increasing sequence of ab-
!                    scissae, returns the index of an interval containing
!                    a specified point.  INTRVL is called by the evalua-
!                    tion functions HVAL, and HPVAL.
!
!          SNHCSH  Subroutine called by several procedures to compute
!                    accurate approximations to the modified hyperbolic
!                    functions which form a basis for exponential ten-
!                    sion splines.
!
!          STORE   Function used by SIGS in computing the machine precision.
!                    STORE forces a value to be stored in main memory so
!                    that the precision of floating point numbers in memory
!                    locations rather than registers is computed.
!
!
!        IV.  REFERENCE
!
!
!        For the theoretical background, consult the following:
!
!          RENKA, R. J.  Interpolatory tension splines with automatic
!          selection of tension factors. SIAM J. Sci. Stat. Comput. 8
!          (1987), pp. 393-415.
!

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~~~~~~~~~~~~~~~  TSPACK  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SUBROUTINE TSPSI (N,X,Y, YP, SIGMA,IER,SigErr)
    INTEGER N, IER, SigErr
    DOUBLE PRECISION X(N), Y(N), YP(N), SIGMA(N)
!***********************************************************
!                                                From TSPACK
!                                            Robert J. Renka
!                                  Dept. of Computer Science
!                                       Univ. of North Texas
!                                           renka@cs.unt.edu
!                                                   07/08/92
!   This subroutine computes a set of parameter values which
! define a Hermite interpolatory tension spline H(x).  The
! parameters consist of knot derivative values YP computed
! by Subroutine YPC1, and tension factors SIGMA computed by
! Subroutine SIGS.  Alternative methods for computing SIGMA
! are provided by Subroutine TSPBI and Functions SIG0, SIG1,
! and SIG2.
!   Refer to Subroutine TSPSS for a means of computing
! parameters which define a smoothing curve rather than an
! interpolatory curve.
!   The tension spline may be evaluated by Subroutine TSVAL1
! or Functions HVAL (values), HPVAL (first derivatives),
! HPPVAL (second derivatives), and TSINTL (integrals).
! On input:
!       N = Number of data points.  N .GE. 2 and N .GE. 3 if
!           PER = TRUE.
!       X = Array of length N containing a strictly in-
!           creasing sequence of abscissae:  X(I) < X(I+1)
!           for I = 1,...,N-1.
!       Y = Array of length N containing data values asso-
!           ciated with the abscissae.  H(X(I)) = Y(I) for
!           I = 1,...,N.
!       YP = Array of length N containing first derivatives
!           of H at the abscissae.  Refer to Subroutine YPC1
! On output:
!       YP = Array containing derivatives of H at the
!            abscissae.  YP is not altered if -4 < IER < 0,
!            and YP is only partially defined if IER = -4.
!       SIGMA = Array containing tension factors.  SIGMA(I)
!               is associated with interval (X(I),X(I+1))
!               for I = 1,...,N-1.  SIGMA is not altered if
!               -4 < IER < 0 (unless IENDC is invalid), and
!               SIGMA is constant (not optimal) if IER = -4
!               or IENDC (if used) is invalid.
!       IER = Error indicator or iteration count:
!             IER = IC .GE. 0 if no errors were encountered
!                      and IC calls to SIGS and IC+1 calls
!                      to YPC1, YPC1P, YPC2 or YPC2P were
!                      employed.  (IC = 0 if NCD = 1).
!             IER = -1 if N, NCD, or IENDC is outside its
!                      valid range.
!             IER = -2 if LWK is too small.
!             IER = -3 if UNIFRM = TRUE and SIGMA(1) is out-
!                      side its valid range.
!             IER = -4 if the abscissae X are not strictly
!                      increasing.
! Procedures required by TSPSI:  SIGS, STORE, YPC1
! Intrinsic functions called by TSPSI:  ABS, MAX
!***********************************************************
!
    INTEGER IERR

    IER = 0

    IF (N .LT. 2) THEN
      ! Invalid input parameter N
      IER = -1
    ELSE

      CALL YPC1 (N,X,Y,YP,IERR)

      IF (IERR .NE. 0) THEN
        !Abscissae are not strictly increasing.
        IER = -4
      ELSE
        CALL SIGS (N,X,Y,YP,SIGMA,IERR,SigErr)
      ENDIF

    ENDIF

  END SUBROUTINE

  SUBROUTINE SIGS (N,X,Y,YP, SIGMA,IER,SigErr)
    INTEGER N, IER,SigErr
    DOUBLE PRECISION X(N), Y(N), YP(N),SIGMA(N)
!***********************************************************
!                                                From TSPACK
!                                            Robert J. Renka
!                                  Dept. of Computer Science
!                                       Univ. of North Texas
!                                           renka@cs.unt.edu
!                                                   11/17/96
!   Given a set of abscissae X with associated data values Y
! and derivatives YP, this subroutine determines the small-
! est (nonnegative) tension factors SIGMA such that the Her-
! mite interpolatory tension spline H(x) preserves local
! shape properties of the data.  In an interval (X1,X2) with
! data values Y1,Y2 and derivatives YP1,YP2, the properties
! of the data are
!       Monotonicity:  S, YP1, and YP2 are nonnegative or
!                        nonpositive,
!  and
!       Convexity:     YP1 .LE. S .LE. YP2  or  YP1 .GE. S
!                        .GE. YP2,
! where S = (Y2-Y1)/(X2-X1).  The corresponding properties
! of H are constant sign of the first and second deriva-
! tives, respectively.  Note that, unless YP1 = S = YP2, in-
! finite tension is required (and H is linear on the inter-
! val) if S = 0 in the case of monotonicity, or if YP1 = S
! or YP2 = S in the case of convexity.
!   SIGS may be used in conjunction with Subroutine YPC2
! (or YPC2P) in order to produce a C-2 interpolant which
! preserves the shape properties of the data.  This is
! achieved by calling YPC2 with SIGMA initialized to the
! zero vector, and then alternating calls to SIGS with
! calls to YPC2 until the change in SIGMA is small (refer to
! the parameter descriptions for SIGMA, DSMAX and IER), or
! the maximum relative change in YP is bounded by a toler-
! ance (a reasonable value is .01).  A similar procedure may
! be used to produce a C-2 shape-preserving smoothing curve
! (Subroutine SMCRV).
!   Refer to Subroutine SIGBI for a means of selecting mini-
! mum tension factors to satisfy more general constraints.
! On input:
!       N = Number of data points.  N .GE. 2.
!       X = Array of length N containing a strictly in-
!           creasing sequence of abscissae:  X(I) < X(I+1)
!           for I = 1,...,N-1.
!       Y = Array of length N containing data values (or
!           function values computed by SMCRV) associated
!           with the abscissae.  H(X(I)) = Y(I) for I =
!           1,...,N.
!       YP = Array of length N containing first derivatives
!            of H at the abscissae.  Refer to Subroutines
!            YPC1, YPC1P, YPC2, YPC2P, and SMCRV.
! The above parameters are not altered by this routine.
! On output:
!       SIGMA = Array containing tension factors for which
!               H(x) preserves the properties of the data,
!               with the restriction that SIGMA(I) .LE. 85
!               for all I (unless the input value is larger).
!               The factors are as small as possible (within
!               the tolerance), but not less than their
!               input values.  If infinite tension is re-
!               quired in interval (X(I),X(I+1)), then
!               SIGMA(I) = 85 (and H is an approximation to
!               the linear interpolant on the interval),
!               and if neither property is satisfied by the
!               data, then SIGMA(I) = 0 (unless the input
!               value is positive), and thus H is cubic in
!               the interval.
!       IER = Error indicator and information flag:
!             IER = I if no errors were encountered and I
!                     components of SIGMA were altered from
!                     their input values for 0 .LE. I .LE.
!                     N-1.
!             IER = -1 if N < 2.  SIGMA is not altered in
!                      this case.
!             IER = -I if X(I) .LE. X(I-1) for some I in the
!                      range 2,...,N.  SIGMA(J-1) is unal-
!                      tered for J = I,...,N in this case.
! Procedures required by SIGS:  SNHCSH, STORE
! Intrinsic functions called by SIGS:  ABS, EXP, MAX, MIN,
!                                        SIGN, SQRT
!
!***********************************************************
!
    INTEGER I, ICNT, IP1, LUN, NIT, NM1
    DOUBLE PRECISION A, C1, C2, COSHM, COSHMM, D0, D1,     &
                     D1D2, D1PD2, D2, DMAX, DSIG, DSM, DX, &
                     E, EMS, EMS2, F, F0, FMAX, FNEG, FP,  &
                     FTOL, RTOL, S, S1, S2, SBIG, SCM,     &
                     SGN, SIG, SIGIN, SINHM, SSINH, SSM,   &
                     STOL, T, T0, T1, T2, TM, TP1
    !DOUBLE PRECISION STORE
    DOUBLE PRECISION TOL, DSMAX     !Added by Zachary Schlag
    LOGICAL CONT,FLAG               !Added by Zachary Schlag

! Initialize flag to .FALSE.

    FLAG = .FALSE.

    DATA SBIG/85.D0/,  LUN/-1/
    NM1 = N - 1
    IF (NM1 .LT. 1) THEN
      ! N < 2.
      DSMAX = 0.D0
      IER = -1
    ELSE

! Initialize the tolerance and sigma values

      TOL = 0.D0
      DO I = 1,NM1
        SIGMA(I) = 0.D0
      ENDDO

! Compute an absolute tolerance FTOL = abs(TOL) and a
!   relative tolerance RTOL = 100*MACHEPS.

      FTOL = ABS(TOL)
      RTOL = 1.D0
      DO
        RTOL = RTOL/2.D0
        IF (STORE(RTOL+1.D0) .LE. 1.D0) EXIT
      ENDDO
      RTOL = RTOL*200.D0

! Initialize change counter ICNT and maximum change DSM for
!   loop on intervals.

      ICNT = 0
      DSM = 0.D0
      DO I = 1,NM1
        IF (LUN .GE. 0) WRITE (LUN,100) I
        100 FORMAT (//1X,'SIGS -- INTERVAL',I4)
        IP1 = I + 1
        DX = X(IP1) - X(I)
        IF (DX .LE. 0.D0) THEN
          ! X(I+1) .LE. X(I).
          DSMAX = DSM
          IER = -IP1
          EXIT
        ENDIF
        SIGIN = SIGMA(I)
        IF (SIGIN .GE. SBIG) CYCLE

! Compute first and second differences.

        S1 = YP(I)
        S2 = YP(IP1)
        S = (Y(IP1)-Y(I))/DX
        D1 = S - S1
        D2 = S2 - S
        D1D2 = D1*D2

! Test for infinite tension required to satisfy either
!   property.

        SIG = SBIG
        IF ((D1D2 .EQ. 0.D0  .AND.  S1 .NE. S2)  .OR.      &
           (S .EQ. 0.D0  .AND.  S1*S2 .GT. 0.D0)) THEN
          SIG = MIN(SIG,SBIG)
          IF (SIG .GT. SIGIN) THEN
            SIGMA(I) = SIG
            ICNT = ICNT + 1
            DSIG = SIG-SIGIN
            IF (SIGIN .GT. 0.D0) DSIG = DSIG/SIGIN
            DSM = MAX(DSM,DSIG)
          ENDIF
          CYCLE
        ENDIF

! Test for SIGMA = 0 sufficient.  The data satisfies convex-
!   ity iff D1D2 .GE. 0, and D1D2 = 0 implies S1 = S = S2.

        SIG = 0.D0
        IF (D1D2 .GE. 0.D0) THEN

          IF (D1D2 .EQ. 0.D0) THEN
            SIG = MIN(SIG,SBIG)
            IF (SIG .GT. SIGIN) THEN
              SIGMA(I) = SIG
              ICNT = ICNT + 1
              DSIG = SIG-SIGIN
              IF (SIGIN .GT. 0.D0) DSIG = DSIG/SIGIN
              DSM = MAX(DSM,DSIG)
            ENDIF
            CYCLE
          ENDIF

          T = MAX(D1/D2,D2/D1)

          IF (T .LE. 2.D0) THEN
            SIG = MIN(SIG,SBIG)
            IF (SIG .GT. SIGIN) THEN
              SIGMA(I) = SIG
              ICNT = ICNT + 1
              DSIG = SIG-SIGIN
              IF (SIGIN .GT. 0.D0) DSIG = DSIG/SIGIN
              DSM = MAX(DSM,DSIG)
            ENDIF
            CYCLE
          ENDIF

          TP1 = T + 1.D0

! Convexity:  Find a zero of F(SIG) = SIG*COSHM(SIG)/
!   SINHM(SIG) - TP1.
!
!   F(0) = 2-T < 0, F(TP1) .GE. 0, the derivative of F
!     vanishes at SIG = 0, and the second derivative of F is
!     .2 at SIG = 0.  A quadratic approximation is used to
!     obtain a starting point for the Newton method.

          SIG = SQRT(10.D0*T-20.D0)
          NIT = 0

!   Top of loop:

          DO
            IF (SIG .LE. .5D0) THEN
              CALL SNHCSH (SIG, SINHM,COSHM,COSHMM)
              T1 = COSHM/SINHM
              FP = T1 + SIG*(SIG/SINHM - T1*T1 + 1.D0)
            ELSE

!   Scale SINHM and COSHM by 2*EXP(-SIG) in order to avoid
!     overflow with large SIG.

              EMS = EXP(-SIG)
              SSM = 1.D0 - EMS*(EMS+SIG+SIG)
              T1 = (1.D0-EMS)*(1.D0-EMS)/SSM
              FP = T1 + SIG*(2.D0*SIG*EMS/SSM - T1*T1 + 1.D0)
            ENDIF

            F = SIG*T1 - TP1
            IF (LUN .GE. 0) WRITE (LUN,110) SIG, F, FP
            110 FORMAT (5X,'CONVEXITY -- SIG = ',D15.8,    &
              ', F(SIG) = ',D15.8/1X,35X,'FP(SIG) = ',     &
              D15.8)
            NIT = NIT + 1
            !WRITE (*,*) NIT
          IF (NIT.GT.10000) THEN
            SigErr=SigErr+1
            RETURN
          END IF

!   Test for convergence.

            FLAG = .FALSE.
            IF (FP .LE. 0.D0) THEN
              FLAG = .TRUE.
              EXIT
            ENDIF
            DSIG = -F/FP
            IF (ABS(DSIG) .LE. RTOL*SIG .OR. (F .GE. 0.D0  &
                .AND. F .LE. FTOL) .OR. ABS(F) .LE. RTOL)  &
            THEN
              FLAG = .TRUE.
              EXIT
            ENDIF

!   Update SIG.

            SIG = SIG + DSIG
          ENDDO
        ENDIF

        IF(FLAG)THEN
          FLAG = .FALSE.
          SIG = MIN(SIG,SBIG)
          IF (SIG .GT. SIGIN) THEN
            SIGMA(I) = SIG
            ICNT = ICNT + 1
            DSIG = SIG-SIGIN
            IF (SIGIN .GT. 0.D0) DSIG = DSIG/SIGIN
            DSM = MAX(DSM,DSIG)
          ENDIF
          CYCLE
        ENDIF

! Convexity cannot be satisfied.  Monotonicity can be satis-
!   fied iff S1*S .GE. 0 and S2*S .GE. 0 since S .NE. 0.

        IF (S1*S .LT. 0.D0  .OR.  S2*S .LT. 0.D0) THEN
          SIG = MIN(SIG,SBIG)
          IF (SIG .GT. SIGIN) THEN
            SIGMA(I) = SIG
            ICNT = ICNT + 1
            DSIG = SIG-SIGIN
            IF (SIGIN .GT. 0.D0) DSIG = DSIG/SIGIN
            DSM = MAX(DSM,DSIG)
          ENDIF
          CYCLE
        ENDIF
        T0 = 3.D0*S - S1 - S2
        D0 = T0*T0 - S1*S2

! SIGMA = 0 is sufficient for monotonicity iff S*T0 .GE. 0
!   or D0 .LE. 0.

        IF (D0 .LE. 0.D0  .OR.  S*T0 .GE. 0.D0) THEN
          SIG = MIN(SIG,SBIG)
          IF (SIG .GT. SIGIN) THEN
            SIGMA(I) = SIG
            ICNT = ICNT + 1
            DSIG = SIG-SIGIN
            IF (SIGIN .GT. 0.D0) DSIG = DSIG/SIGIN
            DSM = MAX(DSM,DSIG)
          ENDIF
          CYCLE
        ENDIF

! Monotonicity:  find a zero of F(SIG) = SIGN(S)*HP(R),
!   where HPP(R) = 0 and HP, HPP denote derivatives of H.
!   F has a unique zero, F(0) < 0, and F approaches abs(S)
!   as SIG increases.
!
!   Initialize parameters for the secant method.  The method
!     uses three points:  (SG0,F0), (SIG,F), and
!     (SNEG,FNEG), where SG0 and SNEG are defined implicitly
!     by DSIG = SIG - SG0 and DMAX = SIG - SNEG.

        SGN = SIGN(1.D0,S)
        SIG = SBIG
        FMAX = SGN*(SIG*S-S1-S2)/(SIG-2.D0)
        IF (FMAX .LE. 0.D0) THEN
          SIG = MIN(SIG,SBIG)
          IF (SIG .GT. SIGIN) THEN
            SIGMA(I) = SIG
            ICNT = ICNT + 1
            DSIG = SIG-SIGIN
            IF (SIGIN .GT. 0.D0) DSIG = DSIG/SIGIN
            DSM = MAX(DSM,DSIG)
          ENDIF
          CYCLE
        ENDIF
        STOL = RTOL*SIG
        F = FMAX
        F0 = SGN*D0/(3.D0*(D1-D2))
        FNEG = F0
        DSIG = SIG
        DMAX = SIG
        D1PD2 = D1 + D2
        NIT = 0

!   Top of loop:  compute the change in SIG by linear
!     interpolation.

        DO
          DSIG = -F*DSIG/(F-F0)
          IF (LUN .GE. 0) WRITE (LUN,120) DSIG
          120 FORMAT (5X,'MONOTONICITY -- DSIG = ',D15.8)
          IF ( ABS(DSIG) .GT. ABS(DMAX)  .OR.              &
               DSIG*DMAX .GT. 0. ) THEN
            DSIG = DMAX
            F0 = FNEG
            CYCLE
          ENDIF

!   Restrict the step-size such that abs(DSIG) .GE. STOL/2.
!     Note that DSIG and DMAX have opposite signs.

          IF (ABS(DSIG) .LT. STOL/2.D0)                    &
            DSIG = -SIGN(STOL/2.D0,DMAX)

!   Update SIG, F0, and F.

          SIG = SIG + DSIG
          F0 = F
          IF (SIG .LE. .5D0) THEN

!   Use approximations to the hyperbolic functions designed
!     to avoid cancellation error with small SIG.

            CALL SNHCSH (SIG, SINHM,COSHM,COSHMM)
            C1 = SIG*COSHM*D2 - SINHM*D1PD2
            C2 = SIG*(SINHM+SIG)*D2 - COSHM*D1PD2
            A = C2 - C1
            E = SIG*SINHM - COSHMM - COSHMM
          ELSE

!   Scale SINHM and COSHM by 2*EXP(-SIG) in order to avoid
!     overflow with large SIG.

            EMS = EXP(-SIG)
            EMS2 = EMS + EMS
            TM = 1.D0 - EMS
            SSINH = TM*(1.D0+EMS)
            SSM = SSINH - SIG*EMS2
            SCM = TM*TM
            C1 = SIG*SCM*D2 - SSM*D1PD2
            C2 = SIG*SSINH*D2 - SCM*D1PD2

!   R is in (0,1) and well-defined iff HPP(X1)*HPP(X2) < 0.

            F = FMAX
            CONT = .TRUE.
            IF (C1*(SIG*SCM*D1 - SSM*D1PD2) .GE. 0.D0)     &
              CONT = .FALSE.
            IF(CONT) A = EMS2*(SIG*TM*D2 + (TM-SIG)*D1PD2)
            IF (A*(C2+C1) .LT. 0.D0) CONT = .FALSE.
            IF(CONT) E = SIG*SSINH - SCM - SCM
          ENDIF

          IF(CONT) F = (SGN*(E*S2-C2) + SQRT(A*(C2+C1)))/E

!   Update number of iterations NIT.

          NIT = NIT + 1
          IF (LUN .GE. 0) WRITE (LUN,130) NIT, SIG, F
          130 FORMAT (1X,10X,I2,' -- SIG = ',D15.8,        &
                  ', F = ',D15.8)

!   Test for convergence.

          STOL = RTOL*SIG
          IF ( ABS(DMAX) .LE. STOL .OR. (F .GE. 0.D0 .AND. &
              F .LE. FTOL) .OR. ABS(F) .LE. RTOL ) THEN
            EXIT
          ENDIF
          DMAX = DMAX + DSIG
          IF ( F0*F .GT. 0.D0 .AND. ABS(F) .GE. ABS(F0) )THEN
            DSIG = DMAX
            F0 = FNEG
            CYCLE
          ENDIF
          IF (F0*F .LE. 0.D0) THEN

!   F and F0 have opposite signs.  Update (SNEG,FNEG) to
!     (SG0,F0) so that F and FNEG always have opposite
!     signs.  If SIG is closer to SNEG than SG0 and abs(F) <
!     abs(FNEG), then swap (SNEG,FNEG) with (SG0,F0).

            T1 = DMAX
            T2 = FNEG
            DMAX = DSIG
            FNEG = F0
            IF ( ABS(DSIG) .GT. ABS(T1)  .AND.             &
                 ABS(F) .LT. ABS(T2)          ) THEN

              DSIG = T1
              F0 = T2
            ENDIF
          ENDIF
        ENDDO

!   Bottom of loop:  F0*F > 0 and the new estimate would
!     be outside of the bracketing interval of length
!     abs(DMAX).  Reset (SG0,F0) to (SNEG,FNEG).

!  Update SIGMA(I), ICNT, and DSM if necessary.

        SIG = MIN(SIG,SBIG)
        IF (SIG .GT. SIGIN) THEN
          SIGMA(I) = SIG
          ICNT = ICNT + 1
          DSIG = SIG-SIGIN
          IF (SIGIN .GT. 0.D0) DSIG = DSIG/SIGIN
          DSM = MAX(DSM,DSIG)
        ENDIF
      ENDDO

    ENDIF

  END SUBROUTINE

  SUBROUTINE SNHCSH (X, SINHM,COSHM,COSHMM)
    DOUBLE PRECISION X, SINHM, COSHM, COSHMM
!***********************************************************
!                                                From TSPACK
!                                            Robert J. Renka
!                                  Dept. of Computer Science
!                                       Univ. of North Texas
!                                           renka@cs.unt.edu
!                                                   11/20/96
!   This subroutine computes approximations to the modified
! hyperbolic functions defined below with relative error
! bounded by 3.4E-20 for a floating point number system with
! sufficient precision.
!   Note that the 21-digit constants in the data statements
! below may not be acceptable to all compilers.
! On input:
!       X = Point at which the functions are to be
!           evaluated.
! X is not altered by this routine.
! On output:
!       SINHM = sinh(X) - X.
!       COSHM = cosh(X) - 1.
!       COSHMM = cosh(X) - 1 - X*X/2.
! Procedures required by SNHCSH:  None
! Intrinsic functions called by SNHCSH:  ABS, EXP
!**********************************************************

    DOUBLE PRECISION AX, EXPX, F, P, P1, P2, P3, P4, Q,    &
                     Q1, Q2, Q3, Q4, XC, XS, XSD2, XSD4

    DATA P1/-3.51754964808151394800D5/,                    &
         P2/-1.15614435765005216044D4/,                    &
         P3/-1.63725857525983828727D2/,                    &
         P4/-7.89474443963537015605D-1/
    DATA Q1/-2.11052978884890840399D6/,                    &
         Q2/3.61578279834431989373D4/,                     &
         Q3/-2.77711081420602794433D2/,                    &
         Q4/1.D0/
    AX = ABS(X)
    XS = AX*AX
    IF (AX .LE. .5D0) THEN

! Approximations for small X:

      XC = X*XS
      P = ((P4*XS+P3)*XS+P2)*XS+P1
      Q = ((Q4*XS+Q3)*XS+Q2)*XS+Q1
      SINHM = XC*(P/Q)
      XSD4 = .25D0*XS
      XSD2 = XSD4 + XSD4
      P = ((P4*XSD4+P3)*XSD4+P2)*XSD4+P1
      Q = ((Q4*XSD4+Q3)*XSD4+Q2)*XSD4+Q1
      F = XSD4*(P/Q)
      COSHMM = XSD2*F*(F+2.D0)
      COSHM = COSHMM + XSD2
    ELSE

! Approximations for large X:

      EXPX = EXP(AX)
      SINHM = -(((1.D0/EXPX+AX)+AX)-EXPX)/2.D0
      IF (X .LT. 0.D0) SINHM = -SINHM
      COSHM = ((1.D0/EXPX-2.D0)+EXPX)/2.D0
      COSHMM = COSHM - XS/2.D0
    ENDIF
  END SUBROUTINE

  SUBROUTINE YPC1 (N,X,Y, YP,IER)
    INTEGER N, IER
    DOUBLE PRECISION X(N), Y(N), YP(N)
!***********************************************************
!                                                From TSPACK
!                                            Robert J. Renka
!                                  Dept. of Computer Science
!                                       Univ. of North Texas
!                                           renka@cs.unt.edu
!                                                   06/10/92
!   This subroutine employs a three-point quadratic interpo-
! lation method to compute local derivative estimates YP
! associated with a set of data points.  The interpolation
! formula is the monotonicity-constrained parabolic method
! described in the reference cited below.  A Hermite int-
! erpolant of the data values and derivative estimates pre-
! serves monotonicity of the data.  Linear interpolation is
! used if N = 2.  The method is invariant under a linear
! scaling of the coordinates but is not additive.
! On input:
!       N = Number of data points.  N .GE. 2.
!       X = Array of length N containing a strictly in-
!           creasing sequence of abscissae:  X(I) < X(I+1)
!           for I = 1,...,N-1.
!       Y = Array of length N containing data values asso-
!           ciated with the abscissae.
! Input parameters are not altered by this routine.
! On output:
!       YP = Array of length N containing estimated deriv-
!            atives at the abscissae unless IER .NE. 0.
!            YP is not altered if IER = 1, and is only par-
!            tially defined if IER > 1.
!       IER = Error indicator:
!             IER = 0 if no errors were encountered.
!             IER = 1 if N < 2.
!             IER = I if X(I) .LE. X(I-1) for some I in the
!                     range 2,...,N.
! Reference:  J. M. Hyman, "Accurate Monotonicity-preserving
!               Cubic Interpolation",  LA-8796-MS, Los
!               Alamos National Lab, Feb. 1982.
! Procedures required by YPC1:  None
! Intrinsic functions called by YPC1:  ABS, MAX, MIN, SIGN
!***********************************************************

    INTEGER I, NM1
    DOUBLE PRECISION ASI, ASIM1, DX2, DXI, DXIM1, S2, SGN, &
                     SI, SIM1, T

    NM1 = N - 1
    I = 1
    DXI = X(2) - X(1)
    IF (DXI .LE. 0.D0) THEN
      ! X(I+1) .LE. X(I).
      IER = I + 1
      RETURN
    ENDIF
    SI = (Y(2)-Y(1))/DXI
    IF (NM1 .EQ. 1) THEN

! Use linear interpolation for N = 2.

      YP(1) = SI
      YP(2) = SI
      IER = 0
      RETURN
    ENDIF

! N .GE. 3.  YP(1) = S1 + DX1*(S1-S2)/(DX1+DX2) unless this
!   results in YP(1)*S1 .LE. 0 or abs(YP(1)) > 3*abs(S1).

    I = 2
    DX2 = X(3) - X(2)
    IF (DX2 .LE. 0.D0) THEN
      ! X(I+1) .LE. X(I).
      IER = I + 1
      RETURN
    ENDIF
    S2 = (Y(3)-Y(2))/DX2
    T = SI + DXI*(SI-S2)/(DXI+DX2)
    IF (SI .GE. 0.D0) THEN
      YP(1) = MIN(MAX(0.D0,T), 3.D0*SI)
    ELSE
      YP(1) = MAX(MIN(0.D0,T), 3.D0*SI)
    ENDIF

! YP(I) = (DXIM1*SI+DXI*SIM1)/(DXIM1+DXI) subject to the
!   constraint that YP(I) has the sign of either SIM1 or
!   SI, whichever has larger magnitude, and abs(YP(I)) .LE.
!   3*min(abs(SIM1),abs(SI)).

    DO I = 2,NM1
      DXIM1 = DXI
      DXI = X(I+1) - X(I)
      IF (DXI .LE. 0.D0) THEN
        ! X(I+1) .LE. X(I).
        IER = I + 1
        RETURN
      ENDIF
      SIM1 = SI
      SI = (Y(I+1)-Y(I))/DXI
      T = (DXIM1*SI+DXI*SIM1)/(DXIM1+DXI)
      ASIM1 = ABS(SIM1)
      ASI = ABS(SI)
      SGN = SIGN(1.D0,SI)
      IF (ASIM1 .GT. ASI) SGN = SIGN(1.D0,SIM1)
      IF (SGN .GT. 0.D0) THEN
        YP(I) = MIN(MAX(0.D0,T),3.D0*MIN(ASIM1,ASI))
      ELSE
        YP(I) = MAX(MIN(0.D0,T),-3.D0*MIN(ASIM1,ASI))
      ENDIF
    ENDDO

! YP(N) = SNM1 + DXNM1*(SNM1-SNM2)/(DXNM2+DXNM1) subject to
!   the constraint that YP(N) has the sign of SNM1 and
!   abs(YP(N)) .LE. 3*abs(SNM1).  Note that DXI = DXNM1 and
!   SI = SNM1.

    T = SI + DXI*(SI-SIM1)/(DXIM1+DXI)
    IF (SI .GE. 0.D0) THEN
      YP(N) = MIN(MAX(0.D0,T), 3.D0*SI)
    ELSE
      YP(N) = MAX(MIN(0.D0,T), 3.D0*SI)
    ENDIF
    IER = 0

  END SUBROUTINE

  DOUBLE PRECISION FUNCTION HVAL (T,N,X,Y,YP,SIGMA, IER)
    INTEGER N, IER
    DOUBLE PRECISION T, X(N), Y(N), YP(N), SIGMA(N)
!***********************************************************
!                                                From TSPACK
!                                            Robert J. Renka
!                                  Dept. of Computer Science
!                                       Univ. of North Texas
!                                           renka@cs.unt.edu
!                                                   11/17/96
!   This function evaluates a Hermite interpolatory tension
! spline H at a point T.  Note that a large value of SIGMA
! may cause underflow.  The result is assumed to be zero.
!   Given arrays X, Y, YP, and SIGMA of length NN, if T is
! known to lie in the interval (X(I),X(J)) for some I < J,
! a gain in efficiency can be achieved by calling this
! function with N = J+1-I (rather than NN) and the I-th
! components of the arrays (rather than the first) as par-
! ameters.
! On input:
!       T = Point at which H is to be evaluated.  Extrapo-
!           lation is performed if T < X(1) or T > X(N).
!       N = Number of data points.  N .GE. 2.
!       X = Array of length N containing the abscissae.
!           These must be in strictly increasing order:
!           X(I) < X(I+1) for I = 1,...,N-1.
!       Y = Array of length N containing data values.
!           H(X(I)) = Y(I) for I = 1,...,N.
!       YP = Array of length N containing first deriva-
!            tives.  HP(X(I)) = YP(I) for I = 1,...,N, where
!            HP denotes the derivative of H.
!       SIGMA = Array of length N-1 containing tension fac-
!               tors whose absolute values determine the
!               balance between cubic and linear in each
!               interval.  SIGMA(I) is associated with int-
!               erval (I,I+1) for I = 1,...,N-1.
! Input parameters are not altered by this function.
! On output:
!       IER = Error indicator:
!             IER = 0  if no errors were encountered and
!                      X(1) .LE. T .LE. X(N).
!             IER = 1  if no errors were encountered and
!                      extrapolation was necessary.
!             IER = -1 if N < 2.
!             IER = -2 if the abscissae are not in strictly
!                      increasing order.  (This error will
!                      not necessarily be detected.)
!       HVAL = Function value H(T), or zero if IER < 0.
! Procedures required by HVAL:  INTRVL, SNHCSH
! Intrinsic functions called by HVAL:  ABS, EXP
!***********************************************************
!
    INTEGER I, IP1
    DOUBLE PRECISION B1, B2, CM, CM2, CMM, D1, D2, DUMMY,  &
                     DX, E, E1, E2, EMS, S, S1, SB1, SB2,  &
                     SBIG, SIG, SM, SM2, TM, TP, TS, U, Y1

    DATA SBIG/85.D0/
    IF (N .LT. 2) THEN
      ! N is outside its valid range.
      HVAL = 0.D0
      IER = -1
    ELSE

! Find the index of the left end of an interval containing
!   T.  If T < X(1) or T > X(N), extrapolation is performed
!   using the leftmost or rightmost interval.

      IF (T .LT. X(1)) THEN
        I = 1
        IER = 1
      ELSEIF (T .GT. X(N)) THEN
        I = N-1
        IER = 1
      ELSE
        I = INTRVL (T,N,X)
        IER = 0
      ENDIF
      IP1 = I + 1

! Compute interval width DX, local coordinates B1 and B2,
!   and second differences D1 and D2.

      DX = X(IP1) - X(I)
      IF (DX .LE. 0.D0) THEN
        ! X(I) .GE. X(I+1).
        HVAL = 0.D0
        IER = -2
      ELSE
        U = T - X(I)
        B2 = U/DX
        B1 = 1.D0 - B2
        Y1 = Y(I)
        S1 = YP(I)
        S = (Y(IP1)-Y1)/DX
        D1 = S - S1
        D2 = YP(IP1) - S
        SIG = ABS(SIGMA(I))
        IF (SIG .LT. 1.D-9) THEN

! SIG = 0:  H is the Hermite cubic interpolant.

          HVAL = Y1 + U*(S1 + B2*(D1 + B1*(D1-D2)))
        ELSEIF (SIG .LE. .5D0) THEN

! 0 .LT. SIG .LE. .5:  use approximations designed to avoid
!   cancellation error in the hyperbolic functions.

          SB2 = SIG*B2
          CALL SNHCSH (SIG, SM,CM,CMM)
          CALL SNHCSH (SB2, SM2,CM2,DUMMY)
          E = SIG*SM - CMM - CMM
          HVAL = Y1 + S1*U + DX*((CM*SM2-SM*CM2)*(D1+D2) + &
                 SIG*(CM*CM2-(SM+SIG)*SM2)*D1) / (SIG*E)
        ELSE

! SIG > .5:  use negative exponentials in order to avoid
!   overflow.  Note that EMS = EXP(-SIG).  In the case of
!   extrapolation (negative B1 or B2), H is approximated by
!   a linear function if -SIG*B1 or -SIG*B2 is large.

          SB1 = SIG*B1
          SB2 = SIG - SB1
          IF (-SB1 .GT. SBIG  .OR.  -SB2 .GT. SBIG) THEN
            HVAL = Y1 + S*U
          ELSE
            E1 = EXP(-SB1)
            E2 = EXP(-SB2)
            EMS = E1*E2
            TM = 1.D0 - EMS
            TS = TM*TM
            TP = 1.D0 + EMS
            E = TM*(SIG*TP - TM - TM)
            HVAL = Y1 + S*U + DX*(TM*(TP-E1-E2)*(D1+D2) +  &
                   SIG* ((E2+EMS*(E1-2.D0)-B1*TS)*D1 +     &
                   (E1+EMS*(E2-2.D0)-B2*TS)*D2)) / (SIG*E)
          ENDIF
        ENDIF
      ENDIF
    ENDIF

  END FUNCTION

  DOUBLE PRECISION FUNCTION HPVAL (T,N,X,Y,YP,SIGMA, IER)
    INTEGER N, IER
    DOUBLE PRECISION T, X(N), Y(N), YP(N), SIGMA(N)
!***********************************************************
!                                                From TSPACK
!                                            Robert J. Renka
!                                  Dept. of Computer Science
!                                       Univ. of North Texas
!                                           renka@cs.unt.edu
!                                                   11/17/96
!   This function evaluates the first derivative HP of a
! Hermite interpolatory tension spline H at a point T.
! On input:
!       T = Point at which HP is to be evaluated.  Extrapo-
!           lation is performed if T < X(1) or T > X(N).
!       N = Number of data points.  N .GE. 2.
!       X = Array of length N containing the abscissae.
!           These must be in strictly increasing order:
!           X(I) < X(I+1) for I = 1,...,N-1.
!       Y = Array of length N containing data values.
!           H(X(I)) = Y(I) for I = 1,...,N.
!       YP = Array of length N containing first deriva-
!            tives.  HP(X(I)) = YP(I) for I = 1,...,N.
!       SIGMA = Array of length N-1 containing tension fac-
!               tors whose absolute values determine the
!               balance between cubic and linear in each
!               interval.  SIGMA(I) is associated with int-
!               erval (I,I+1) for I = 1,...,N-1.
! Input parameters are not altered by this function.
! On output:
!       IER = Error indicator:
!             IER = 0  if no errors were encountered and
!                      X(1) .LE. T .LE. X(N).
!             IER = 1  if no errors were encountered and
!                      extrapolation was necessary.
!             IER = -1 if N < 2.
!             IER = -2 if the abscissae are not in strictly
!                      increasing order.  (This error will
!                      not necessarily be detected.)
!       HPVAL = Derivative value HP(T), or zero if IER < 0.
! Procedures required by HPVAL:  INTRVL, SNHCSH
! Intrinsic functions called by HPVAL:  ABS, EXP
!***********************************************************

    INTEGER I, IP1
    DOUBLE PRECISION B1, B2, CM, CM2, CMM, D1, D2, DUMMY,  &
                     DX, E, E1, E2, EMS, S, S1, SB1, SB2,  &
                     SBIG, SIG, SINH2, SM, SM2, TM

    DATA SBIG/85.D0/
    IF (N .LT. 2) THEN
      ! N is outside its valid range.
      HPVAL = 0.D0
      IER = -1
    ELSE

! Find the index of the left end of an interval containing
!   T.  If T < X(1) or T > X(N), extrapolation is performed
!   using the leftmost or rightmost interval.

      IF (T .LT. X(1)) THEN
        I = 1
        IER = 1
      ELSEIF (T .GT. X(N)) THEN
        I = N-1
        IER = 1
      ELSE
        I = INTRVL (T,N,X)
        IER = 0
      ENDIF
      IP1 = I + 1

! Compute interval width DX, local coordinates B1 and B2,
!   and second differences D1 and D2.

      DX = X(IP1) - X(I)
      IF (DX .LE. 0.D0) THEN
        ! X(I) .GE. X(I+1).
        HPVAL = 0.D0
        IER = -2
      ELSE
        B1 = (X(IP1) - T)/DX
        B2 = 1.D0 - B1
        S1 = YP(I)
        S = (Y(IP1)-Y(I))/DX
        D1 = S - S1
        D2 = YP(IP1) - S
        SIG = ABS(SIGMA(I))
        IF (SIG .LT. 1.D-9) THEN

! SIG = 0:  H is the Hermite cubic interpolant.

          HPVAL = S1 + B2*(D1 + D2 - 3.D0*B1*(D2-D1))
        ELSEIF (SIG .LE. .5D0) THEN

! 0 .LT. SIG .LE. .5:  use approximations designed to avoid
!   cancellation error in the hyperbolic functions.

          SB2 = SIG*B2
          CALL SNHCSH (SIG, SM,CM,CMM)
          CALL SNHCSH (SB2, SM2,CM2,DUMMY)
          SINH2 = SM2 + SB2
          E = SIG*SM - CMM - CMM
          HPVAL = S1 + ((CM*CM2-SM*SINH2)*(D1+D2) +        &
                    SIG*(CM*SINH2-(SM+SIG)*CM2)*D1)/E
        ELSE

! SIG > .5:  use negative exponentials in order to avoid
!   overflow.  Note that EMS = EXP(-SIG).  In the case of
!   extrapolation (negative B1 or B2), H is approximated by
!   a linear function if -SIG*B1 or -SIG*B2 is large.

          SB1 = SIG*B1
          SB2 = SIG - SB1
          IF (-SB1 .GT. SBIG  .OR.  -SB2 .GT. SBIG) THEN
            HPVAL = S
          ELSE
            E1 = EXP(-SB1)
            E2 = EXP(-SB2)
            EMS = E1*E2
            TM = 1.D0 - EMS
            E = TM*(SIG*(1.D0+EMS) - TM - TM)
            HPVAL = S + (TM*((E2-E1)*(D1+D2) + TM*(D1-D2)) &
                + SIG*((E1*EMS-E2)*D1 + (E1-E2*EMS)*D2))/E
          ENDIF
        ENDIF
      ENDIF
    ENDIF

  END FUNCTION

  DOUBLE PRECISION FUNCTION STORE (X)
    DOUBLE PRECISION X
!***********************************************************
!                                                From TSPACK
!                                            Robert J. Renka
!                                  Dept. of Computer Science
!                                       Univ. of North Texas
!                                           renka@cs.unt.edu
!                                                   06/10/92
!   This function forces its argument X to be stored in a
! memory location, thus providing a means of determining
! floating point number characteristics (such as the machine
! precision) when it is necessary to avoid computation in
! high precision registers.
! On input:
!       X = Value to be stored.
! X is not altered by this function.
! On output:
!       STORE = Value of X after it has been stored and
!               possibly truncated or rounded to the single
!               precision word length.
! Procedures required by STORE:  None
!***********************************************************

    DOUBLE PRECISION Y
    COMMON/STCOM/Y
    Y = X
    STORE = Y
  END FUNCTION

  INTEGER FUNCTION INTRVL (T,N,X)
    INTEGER N
    DOUBLE PRECISION T, X(N)
!***********************************************************
!                                                From TSPACK
!                                            Robert J. Renka
!                                  Dept. of Computer Science
!                                       Univ. of North Texas
!                                           renka@cs.unt.edu
!                                                   06/10/92
!   This function returns the index of the left end of an
! interval (defined by an increasing sequence X) which
! contains the value T.  The method consists of first test-
! ing the interval returned by a previous call, if any, and
! then using a binary search if necessary.
! On input:
!       T = Point to be located.
!       N = Length of X.  N .GE. 2.
!       X = Array of length N assumed (without a test) to
!           contain a strictly increasing sequence of
!           values.
! Input parameters are not altered by this function.
! On output:
!       INTRVL = Index I defined as follows:
!                  I = 1    if  T .LT. X(2) or N .LE. 2,
!                  I = N-1  if  T .GE. X(N-1), and
!                  X(I) .LE. T .LT. X(I+1) otherwise.
! Procedures required by INTRVL:  None
!***********************************************************

    INTEGER IH, IL, K
    DOUBLE PRECISION TT
    LOGICAL FLAG

    SAVE IL
    DATA IL/1/

    TT = T
    FLAG = .TRUE.
    IF (IL .GE. 1  .AND.  IL .LT. N) THEN
      IF (X(IL) .LE. TT  .AND.  TT .LT. X(IL+1)) FLAG=.FALSE.
    ENDIF

    IF(FLAG) THEN
! Initialize low and high indexes.

      IL = 1
      IH = N

! Binary search:

      DO
        IF (IH .LE. IL+1) EXIT
        K = (IL+IH)/2
        IF (TT .LT. X(K)) THEN
          IH = K
        ELSE
          IL = K
        ENDIF
      ENDDO

! X(IL) .LE. T .LT. X(IL+1)  or  (T .LT. X(1) and IL=1)
!                            or  (T .GE. X(N) and IL=N-1)

    ENDIF

    INTRVL = IL
  END FUNCTION

END MODULE TENSION_MOD


      SUBROUTINE MB04BZ( JOB, COMPQ, N, A, LDA, DE, LDDE, B, LDB, FG,
     $                   LDFG, Q, LDQ, ALPHAR, ALPHAI, BETA, DWORK,
     $                   LDWORK, ZWORK, LZWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a complex N-by-N skew-Hamiltonian/
C     Hamiltonian pencil aS - bH, with
C
C           (  A  D  )         (  B  F  )
C       S = (      H ) and H = (      H ).                           (1)
C           (  E  A  )         (  G -B  )
C
C     This routine computes the eigenvalues using an embedding to a real
C     skew-Hamiltonian/skew-Hamiltonian pencil aB_S - bB_T, defined as
C
C
C             (  Re(A)  -Im(A)  |  Re(D)  -Im(D)  )
C             (                 |                 )
C             (  Im(A)   Re(A)  |  Im(D)   Re(D)  )
C             (                 |                 )
C       B_S = (-----------------+-----------------) , and
C             (                 |      T       T  )
C             (  Re(E)  -Im(E)  |  Re(A )  Im(A ) )
C             (                 |      T       T  )
C             (  Im(E)   Re(E)  | -Im(A )  Re(A ) )
C                                                                    (2)
C             ( -Im(B)  -Re(B)  | -Im(F)  -Re(F)  )
C             (                 |                 )
C             (  Re(B)  -Im(B)  |  Re(F)  -Im(F)  )
C             (                 |                 )
C       B_T = (-----------------+-----------------) ,  T = i*H.
C             (                 |      T       T  )
C             ( -Im(G)  -Re(G)  | -Im(B )  Re(B ) )
C             (                 |      T       T  )
C             (  Re(G)  -Im(G)  | -Re(B ) -Im(B ) )
C
C     Optionally, if JOB = 'T', the pencil aB_S - bB_H (B_H = -i*B_T) is
C     transformed by a unitary matrix Q to the structured Schur form
C
C                ( BA  BD  )              ( BB  BF  )
C       B_Sout = (       H ) and B_Hout = (       H ),               (3)
C                (  0  BA  )              (  0 -BB  )
C
C     where BA and BB are upper triangular, BD is skew-Hermitian, and
C     BF is Hermitian. The embedding doubles the multiplicities of the
C     eigenvalues of the pencil aS - bH. Optionally, if COMPQ = 'C', the
C     unitary matrix Q is computed.
C
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'E': compute the eigenvalues only; S and H will not
C                    necessarily be transformed as in (3).
C             = 'T': put S and H into the forms in (3) and return the
C                    eigenvalues in ALPHAR, ALPHAI and BETA.
C
C     COMPQ   CHARACTER*1
C             Specifies whether to compute the unitary transformation
C             matrix Q, as follows:
C             = 'N':  Q is not computed;
C             = 'C':  compute the unitary transformation matrix Q.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA, K)
C             where K = N/2, if JOB = 'E', and K = N, if JOB = 'T'.
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix A.
C             On exit, if JOB = 'T', the leading N-by-N part of this
C             array contains the upper triangular matrix BA in (3) (see
C             also METHOD). The strictly lower triangular part is not
C             zeroed, but it is preserved.
C             If JOB = 'E', this array is unchanged on exit.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, K).
C
C     DE      (input/output) COMPLEX*16 array, dimension
C                            (LDDE, MIN(K+1,N))
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             skew-Hermitian matrix E, and the N/2-by-N/2 upper
C             triangular part of the submatrix in the columns 2 to N/2+1
C             of this array must contain the upper triangular part of
C             the skew-Hermitian matrix D.
C             On exit, if JOB = 'T', the leading N-by-N part of this
C             array contains the skew-Hermitian matrix BD in (3) (see
C             also METHOD). The strictly lower triangular part of the
C             input matrix is preserved.
C             If JOB = 'E', this array is unchanged on exit.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.  LDDE >= MAX(1, K).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB, K)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix B.
C             On exit, if JOB = 'T', the leading N-by-N part of this
C             array contains the upper triangular matrix BB in (3) (see
C             also METHOD). The strictly lower triangular part is not
C             zeroed; the elements below the first subdiagonal of the
C             input matrix are preserved.
C             If JOB = 'E', this array is unchanged on exit.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, K).
C
C     FG      (input/output) COMPLEX*16 array, dimension
C                            (LDFG, MIN(K+1,N))
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             Hermitian matrix G, and the N/2-by-N/2 upper triangular
C             part of the submatrix in the columns 2 to N/2+1 of this
C             array must contain the upper triangular part of the
C             Hermitian matrix F.
C             On exit, if JOB = 'T', the leading N-by-N part of this
C             array contains the Hermitian matrix BF in (3) (see also
C             METHOD). The strictly lower triangular part of the input
C             matrix is preserved. The diagonal elements might have tiny
C             imaginary parts.
C             If JOB = 'E', this array is unchanged on exit.
C
C     LDFG    INTEGER
C             The leading dimension of the array FG.  LDFG >= MAX(1, K).
C
C     Q       (output) COMPLEX*16 array, dimension (LDQ, 2*N)
C             On exit, if COMPQ = 'C', the leading 2*N-by-2*N part of
C             this array contains the unitary transformation matrix Q
C             that reduced the matrices B_S and B_H to the form in (3).
C             However, if JOB = 'E', the reduction was possibly not
C             completed: the matrix B_H may have 2-by-2 diagonal blocks,
C             and the array Q returns the orthogonal matrix that
C             performed the partial reduction.
C             If COMPQ = 'N', this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,           if COMPQ = 'N';
C             LDQ >= MAX(1, 2*N), if COMPQ = 'C'.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C             The real parts of each scalar alpha defining an eigenvalue
C             of the pencil aS - bH.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C             The imaginary parts of each scalar alpha defining an
C             eigenvalue of the pencil aS - bH.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             The scalars beta that define the eigenvalues of the pencil
C             aS - bH.
C             Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
C             beta = BETA(j) represent the j-th eigenvalue of the pencil
C             aS - bH, in the form lambda = alpha/beta. Since lambda may
C             overflow, the ratios should not, in general, be computed.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C             On exit, if INFO = -18, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C                                               If COMPQ = 'N',
C             LDWORK >= MAX( 1,  4*N*N + 3*N ), if   JOB = 'E';
C             LDWORK >= MAX( 1,  5*N*N + 3*N ), if   JOB = 'T';
C             LDWORK >= MAX( 1, 11*N*N + 2*N ), if COMPQ = 'C'.
C             For good performance LDWORK should be generally larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) returns the optimal LZWORK.
C             On exit, if INFO = -20, ZWORK(1) returns the minimum
C             value of LZWORK.
C
C     LZWORK  INTEGER
C             The dimension of the array ZWORK.
C             LZWORK >= 1,       if JOB = 'E'; otherwise,
C             LZWORK >= 6*N + 4, if COMPQ = 'N';
C             LZWORK >= 8*N + 4, if COMPQ = 'C'.
C
C             If LZWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             ZWORK array, returns this value as the first entry of
C             the ZWORK array, and no error message related to LZWORK
C             is issued by XERBLA.
C
C     BWORK   LOGICAL array, dimension (LBWORK)
C             LBWORK >= 0, if JOB = 'E';
C             LBWORK >= N, if JOB = 'T'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: QZ iteration failed in the SLICOT Library routine
C                  MB04FD (QZ iteration did not converge or computation
C                  of the shifts failed);
C             = 2: QZ iteration failed in the LAPACK routine ZHGEQZ when
C                  trying to triangularize the 2-by-2 blocks.
C
C     METHOD
C
C     First, T = i*H is set. Then, the embeddings, B_S and B_T, of the
C     matrices S and T, are determined and, subsequently, the SLICOT
C     Library routine MB04FD is applied to compute the structured Schur
C     form, i.e., the factorizations
C
C     ~        T  T         (  S11  S12  )
C     B_S = J Q  J  B_S Q = (          T ) and
C                           (   0   S11  )
C
C     ~        T  T         (  T11  T12  )
C     B_T = J Q  J  B_T Q = (          T ),
C                           (   0   T11  )
C
C     where Q is real orthogonal, S11 is upper triangular, and T11 is
C     upper quasi-triangular. If JOB = 'T', then the matrices above are
C                                                        ~
C     further transformed so that the 2-by-2 blocks in i*B_T are split
C     into 1-by-1 blocks.  If COMPQ = 'C', the transformations are
C     accumulated in the unitary matrix Q.
C     See also page 22 in [1] for more details.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N )
C     complex floating point operations.
C
C     FURTHER COMMENTS
C
C     This routine does not perform any scaling of the matrices. Scaling
C     might sometimes be useful, and it should be done externally.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Nov. 2011, July 2012.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Deflating subspace, embedded pencil, skew-Hamiltonian/Hamiltonian
C     pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      COMPLEX*16         CZERO, CONE, CIMAG
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                      CONE = ( 1.0D+0, 0.0D+0 ),
     $                     CIMAG = ( 0.0D+0, 1.0D+0 ) )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, JOB
      INTEGER            INFO, LDA, LDB, LDDE, LDFG, LDQ, LDWORK,
     $                   LZWORK, N
C
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      DOUBLE PRECISION   ALPHAI( * ), ALPHAR( * ), BETA( * ), DWORK( * )
      COMPLEX*16         A( LDA, * ), B( LDB, * ), DE( LDDE, * ),
     $                   FG( LDFG, * ), Q( LDQ, * ), ZWORK( * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LQUERY, LTRI
      CHARACTER*14       CMPQ, JOBF
      INTEGER            I, I1, IA, IB, IDE, IEV, IFG, IQ, IQ2, IQB, IS,
     $                   IW, IW1, IWRK, J, J1, J2, JM1, JP2, K, M,
     $                   MINDB, MINDW, MINZW, N2, NB, NC, NN, OPTDW,
     $                   OPTZW
      DOUBLE PRECISION   EPS, NRMB
      COMPLEX*16         TMP
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DSCAL, MB04FD, XERBLA, ZGEMM,
     $                   ZGEQRF, ZHGEQZ, ZLACPY, ZSCAL
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M     = N/2
      NN    = N*N
      N2    = 2*N
      LTRI  = LSAME( JOB,   'T' )
      LCMPQ = LSAME( COMPQ, 'C' )
C
      IF( LTRI ) THEN
         K = N
      ELSE
         K = M
      END IF
C
      IF( N.EQ.0 ) THEN
         MINDW = 1
         MINZW = 1
      ELSE IF( LCMPQ ) THEN
         MINDB =  8*NN + N2
         MINDW = 11*NN + N2
         MINZW =  8*N  + 4
      ELSE
         MINDB =  4*NN + N2
         IF( LTRI ) THEN
            MINDW = 5*NN + 3*N
         ELSE
            MINDW = 4*NN + 3*N
         END IF
         MINZW = 6*N + 4
      END IF
C
      LQUERY = LDWORK.EQ.-1 .OR. LZWORK.EQ.-1
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -3
      ELSE IF(  LDA.LT.MAX( 1, K ) ) THEN
         INFO = -5
      ELSE IF( LDDE.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF(  LDB.LT.MAX( 1, K ) ) THEN
         INFO = -9
      ELSE IF( LDFG.LT.MAX( 1, K ) ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N2 ) ) THEN
         INFO = -13
      ELSE IF( .NOT. LQUERY ) THEN
         IF( LDWORK.LT.MINDW ) THEN
            DWORK( 1 ) = MINDW
            INFO = -18
         ELSE IF( LZWORK.LT.MINZW ) THEN
            ZWORK( 1 ) = MINZW
            INFO = -20
         END IF
      END IF
C
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB04BZ', -INFO )
         RETURN
      ELSE IF( N.GT.0 ) THEN
C
C        Compute optimal workspace.
C
         OPTZW = MINZW
         IF( LCMPQ ) THEN
            CMPQ = 'Initialize'
         ELSE
            CMPQ = 'No Computation'
         END IF
C
         IF( LTRI ) THEN
            JOBF = 'Triangularize'
            CALL ZGEQRF( N, N, ZWORK, N, ZWORK, ZWORK, -1, INFO )
            I  = INT( ZWORK( 1 ) )
            NB = MAX( I/N, 2 )
         ELSE
            JOBF = 'Eigenvalues'
         END IF
C
         IF( LQUERY ) THEN
            CALL MB04FD( JOBF, CMPQ, N2, DWORK, N, DWORK, N, DWORK, N,
     $                   DWORK, N, DWORK, N2, ALPHAI, ALPHAR, BETA,
     $                   DWORK, -1, INFO )
            OPTDW = MAX( MINDW, MINDB + INT( DWORK( 1 ) ) )
            DWORK( 1 ) = OPTDW
            ZWORK( 1 ) = OPTZW
            RETURN
         END IF
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK( 1 ) = ONE
         ZWORK( 1 ) = CONE
         RETURN
      END IF
C
C     Set up the embeddings of the matrices S and H.
C
C     Set the pointers for the inputs and outputs of MB04FD.
C     Real workspace:    need   4*N**2 + 2*N, if COMPQ = 'N';
C                               8*N**2 + 2*N, if COMPQ = 'C'.
C
      IQ = 1
      IF( LCMPQ ) THEN
         IA = IQ + N2*N2
      ELSE
         IA = 1
      END IF
C
      IDE  = IA  + NN
      IB   = IDE + NN + N
      IFG  = IB  + NN
      IWRK = IFG + NN + N
C
C     Build the embedding of A.
C
      IW = IA
      IS = IW + N*M
      DO 30 J = 1, M
         IW1 = IW
         DO 10 I = 1, M
            DWORK( IW ) = DBLE( A( I, J ) )
            IW = IW + 1
   10    CONTINUE
C
         DO 20 I = 1, M
            DWORK( IW ) =  DIMAG( A( I, J ) )
            DWORK( IS ) = -DWORK( IW )
            IW = IW + 1
            IS = IS + 1
   20    CONTINUE
         CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 )
         IS = IS + M
   30 CONTINUE
C
C     Build the embedding of D and E.
C
      IW = IDE
      DO 60 J = 1, M + 1
         DO 40 I = 1, M
            DWORK( IW ) = DBLE( DE( I, J ) )
            IW = IW + 1
   40    CONTINUE
C
         IW = IW + J - 1
         IS = IW
         DO 50 I = J, M
            DWORK( IW ) = DIMAG( DE( I, J ) )
            DWORK( IS ) = DWORK( IW )
            IW = IW + 1
            IS = IS + N
   50    CONTINUE
   60 CONTINUE
C
      IW1 = IW
      I1  = IW
      DO 80 J = 2, M + 1
         IS = I1
         I1 = I1 + 1
         DO 70 I = 1, J - 1
            DWORK( IW ) = -DIMAG( DE( I, J ) )
            DWORK( IS ) =  DWORK( IW )
            IW = IW + 1
            IS = IS + N
   70    CONTINUE
         IW = IW + N - J + 1
   80 CONTINUE
      CALL DLACPY( 'Full', M, M+1, DWORK( IDE ), N, DWORK( IW1-M ), N )
C
C     Build the embedding of B.
C
      IW = IB
      IS = IW + N*M
      DO 110 J = 1, M
         IW1 = IW
         DO 90 I = 1, M
            DWORK( IW ) = -DIMAG( B( I, J ) )
            IW = IW + 1
   90    CONTINUE
C
         DO 100 I = 1, M
            DWORK( IW ) =   DBLE( B( I, J ) )
            DWORK( IS ) = -DWORK( IW )
            IW = IW + 1
            IS = IS + 1
  100    CONTINUE
         CALL DCOPY( M, DWORK( IW1 ), 1, DWORK( IS ), 1 )
         IS = IS + M
  110 CONTINUE
C
C     Build the embedding of F and G.
C
      IW = IFG
      DO 140 J = 1, M + 1
         DO 120 I = 1, M
            DWORK( IW ) = -DIMAG( FG( I, J ) )
            IW = IW + 1
  120    CONTINUE
C
         IW = IW + J - 1
         IS = IW
         DO 130 I = J, M
            DWORK( IW ) =  DBLE( FG( I, J ) )
            DWORK( IS ) = DWORK( IW )
            IW = IW + 1
            IS = IS + N
  130    CONTINUE
  140 CONTINUE
C
      IW1 = IW
      I1  = IW
      DO 160 J = 2, M + 1
         IS = I1
         I1 = I1 + 1
         DO 150 I = 1, J - 1
            DWORK( IW ) = -DBLE( FG( I, J ) )
            DWORK( IS ) = DWORK( IW )
            IW = IW + 1
            IS = IS + N
  150    CONTINUE
         IW = IW + N - J + 1
  160 CONTINUE
      CALL DLACPY( 'Full', M, M+1, DWORK( IFG ), N, DWORK( IW1-M ), N )
C
C     STEP 1: Apply MB04FD to transform the extended pencil to real
C             skew-Hamiltonian/skew-Hamiltonian Schur form.
C
C             Real workspace:
C                  need    4*N*N + 3*N, if JOB = 'E' and COMPQ = 'N';
C                          5*N*N + 3*N, if JOB = 'T' and COMPQ = 'N';
C                         11*N*N + 2*N, if               COMPQ = 'C'.
C                  prefer larger.
C
      CALL MB04FD( JOBF, CMPQ, N2, DWORK( IA ), N, DWORK( IDE ), N,
     $             DWORK( IB ), N, DWORK( IFG ), N, DWORK( IQ ), N2,
     $             ALPHAI, ALPHAR, BETA, DWORK( IWRK ), LDWORK-IWRK+1,
     $             INFO )
      IF( INFO.GT.0 )
     $   RETURN
      OPTDW = MAX( MINDW, MINDB + INT( DWORK( IWRK ) ) )
C
C     Scale the eigenvalues.
C
      CALL DSCAL( N, -ONE, ALPHAI, 1 )
C
      IF( LCMPQ ) THEN
C
C        Set the transformation matrix.
C
         IW = IQ
         DO 180 J = 1, N2
            DO 170 I = 1, N2
               Q( I, J ) = DCMPLX( DWORK( IW ) )
               IW = IW + 1
  170       CONTINUE
  180    CONTINUE
      END IF
C
C     Return if further reduction is not required.
C
      IF( .NOT.LTRI ) THEN
         DWORK( 1 ) = OPTDW
         ZWORK( 1 ) = OPTZW
         RETURN
      END IF
C
C     Convert the results to complex datatype. D and F start in the
C     first column of DE and FG, respectively.
C
      IW = IA
      DO 200 J = 1, N
         DO 190 I = 1, J
            A( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  190    CONTINUE
         IW = IW + N - J
  200 CONTINUE
C
      IW = IDE + N
      DO 220 J = 1, N
         DO 210 I = 1, J - 1
            DE( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  210    CONTINUE
         DE( J, J ) = CZERO
         IW = IW + N - J + 1
  220 CONTINUE
C
      IW = IB
      DO 240 J = 1, N
         DO 230 I = 1, MIN( J + 1, N )
            B( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  230    CONTINUE
         IW = IW + N - J - 1
  240 CONTINUE
C
      IW = IFG + N
      DO 260 J = 1, N
         DO 250 I = 1, J - 1
            FG( I, J ) = DCMPLX( DWORK( IW ) )
            IW = IW + 1
  250    CONTINUE
         FG( J, J ) = CZERO
         IW = IW + N - J + 1
  260 CONTINUE
C
C     Triangularize the 2-by-2 diagonal blocks in B using the complex
C     version of the QZ algorithm.
C
C     Determine machine constants.
C
      EPS = DLAMCH( 'Precision' )
C
C     Set up pointers on the outputs of ZHGEQZ.
C     A block algorithm is used for large N.
C
      IQ2  = 1
      IEV  = 5
      IQ   = 9
      IWRK = IQ + 4*( N - 1 )
C
      J  = 1
      J1 = 1
      J2 = MIN( N, J1 + NB - 1 )
C     WHILE( J.LT.N ) DO
  270 CONTINUE
      IF( J.LT.N ) THEN
         NRMB = ABS( B( J, J ) ) + ABS( B( J+1, J+1 ) )
         IF( ABS( B( J+1, J ) ).GT.NRMB*EPS ) THEN
C
C           Triangularization step.
C           Complex workspace:    need   4*N + 6.
C           Real    workspace:    need   2.
C
            NC  = MAX( J2-J-1, 0 )
            JM1 = MAX( J-1, 1 )
            JP2 = MIN( J+2, N )
            TMP         =  A( J+1, J )
            A( J+1, J ) = CZERO
            CALL ZHGEQZ( 'Schur Form', 'Initialize', 'Initialize', 2, 1,
     $                   2, B( J, J ), LDB, A( J, J ), LDA,
     $                   ZWORK( IEV ), ZWORK( IEV+2 ), ZWORK( IQ ), 2,
     $                   ZWORK( IQ2 ), 2, ZWORK( IWRK ), LZWORK-IWRK+1,
     $                   DWORK, INFO )
            A( J+1, J ) = TMP
            IF( INFO.GT.0 ) THEN
               INFO = 2
               RETURN
            END IF
C
C           Update A, DE, B, and FG.
C           Complex workspace:    need   6*N + 4.
C
C           Update A.
C
            CALL ZGEMM(  'No Transpose', 'No Transpose', J-1, 2, 2,
     $                   CONE, A( 1, J ), LDA, ZWORK( IQ2 ), 2, CZERO,
     $                   ZWORK( IWRK ), JM1 )
            CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, A( 1, J ),
     $                   LDA )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2, NC,
     $                   2, CONE, ZWORK( IQ ), 2, A( J, JP2 ), LDA,
     $                   CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, A( J, JP2 ),
     $                   LDA )
C
C           Update DE.
C
            TMP          =  DE( J+1, J )
            DE( J+1, J ) = -DE( J, J+1 )
            CALL ZGEMM(  'No Transpose', 'No Transpose', J+1, 2, 2,
     $                   CONE, DE( 1, J ), LDDE, ZWORK( IQ ), 2, CZERO,
     $                   ZWORK( IWRK ), J+1 )
            CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, DE( 1, J ),
     $                   LDDE )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                   J2-J+1, 2, CONE, ZWORK( IQ ), 2, DE( J, J ),
     $                   LDDE, CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2,
     $                   DE( J, J ), LDDE )
            DE( J+1, J ) = TMP
C
C           Update B.
C
            CALL ZGEMM(  'No Transpose', 'No Transpose', J-1, 2, 2,
     $                   CONE, B( 1, J ), LDB, ZWORK( IQ2 ), 2, CZERO,
     $                   ZWORK( IWRK ), JM1 )
            CALL ZLACPY( 'Full', J-1, 2, ZWORK( IWRK ), JM1, B( 1, J ),
     $                   LDB )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2, NC,
     $                   2, CONE, ZWORK( IQ ), 2, B( J, JP2 ), LDB,
     $                   CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2, B( J, JP2 ),
     $                   LDB )
C
C           Update FG.
C
            TMP          =  FG( J+1, J )
            FG( J+1, J ) = -FG( J, J+1 )
            CALL ZGEMM(  'No Transpose', 'No Transpose', J+1, 2, 2,
     $                   CONE, FG( 1, J ), LDFG, ZWORK( IQ ), 2, CZERO,
     $                   ZWORK( IWRK ), J+1 )
            CALL ZLACPY( 'Full', J+1, 2, ZWORK( IWRK ), J+1, FG( 1, J ),
     $                   LDFG )
            CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                   J2-J+1, 2, CONE, ZWORK( IQ ), 2, FG( J, J ),
     $                   LDFG, CZERO, ZWORK( IWRK ), 2 )
            CALL ZLACPY( 'Full', 2, J2-J+1, ZWORK( IWRK ), 2,
     $                   FG( J, J ), LDFG )
            FG( J+1, J ) = TMP
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C              Complex workspace:    need   8*N + 4.
C
               CALL ZGEMM(  'No Transpose', 'No Transpose', N2, 2, 2,
     $                      CONE, Q( 1, J ), LDQ, ZWORK( IQ2 ), 2,
     $                      CZERO, ZWORK( IWRK ), N2 )
               CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2, Q( 1, J ),
     $                      LDQ )
               CALL ZGEMM(  'No Transpose', 'No Transpose', N2, 2, 2,
     $                      CONE, Q( 1, N+J ), LDQ, ZWORK( IQ ), 2,
     $                      CZERO, ZWORK( IWRK ), N2 )
               CALL ZLACPY( 'Full', N2, 2, ZWORK( IWRK ), N2,
     $                      Q( 1, N+J ), LDQ )
            END IF
C
            BWORK( J ) = .TRUE.
            J  = J  + 2
            IQ = IQ + 4
         ELSE
            BWORK( J )  = .FALSE.
            B( J+1, J ) = CZERO
            J = J + 1
         END IF
C
         IF( J.GE.J2 ) THEN
            J1 = J2 + 1
            J2 = MIN( N, J1 + NB - 1 )
            NC = J2 - J1 + 1
C
C           Update the columns J1 to J2 of A, DE, B, and FG for previous
C           transformations.
C
            I   = 1
            IQB = 9
C           WHILE( I.LT.J ) DO
  280       CONTINUE
            IF( I.LT.J ) THEN
               IF( BWORK( I ) ) THEN
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2, A( I, J1 ),
     $                         LDA, CZERO, ZWORK( IWRK ), 2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         A( I, J1 ), LDA )
C
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2,
     $                         DE( I, J1 ), LDDE, CZERO, ZWORK( IWRK ),
     $                         2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         DE( I, J1 ), LDDE )
C
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2, B( I, J1 ),
     $                         LDB, CZERO, ZWORK( IWRK ), 2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         B( I, J1 ), LDB )
C
                  CALL ZGEMM(  'Conjugate Transpose', 'No Transpose', 2,
     $                         NC, 2, CONE, ZWORK( IQB ), 2,
     $                         FG( I, J1 ), LDFG, CZERO, ZWORK( IWRK ),
     $                         2 )
                  CALL ZLACPY( 'Full', 2, NC, ZWORK( IWRK ), 2,
     $                         FG( I, J1 ), LDFG )
                  IQB = IQB + 4
C
                  I = I + 2
               ELSE
                  I = I + 1
               END IF
               GO TO 280
            END IF
C           END WHILE 280
         END IF
         GO TO 270
      END IF
C     END WHILE 270
C
C     Scale B and FG by -i.
C
      DO 290 I = 1, N
         CALL ZSCAL( I, -CIMAG, B( 1, I ), 1 )
  290 CONTINUE
C
      DO 300 I = 1, N
         CALL ZSCAL( I, -CIMAG, FG( 1, I ), 1 )
  300 CONTINUE
C
      DWORK( 1 ) = OPTDW
      ZWORK( 1 ) = OPTZW
      RETURN
C *** Last line of MB04BZ ***
      END