      DOUBLE PRECISION FUNCTION DSINPX (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DSINPX Krogh   Added external statement.
C>> 1996-01-29 SCOSPX WVS JPL Add better acknowledgement for origins.
C>> 1994-10-20 DSINPX Krogh  Changes to use M77CON
C>> 1994-04-22 DSINPX CLL Made SP and DP codes similar.
C>> 1993-05-06 DSINPX WVS JPL Convert from NSWC to Math 77
c--D replaces "?": ?SINPX, ?ERM1
C ----------------------------------------------------------------------
c This procedure was originally procedure SIN1 from the Naval Surface
c Warfare Center library.
C ----------------------------------------------------------------------
C
C                        EVALUATION OF SIN(PI*X)
C
C                             --------------
C
C     THE EXPANSION FOR SIN(PI*A) (ABS(A) .LE. 1/4) USING A1,...,A13
C     IS ACCURATE TO WITHIN 2 UNITS OF THE 40-TH SIGNIFICANT DIGIT, AND
C     THE EXPANSION FOR COS(PI*A) (ABS(A) .LE. 1/4) USING B1,...,B13
C     IS ACCURATE TO WITHIN 4 UNITS OF THE 40-TH SIGNIFICANT DIGIT.
c
c     The polynomials using coefficients SA0, ... SA6 and SB1, ..., SB6
c     give approximations whose largest observed relative error in the
c     relevant intervals is 0.129d-14.
c     We will use this latter approximation when the machine epsilon
c     is larger than 0.2d-14.
c ----------------------------------------------------------------------
      external D1MACH
      integer N
      double precision D1MACH
      DOUBLE PRECISION A, BIG, CUTOFF, EPS, PI, T, W, X
      DOUBLE PRECISION A1, A2, A3, A4, A5, A6, A7, A8, A9, A10,
     *                 A11, A12, A13
      DOUBLE PRECISION B1, B2, B3, B4, B5, B6, B7, B8, B9, B10,
     *                 B11, B12, B13
      DOUBLE PRECISION SA0, SA1, SA2, SA3, SA4, SA5, SA6
      DOUBLE PRECISION      SB1, SB2, SB3, SB4, SB5, SB6
      SAVE BIG, EPS
c -----------------------
      PARAMETER ( PI = 3.141592653589793238462643383279502884197D+00 )
      parameter ( CUTOFF = 0.2d-14 )
c -----------------------
      data EPS / -1.0d0 /
      DATA SA0 /.314159265358979D+01/, SA1 /-.516771278004995D+01/,
     *     SA2 /.255016403987327D+01/, SA3 /-.599264528932149D+00/,
     *     SA4 /.821458689493251D-01/, SA5 /-.737001831310553D-02/,
     *     SA6 /.461514425296398D-03/
      DATA SB1 /-.493480220054460D+01/, SB2 /.405871212639605D+01/,
     *     SB3 /-.133526276691575D+01/, SB4 /.235330543508553D+00/,
     *     SB5 /-.258048861575714D-01/, SB6 /.190653140279462D-02/
      DATA A1  /-.1028083791780141522795259479153765743002D+00/,
     *     A2  / .3170868848763100170457042079710451905600D-02/,
     *     A3  /-.4657026956105571623449026167864697920000D-04/,
     *     A4  / .3989844942879455643410226655783424000000D-06/,
     *     A5  /-.2237397227721999776371894030796800000000D-08/,
     *     A6  / .8847045483056962709715066675200000000000D-11/,
     *     A7  /-.2598715447506450292885585920000000000000D-13/,
     *     A8  / .5893449774331011070033920000000000000000D-16/,
     *     A9  /-.1062975472045522550784000000000000000000D-18/,
     *     A10 / .1561182648301780992000000000000000000000D-21/,
     *     A11 /-.1903193516670976000000000000000000000000D-24/,
     *     A12 / .1956617650176000000000000000000000000000D-27/,
     *     A13 /-.1711276032000000000000000000000000000000D-30/
c -----------------------
      DATA B1  /-.3084251375340424568385778437461297229882D+00/,
     *     B2  / .1585434424381550085228521039855226435920D-01/,
     *     B3  /-.3259918869273900136414318317506279360000D-03/,
     *     B4  / .3590860448591510079069203991239232000000D-05/,
     *     B5  /-.2461136950494199754009084061808640000000D-07/,
     *     B6  / .1150115912797405152263195572224000000000D-09/,
     *     B7  /-.3898073171259675439899172864000000000000D-12/,
     *     B8  / .1001886461636271969091584000000000000000D-14/,
     *     B9  /-.2019653396886572027084800000000000000000D-17/,
     *     B10 / .3278483561466560512000000000000000000000D-20/,
     *     B11 /-.4377345082051788800000000000000000000000D-23/,
     *     B12 / .4891532381388800000000000000000000000000D-26/,
     *     B13 /-.4617089843200000000000000000000000000000D-29/
c -----------------------
      IF (eps .LT. 0.0d0) then
         eps = D1MACH(3)
         BIG = 1.0d0/eps
      endif
c -----------------------
      A = ABS(X)
      IF (A .GE. BIG) THEN
         CALL DERM1 ('DSINPX',1,2,
     1   'No precision because ABS(X) is too large','X',X,'.')
         DSINPX = 0.D0
         RETURN
      END IF
      N = A
      T = N
      A = A - T
      IF (A .GT. 0.75D0) GO TO 20
      IF (A .LT. 0.25D0) GO TO 21
C
C                    0.25 .LE. A .LE. 0.75
C
      A = 0.25D0 + (0.25D0 - A)
      if(eps .lt. cutoff) then
         T = 16.D0*A*A
         DSINPX = (((((((((((((B13*T + B12)*T + B11)*T + B10)*T + B9)*T+
     *                B8)*T + B7)*T + B6)*T + B5)*T + B4)*T + B3)*T +
     *                B2)*T + B1)*T + 0.5D0) + 0.5D0
      else
         T = A*A
         DSINPX = ((((((SB6*T + SB5)*T + SB4)*T + SB3)*T + SB2)*T
     *                  + SB1)*T + 0.5D0) + 0.5D0
      endif
      GO TO 30
C
C                 A .LT. 0.25  OR  A .GT. 0.75
C
   20 A = 0.25D0 + (0.75D0 - A)
   21 continue
      if(eps .lt. cutoff) then
         T = 16.D0*A*A
         W = (((((((((((((A13*T + A12)*T + A11)*T + A10)*T + A9)*T +
     *            A8)*T + A7)*T + A6)*T + A5)*T + A4)*T + A3)*T +
     *            A2)*T + A1)*T + 0.5D0) + 0.5D0
         DSINPX = PI*A*W
      else
         T = A*A
         DSINPX = ((((((SA6*T + SA5)*T + SA4)*T + SA3)*T + SA2)*T
     *                  + SA1)*T + SA0)*A
      endif
C
C                        TERMINATION
C
   30 IF (X .LT. 0.0D0) DSINPX = - DSINPX
      IF (MOD(N,2) .NE. 0) DSINPX = - DSINPX
      RETURN
      END


      DOUBLE PRECISION FUNCTION PHO_PTCUT(Ecm,Ip)
C***********************************************************************
C
C     calculate energy-dependent transverse momentum cutoff
C
C***********************************************************************

      IMPLICIT NONE

      SAVE

      DOUBLE PRECISION Ecm
      INTEGER Ip

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  model switches and parameters
      INCLUDE 'inc/pomdls'

      IF ( IPAmdl(7).EQ.0 ) THEN
C  energy-independent cutoff
         PHO_PTCUT = PARmdl(35+Ip)
      ELSE IF ( IPAmdl(7).EQ.1 ) THEN
C  Bopp et al. type (DPMJET)
         PHO_PTCUT = PARmdl(35+Ip)
     &               + MAX(0.D0,0.12D0*(LOG10(Ecm/50.D0))**3)
      ELSE IF ( IPAmdl(7).EQ.2 ) THEN
C  Gribov-Levin-Ryskin type energy dependence
         PHO_PTCUT = PARmdl(35+Ip)
     &               + 0.065D0*EXP(0.9D0*SQRT(2.D0*LOG(Ecm)))
      ELSE IF ( IPAmdl(7).EQ.3 ) THEN
C  Golec-Biernat-Wusthoff type dependence
         PHO_PTCUT = PARmdl(250)*((Ecm+PARmdl(251))/PARmdl(252))
     &               **PARmdl(253)
      ELSE
         PHO_PTCUT = 0.D0
         WRITE (LO,*) 'PHO_PTCUT: UNKNOWN MODEL SWITCH' , IPAmdl(7)
         CALL PHO_ABORT
      END IF

      END FUNCTION


      SUBROUTINE SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE,
     $                   DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Cholesky factor U of the matrix X, X = U**T * U or
C     X = U * U**T, which is the solution of the generalized c-stable
C     continuous-time Lyapunov equation
C
C         T            T                  2    T
C        A  * X * E + E  * X * A = - SCALE  * B  * B,                (1)
C
C     or the transposed equation
C
C                 T            T          2        T
C        A * X * E  + E * X * A  = - SCALE  * B * B ,                (2)
C
C     respectively, where A, E, B, and U are real N-by-N matrices. The
C     Cholesky factor U of the solution is computed without first
C     finding X. The pencil A - lambda * E must be in generalized Schur
C     form ( A upper quasitriangular, E upper triangular ). Moreover, it
C     must be c-stable, i.e. its eigenvalues must have negative real
C     parts. B must be an upper triangular matrix with non-negative
C     entries on its main diagonal.
C
C     The resulting matrix U is upper triangular. The entries on its
C     main diagonal are non-negative. SCALE is an output scale factor
C     set to avoid overflow in U.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANS   CHARACTER*1
C             Specifies whether equation (1) or equation (2) is to be
C             solved:
C             = 'N':  Solve equation (1);
C             = 'T':  Solve equation (2).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N upper Hessenberg part of this array
C             must contain the quasitriangular 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             The leading N-by-N upper triangular part of this array
C             must contain the matrix E.
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading N-by-N upper triangular part of this
C             array must contain the matrix B.
C             On exit, the leading N-by-N upper triangular part of this
C             array contains the solution matrix U.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor set to avoid overflow in U.
C             0 < SCALE <= 1.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (6*N-6)
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 generalized Sylvester equation to be solved in
C                   step II (see METHOD) is (nearly) singular to working
C                   precision;  perturbed values were used to solve the
C                   equation (but the matrices A and E are unchanged);
C             = 2:  the generalized Schur form of the pencil
C                   A - lambda * E contains a 2-by-2 main diagonal block
C                   whose eigenvalues are not a pair of conjugate
C                   complex numbers;
C             = 3:  the pencil A - lambda * E is not stable, i.e. there
C                   is an eigenvalue without a negative real part.
C
C     METHOD
C
C     The method [2] used by the routine is an extension of Hammarling's
C     algorithm [1] to generalized Lyapunov equations.
C
C     We present the method for solving equation (1). Equation (2) can
C     be treated in a similar fashion. For simplicity, assume SCALE = 1.
C
C     The matrix A is an upper quasitriangular matrix, i.e. it is a
C     block triangular matrix with square blocks on the main diagonal
C     and the block order at most 2. We use the following partitioning
C     for the matrices A, E, B and the solution matrix U
C
C               ( A11   A12 )        ( E11   E12 )
C           A = (           ),   E = (           ),
C               (   0   A22 )        (   0   E22 )
C
C               ( B11   B12 )        ( U11   U12 )
C           B = (           ),   U = (           ).                  (3)
C               (   0   B22 )        (   0   U22 )
C
C     The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or
C     2-by-2.
C
C     We compute U11 and U12**T in three steps.
C
C     Step I:
C
C        From (1) and (3) we get the 1-by-1 or 2-by-2 equation
C
C                T      T                  T      T
C             A11  * U11  * U11 * E11 + E11  * U11  * U11 * A11
C
C                    T
C             = - B11  * B11.
C
C        For brevity, details are omitted here. The technique for
C        computing U11 is similar to those applied to standard Lyapunov
C        equations in Hammarling's algorithm ([1], section 6).
C
C        Furthermore, the auxiliary matrices M1 and M2 defined as
C        follows
C
C                               -1      -1
C           M1 = U11 * A11 * E11   * U11
C
C                         -1      -1
C           M2 = B11 * E11   * U11
C
C        are computed in a numerically reliable way.
C
C     Step II:
C
C        We solve for U12**T the generalized Sylvester equation
C
C              T      T      T      T
C           A22  * U12  + E22  * U12  * M1
C
C                  T           T      T      T      T
C           = - B12  * M2 - A12  * U11  - E12  * U11  * M1.
C
C     Step III:
C
C        One can show that
C
C              T      T                  T      T
C           A22  * U22  * U22 * E22 + E22  * U22  * U22 * A22  =
C
C                T              T
C           - B22  * B22 - y * y                                     (4)
C
C        holds, where y is defined as follows
C
C                  T      T      T      T
C           w = E12  * U11  + E22  * U12
C                  T         T
C           y = B12  - w * M2 .
C
C        If B22_tilde is the square triangular matrix arising from the
C        QR-factorization
C
C               ( B22_tilde )     ( B22  )
C           Q * (           )  =  (      ),
C               (     0     )     ( y**T )
C
C        then
C
C                T              T                T
C           - B22  * B22 - y * y   =  - B22_tilde  * B22_tilde.
C
C        Replacing the right hand side in (4) by the term
C        - B22_tilde**T * B22_tilde leads to a generalized Lyapunov
C        equation of lower dimension compared to (1).
C
C     The solution U of the equation (1) can be obtained by recursive
C     application of the steps I to III.
C
C     REFERENCES
C
C     [1] Hammarling, S.J.
C         Numerical solution of the stable, non-negative definite
C         Lyapunov equation.
C         IMA J. Num. Anal., 2, pp. 303-323, 1982.
C
C     [2] Penzl, T.
C         Numerical solution of generalized Lyapunov equations.
C         Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
C
C     NUMERICAL ASPECTS
C
C     The routine requires 2*N**3 flops. Note that we count a single
C     floating point arithmetic operation as one flop.
C
C     FURTHER COMMENTS
C
C     The Lyapunov equation may be very ill-conditioned. In particular,
C     if the pencil A - lambda * E has a pair of almost degenerate
C     eigenvalues, then the Lyapunov equation will be ill-conditioned.
C     Perturbed values were used to solve the equation.
C     A condition estimate can be obtained from the routine SG03AD.
C     When setting the error indicator INFO, the routine does not test
C     for near instability in the equation but only for exact
C     instability.
C
C     CONTRIBUTOR
C
C     T. Penzl, Technical University Chemnitz, Germany, Aug. 1998.
C
C     REVISIONS
C
C     Sep. 1998 (V. Sima).
C
C     KEYWORDS
C
C     Lyapunov equation
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  MONE, ONE, TWO, ZERO
      PARAMETER         ( MONE = -1.0D0, ONE = 1.0D+0, TWO = 2.0D+0,
     $                    ZERO = 0.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANS
      DOUBLE PRECISION  SCALE
      INTEGER           INFO, LDA, LDB, LDE, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*)
C     .. Local Scalars ..
      DOUBLE PRECISION  BIGNUM, C, DELTA1, EPS, S, SCALE1, SMLNUM, X, Z
      INTEGER           I, INFO1, J, KB, KH, KL, LDWS, UIIPT, WPT, YPT
      LOGICAL           NOTRNS
C     .. Local Arrays ..
      DOUBLE PRECISION  M1(2,2), M2(2,2), TM(2,2), UI(2,2)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
      LOGICAL           LSAME
      EXTERNAL          DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DLABAD, DLACPY, DLASET, DROT,
     $                  DROTG, DSCAL, DTRMM, SG03BW, SG03BX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SQRT
C     .. Executable Statements ..
C
C     Decode input parameter.
C
      NOTRNS = LSAME( TRANS, 'N' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN
         INFO = -1
      ELSEIF ( N .LT. 0 ) THEN
         INFO = -2
      ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN
         INFO = -4
      ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN
         INFO = -6
      ELSEIF ( LDB .LT. MAX( 1, N ) ) THEN
         INFO = -8
      ELSE
         INFO = 0
      END IF
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'SG03BV', -INFO )
         RETURN
      END IF
C
      SCALE = ONE
C
C     Quick return if possible.
C
      IF ( N .EQ. 0 )
     $    RETURN
C
C     Set constants to control overflow.
C
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )/EPS
      BIGNUM = ONE/SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
C
C     Set work space pointers and leading dimension of matrices in
C     work space.
C
      UIIPT = 1
      WPT = 2*N-1
      YPT = 4*N-3
      LDWS = N-1
C
      IF ( NOTRNS ) THEN
C
C        Solve equation (1).
C
C        Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the
C        number of rows in this block row.
C
         KH = 0
C        WHILE ( KH .LT. N ) DO
   20    IF ( KH .LT. N ) THEN
            KL = KH + 1
            IF ( KL .EQ. N ) THEN
               KH = N
               KB = 1
            ELSE
               IF ( A(KL+1,KL) .EQ. ZERO ) THEN
                  KH = KL
                  KB = 1
               ELSE
                  KH = KL + 1
                  KB = 2
               END IF
            END IF
C
C           STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary
C                   matrices M1 and M2. (For the moment the result
C                   U(KL:KH,KL:KH) is stored in UI).
C
            IF ( KB .EQ. 1 ) THEN
               DELTA1 = -TWO*A(KL,KL)*E(KL,KL)
               IF ( DELTA1 .LE. ZERO ) THEN
                  INFO = 3
                  RETURN
               END IF
               DELTA1 = SQRT( DELTA1 )
               Z = TWO*ABS( B(KL,KL) )*SMLNUM
               IF ( Z .GT. DELTA1 ) THEN
                  SCALE1 = DELTA1/Z
                  SCALE = SCALE1*SCALE
                  DO 40 I = 1, N
                     CALL DSCAL( I, SCALE1, B(1,I), 1 )
   40             CONTINUE
               END IF
               UI(1,1) = B(KL,KL)/DELTA1
               M1(1,1) = A(KL,KL)/E(KL,KL)
               M2(1,1) = DELTA1/E(KL,KL)
            ELSE
C
C              If a pair of complex conjugate eigenvalues occurs, apply
C              (complex) Hammarling algorithm for the 2-by-2 problem.
C
               CALL SG03BX( 'C', 'N', A(KL,KL), LDA, E(KL,KL), LDE,
     $                      B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2,
     $                      INFO1 )
               IF ( INFO1 .NE. 0 ) THEN
                  INFO = INFO1
                  RETURN
               END IF
               IF ( SCALE1 .NE. ONE ) THEN
                  SCALE = SCALE1*SCALE
                  DO 60 I = 1, N
                     CALL DSCAL( I, SCALE1, B(1,I), 1 )
   60             CONTINUE
               END IF
            END IF
C
            IF ( KH .LT. N ) THEN
C
C              STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized
C                       Sylvester equation. (For the moment the result
C                       U(KL:KH,KH+1:N) is stored in the workspace.)
C
C              Form right hand side of the Sylvester equation.
C
               CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1),
     $                     LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS )
               CALL DGEMM( 'T', 'T', N-KH, KB, KB, MONE, A(KL,KH+1),
     $                     LDA, UI, 2, ONE, DWORK(UIIPT), LDWS )
               CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2,
     $                     ZERO, TM, 2 )
               CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, E(KL,KH+1),
     $                     LDE, TM, 2, ONE, DWORK(UIIPT), LDWS )
C
C              Solve generalized Sylvester equation.
C
               CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 )
               CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, TM, 2,
     $                      E(KH+1,KH+1), LDE, M1, 2, DWORK(UIIPT),
     $                      LDWS, SCALE1, INFO1 )
               IF ( INFO1 .NE. 0 )
     $            INFO = 1
               IF ( SCALE1 .NE. ONE ) THEN
                  SCALE = SCALE1*SCALE
                  DO 80 I = 1, N
                     CALL DSCAL( I, SCALE1, B(1,I), 1 )
   80             CONTINUE
                  CALL DSCAL( 4, SCALE1, UI(1,1), 1 )
               END IF
C
C              STEP III: Form the right hand side matrix
C                        B(KH+1:N,KH+1:N) of the (smaller) Lyapunov
C                        equation to be solved during the next pass of
C                        the main loop.
C
C              Compute auxiliary vectors (or matrices) W and Y.
C
               CALL DLACPY( 'A', N-KH, KB, DWORK(UIIPT), LDWS,
     $                      DWORK(WPT), LDWS )
               CALL DTRMM(  'L', 'U', 'T', 'N', N-KH, KB, ONE,
     $                      E(KH+1,KH+1), LDE, DWORK(WPT), LDWS )
               CALL DGEMM(  'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1),
     $                      LDE, UI, 2, ONE, DWORK(WPT), LDWS )
               DO 100 I = KL, KH
                  CALL DCOPY( N-KH, B(I,KH+1), LDB,
     $                        DWORK(YPT+LDWS*(I-KL)), 1 )
  100          CONTINUE
               CALL DGEMM( 'N', 'T', N-KH, KB, KB, MONE, DWORK(WPT),
     $                     LDWS, M2, 2, ONE, DWORK(YPT), LDWS )
C
C              Overwrite B(KH+1:N,KH+1:N) with the triangular matrix
C              from the QR-factorization of the (N-KH+KB)-by-(N-KH)
C              matrix
C
C                          (  B(KH+1:N,KH+1:N)  )
C                          (                    )
C                          (       Y**T         ) .
C
               DO 140 J = 1, KB
                  DO 120 I = 1, N-KH
                     X = B(KH+I,KH+I)
                     Z = DWORK(YPT+I-1+(J-1)*LDWS)
                     CALL DROTG( X, Z, C, S )
                     CALL DROT(  N-KH-I+1, B(KH+I,KH+I), LDB,
     $                           DWORK(YPT+I-1+(J-1)*LDWS), 1, C, S )
  120             CONTINUE
  140          CONTINUE
C
C              Make main diagonal elements of B(KH+1:N,KH+1:N) positive.
C
               DO 160 I = KH+1, N
                  IF ( B(I,I) .LT. ZERO )
     $               CALL DSCAL( N-I+1, MONE, B(I,I), LDB )
  160          CONTINUE
C
C              Overwrite right hand side with the part of the solution
C              computed in step II.
C
               DO 180 J = KL, KH
                  CALL DCOPY( N-KH, DWORK(UIIPT+(J-KL)*LDWS), 1,
     $                        B(J,KH+1), LDB )
  180          CONTINUE
            END IF
C
C           Overwrite right hand side with the part of the solution
C           computed in step I.
C
            CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB )
C
         GOTO 20
         END IF
C        END WHILE 20
C
      ELSE
C
C        Solve equation (2).
C
C        Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the
C        number of columns in this block column.
C
         KL = N + 1
C        WHILE ( KL .GT. 1 ) DO
  200    IF ( KL .GT. 1 ) THEN
            KH = KL - 1
            IF ( KH .EQ. 1 ) THEN
               KL = 1
               KB = 1
            ELSE
               IF ( A(KH,KH-1) .EQ. ZERO ) THEN
                  KL = KH
                  KB = 1
               ELSE
                  KL = KH - 1
                  KB = 2
               END IF
            END IF
C
C           STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary
C                   matrices M1 and M2. (For the moment the result
C                   U(KL:KH,KL:KH) is stored in UI).
C
            IF ( KB .EQ. 1 ) THEN
               DELTA1 = -TWO*A(KL,KL)*E(KL,KL)
               IF ( DELTA1 .LE. ZERO ) THEN
                  INFO = 3
                  RETURN
               END IF
               DELTA1 = SQRT( DELTA1 )
               Z = TWO*ABS( B(KL,KL) )*SMLNUM
               IF ( Z .GT. DELTA1 ) THEN
                  SCALE1 = DELTA1/Z
                  SCALE = SCALE1*SCALE
                  DO 220 I = 1, N
                     CALL DSCAL( I, SCALE1, B(1,I), 1 )
  220             CONTINUE
               END IF
               UI(1,1) = B(KL,KL)/DELTA1
               M1(1,1) = A(KL,KL)/E(KL,KL)
               M2(1,1) = DELTA1/E(KL,KL)
            ELSE
C
C              If a pair of complex conjugate eigenvalues occurs, apply
C              (complex) Hammarling algorithm for the 2-by-2 problem.
C
               CALL SG03BX( 'C', 'T', A(KL,KL), LDA, E(KL,KL), LDE,
     $                      B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2,
     $                      INFO1 )
               IF ( INFO1 .NE. 0 ) THEN
                  INFO = INFO1
                  RETURN
               END IF
               IF ( SCALE1 .NE. ONE ) THEN
                  SCALE = SCALE1*SCALE
                  DO 240 I = 1, N
                     CALL DSCAL( I, SCALE1, B(1,I), 1 )
  240             CONTINUE
               END IF
            END IF
C
            IF ( KL .GT. 1 ) THEN
C
C              STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized
C                       Sylvester equation. (For the moment the result
C                       U(1:KL-1,KL:KH) is stored in the workspace.)
C
C              Form right hand side of the Sylvester equation.
C
               CALL DGEMM( 'N', 'T', KL-1, KB, KB, MONE, B(1,KL), LDB,
     $                     M2, 2, ZERO, DWORK(UIIPT), LDWS )
               CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, A(1,KL), LDA,
     $                     UI, 2, ONE, DWORK(UIIPT), LDWS )
               CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2,
     $                     ZERO, TM, 2 )
               CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, E(1,KL), LDE,
     $                     TM, 2, ONE, DWORK(UIIPT), LDWS )
C
C              Solve generalized Sylvester equation.
C
               CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 )
               CALL SG03BW( 'T', KL-1, KB, A, LDA, TM, 2, E, LDE, M1, 2,
     $                      DWORK(UIIPT), LDWS, SCALE1, INFO1 )
               IF ( INFO1 .NE. 0 )
     $            INFO = 1
               IF ( SCALE1 .NE. ONE ) THEN
                  SCALE = SCALE1*SCALE
                  DO 260 I = 1, N
                     CALL DSCAL( I, SCALE1, B(1,I), 1 )
  260             CONTINUE
                  CALL DSCAL( 4, SCALE1, UI(1,1), 1 )
               END IF
C
C              STEP III: Form the right hand side matrix
C                        B(1:KL-1,1:KL-1) of the (smaller) Lyapunov
C                        equation to be solved during the next pass of
C                        the main loop.
C
C              Compute auxiliary vectors (or matrices) W and Y.
C
               CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS,
     $                      DWORK(WPT), LDWS )
               CALL DTRMM(  'L', 'U', 'N', 'N', KL-1, KB, ONE, E(1,1),
     $                      LDE, DWORK(WPT), LDWS )
               CALL DGEMM(  'N', 'N', KL-1, KB, KB, ONE, E(1,KL), LDE,
     $                      UI, 2, ONE, DWORK(WPT), LDWS )
               CALL DLACPY( 'A', KL-1, KB, B(1, KL), LDB, DWORK(YPT),
     $                      LDWS )
               CALL DGEMM(  'N', 'N', KL-1, KB, KB, MONE, DWORK(WPT),
     $                      LDWS, M2, 2, ONE, DWORK(YPT), LDWS )
C
C              Overwrite B(1:KL-1,1:KL-1) with the triangular matrix
C              from the RQ-factorization of the (KL-1)-by-KH matrix
C
C                          (                        )
C                          (  B(1:KL-1,1:KL-1)   Y  )
C                          (                        ).
C
               DO 300 J = 1, KB
                  DO 280 I = KL-1, 1, -1
                     X = B(I,I)
                     Z = DWORK(YPT+I-1+(J-1)*LDWS)
                     CALL DROTG( X, Z, C, S )
                     CALL DROT(  I, B(1,I), 1, DWORK(YPT+(J-1)*LDWS), 1,
     $                           C, S )
  280             CONTINUE
  300          CONTINUE
C
C              Make main diagonal elements of B(1:KL-1,1:KL-1) positive.
C
               DO 320 I = 1, KL-1
                  IF ( B(I,I) .LT. ZERO )
     $               CALL DSCAL( I, MONE, B(1,I), 1 )
  320          CONTINUE
C
C              Overwrite right hand side with the part of the solution
C              computed in step II.
C
               CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, B(1,KL),
     $                      LDB )
C
            END IF
C
C           Overwrite right hand side with the part of the solution
C           computed in step I.
C
            CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB )
C
         GOTO 200
         END IF
C        END WHILE 200
C
      END IF
C
      RETURN
C *** Last line of SG03BV ***
      END


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of BTEST
module m1
  integer, parameter :: ia1(*) = [(j, j=0, 15)]
  logical, parameter :: test_ia1a = all(btest(ia1, 0) .eqv. [(.false., .true., j=1, 8)])
  logical, parameter :: test_ia1b = all(btest(ia1, 1) .eqv. [(.false., .false., .true., .true., j=1, 4)])
  logical, parameter :: test_ia1c = all(btest(ia1, 2) .eqv. [(modulo(j/4, 2) == 1, j=0, 15)])
  logical, parameter :: test_ia1d = all(btest(ia1, 3) .eqv. [(j > 8, j=1, 16)])
  logical, parameter :: test_shft1 = all([(btest(ishft(1_1, j), j), j=0, 7)])
  logical, parameter :: test_shft2 = all([(btest(ishft(1_2, j), j), j=0, 15)])
  logical, parameter :: test_shft4 = all([(btest(ishft(1_4, j), j), j=0, 31)])
  logical, parameter :: test_shft8 = all([(btest(ishft(1_8, j), j), j=0, 63)])
  logical, parameter :: test_shft16 = all([(btest(ishft(1_16, j), j), j=0, 127)])
  logical, parameter :: test_set1 = all([(btest(ibset(0_1, j), j), j=0, 7)])
  logical, parameter :: test_set2 = all([(btest(ibset(0_2, j), j), j=0, 15)])
  logical, parameter :: test_set4 = all([(btest(ibset(0_4, j), j), j=0, 31)])
  logical, parameter :: test_set8 = all([(btest(ibset(0_8, j), j), j=0, 63)])
  logical, parameter :: test_set16 = all([(btest(ibset(0_16, j), j), j=0, 127)])
  logical, parameter :: test_z = .not. any([(btest(0_4, j), j=0, 31)])
  logical, parameter :: test_shft1e = all(btest([(ishft(1_1, j), j=0, 7)], [(j, j=0, 7)]))
end module


*> \brief \b CGBTRS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CGBTRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
*                          INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANS
*       INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       COMPLEX            AB( LDAB, * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CGBTRS solves a system of linear equations
*>    A * X = B,  A**T * X = B,  or  A**H * X = B
*> with a general band matrix A using the LU factorization computed
*> by CGBTRF.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies the form of the system of equations.
*>          = 'N':  A * X = B     (No transpose)
*>          = 'T':  A**T * X = B  (Transpose)
*>          = 'C':  A**H * X = B  (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>          The number of subdiagonals within the band of A.  KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>          The number of superdiagonals within the band of A.  KU >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*>          AB is COMPLEX array, dimension (LDAB,N)
*>          Details of the LU factorization of the band matrix A, as
*>          computed by CGBTRF.  U is stored as an upper triangular band
*>          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
*>          the multipliers used during the factorization are stored in
*>          rows KL+KU+2 to 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*>          LDAB is INTEGER
*>          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          The pivot indices; for 1 <= i <= N, row i of the matrix was
*>          interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX array, dimension (LDB,NRHS)
*>          On entry, the right hand side matrix B.
*>          On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complexGBcomputational
*
*  =====================================================================
      SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
     $                   INFO )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            AB( LDAB, * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LNOTI, NOTRAN
      INTEGER            I, J, KD, L, LM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEMV, CGERU, CLACGV, CSWAP, CTBSV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGBTRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
      KD = KU + KL + 1
      LNOTI = KL.GT.0
*
      IF( NOTRAN ) THEN
*
*        Solve  A*X = B.
*
*        Solve L*X = B, overwriting B with X.
*
*        L is represented as a product of permutations and unit lower
*        triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
*        where each transformation L(i) is a rank-one modification of
*        the identity matrix.
*
         IF( LNOTI ) THEN
            DO 10 J = 1, N - 1
               LM = MIN( KL, N-J )
               L = IPIV( J )
               IF( L.NE.J )
     $            CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
               CALL CGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
     $                     LDB, B( J+1, 1 ), LDB )
   10       CONTINUE
         END IF
*
         DO 20 I = 1, NRHS
*
*           Solve U*X = B, overwriting B with X.
*
            CALL CTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
     $                  AB, LDAB, B( 1, I ), 1 )
   20    CONTINUE
*
      ELSE IF( LSAME( TRANS, 'T' ) ) THEN
*
*        Solve A**T * X = B.
*
         DO 30 I = 1, NRHS
*
*           Solve U**T * X = B, overwriting B with X.
*
            CALL CTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
     $                  LDAB, B( 1, I ), 1 )
   30    CONTINUE
*
*        Solve L**T * X = B, overwriting B with X.
*
         IF( LNOTI ) THEN
            DO 40 J = N - 1, 1, -1
               LM = MIN( KL, N-J )
               CALL CGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
     $                     LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
               L = IPIV( J )
               IF( L.NE.J )
     $            CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
   40       CONTINUE
         END IF
*
      ELSE
*
*        Solve A**H * X = B.
*
         DO 50 I = 1, NRHS
*
*           Solve U**H * X = B, overwriting B with X.
*
            CALL CTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N,
     $                  KL+KU, AB, LDAB, B( 1, I ), 1 )
   50    CONTINUE
*
*        Solve L**H * X = B, overwriting B with X.
*
         IF( LNOTI ) THEN
            DO 60 J = N - 1, 1, -1
               LM = MIN( KL, N-J )
               CALL CLACGV( NRHS, B( J, 1 ), LDB )
               CALL CGEMV( 'Conjugate transpose', LM, NRHS, -ONE,
     $                     B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE,
     $                     B( J, 1 ), LDB )
               CALL CLACGV( NRHS, B( J, 1 ), LDB )
               L = IPIV( J )
               IF( L.NE.J )
     $            CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
   60       CONTINUE
         END IF
      END IF
      RETURN
*
*     End of CGBTRS
*
      END


C
C	$Id: cssetup.f,v 1.5 2008-07-27 03:10:08 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSSETUP (XI,YI,WI,WK,S1,S2,WT, ROW)
      DOUBLE PRECISION XI, YI, WI, WK, S1, S2, WT, ROW(6)
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   05/09/92
C
C   This subroutine sets up the I-th row of an augmented
C regression matrix for a weighted least squares fit of a
C quadratic function Q(X,Y) to a set of data values Wi,
C where Q(0,0) = Wk.  The first 3 columns (quadratic terms)
C are scaled by 1/S2 and the fourth and fifth columns (lin-
C ear terms) are scaled by 1/S1.
C
C On input:
C
C       XI,YI = Coordinates of node I.
C
C       WI = Data value at node I.
C
C       WK = Data value interpolated by Q at the origin.
C
C       S1,S2 = Inverse scale factors.
C
C       WT = Weight factor corresponding to the I-th
C            equation.
C
C       ROW = Array of length 6.
C
C Input parameters are not altered by this routine.
C
C On output:
C
C       ROW = Array containing a row of the augmented re-
C             gression matrix.
C
C Modules required by CSSETUP:  None
C
C***********************************************************
C
      DOUBLE PRECISION W1, W2
C
C Local parameters:
C
C W1 = Weighted scale factor for the linear terms
C W2 = Weighted scale factor for the quadratic terms
C
      W1 = WT/S1
      W2 = WT/S2
      ROW(1) = XI*XI*W2
      ROW(2) = XI*YI*W2
      ROW(3) = YI*YI*W2
      ROW(4) = XI*W1
      ROW(5) = YI*W1
      ROW(6) = (WI-WK)*WT
      RETURN
      END


c=======================================================================
c=======================================================================
c     SUBROUTINES FOR STICK-BREAKING
c=======================================================================
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c=======================================================================

c=======================================================================
      subroutine sickbreaksim(nr,n,alpha,beta,workv,w,v)
c=======================================================================
c     Subroutine to compute the stick breaking weights up to
c     finite level n.
c
c     A.J.V. 2007
c=======================================================================
      implicit none

c+++++Input
      integer nr,n
      real*8 alpha(nr),beta(nr)

c+++++External working space
      real*8 workv(nr+1)

c+++++Output
      real*8 w(nr),v(nr)

c+++++Internal working space
      integer i
      real*8 rbeta
      real*8 tmp1,tmp2

c+++++Algorihtm

      workv(1)=0.d0
      tmp1=0.d0
      do i=1,n
         v(i)=rbeta(alpha(i),beta(i))
         tmp2=1.d0-v(i)
         if(i.ne.n)then
            tmp1=tmp1-dlog(tmp2)
            workv(i+1)=tmp1
         end if
      end do
      workv(n+1)=1.0D300

      tmp1=0.d0
      do i=1,n
         w(i)=dexp(-workv(i))-dexp(-workv(i+1))
         tmp1=tmp1+w(i)
      end do

      do i=1,n
         w(i)=w(i)/tmp1
      end do

      return
      end

c=======================================================================
      subroutine dpweightsimbl(n,ccluster,alpha,workv,w,v)
c=======================================================================
c     Subroutine to compute the DP weights up to
c     finite level n.
c
c     A.J.V. 2007
c=======================================================================
      implicit none

c+++++Input
      integer n
      integer ccluster(n)
      real*8 alpha

c+++++External working space
      real*8 workv(n+1)

c+++++Output
      real*8 w(n),v(n)

c+++++Internal working space
      integer i,j,ns
      real*8 rbeta
      real*8 tmp1,tmp2
      real*8 tmp3
      real*8 tmp5,tmp6
      real*8 tmpv

c+++++Algorihtm

      workv(1)=0.d0
      tmp1=0.d0
      do i=1,n-1
         tmp3=dble(ccluster(i))
         ns=0
         do j=i+1,n
            ns=ns+ccluster(j)
         end do
         tmp5=1.d0+tmp3
         tmp6=alpha+dble(ns)

         v(i)=rbeta(tmp5,tmp6)
         tmp2=1.d0-v(i)
         tmp1=tmp1-dlog(tmp2)
         workv(i+1)=tmp1
      end do
      workv(n+1)=1.0D300

      tmp1=0.d0
      do i=1,n
         w(i)=dexp(-workv(i))-dexp(-workv(i+1))
         tmp1=tmp1+w(i)
      end do

      do i=1,n
         w(i)=w(i)/tmp1
      end do

      return
      end

c=======================================================================
      subroutine sickbreak(n,v,workv,w)
c=======================================================================
c     Subroutine to compute the stick breaking weights.
c=======================================================================
      implicit none

c+++++Input
      integer n
      real*8 v(n)

c+++++External working space
      real*8 workv(n+1)

c+++++Output
      real*8 w(n)

c+++++Internal working space
      integer i
      real*8 tmp1,tmp2

c+++++Algorihtm

c      w(1)=v(1)
c      tmp1=1.d0-v(1)
c      do i=2,n
c	 w(i)=tmp1*v(i)
c         tmp1=tmp1*(1.d0-v(i))
c      end do

      workv(1)=0.d0
      tmp1=0.d0
      do i=1,n
         tmp2=1.d0-v(i)
         if(i.ne.n)then
            tmp1=tmp1-dlog(tmp2)
            workv(i+1)=tmp1
         end if
      end do
      workv(n+1)=1.0D300

      tmp1=0.d0
      do i=1,n
         w(i)=dexp(-workv(i))-dexp(-workv(i+1))
         tmp1=tmp1+w(i)
      end do

      do i=1,n
         w(i)=w(i)/tmp1
      end do

      return
      end


module global_module

  implicit none

  ! Time integration

  real(kind=8), parameter :: t_end      = 1.0d-1 ! [s] total simulated time (from 0 to t_end)
  real(kind=8), parameter :: CFL_target = 0.25

  ! Specify domain and discretization. This version includes a flat plate in the domain,
  ! therefore the domain must contain it.

  real(kind=8), parameter :: x_min = -1.75 ! [m] needs to be NEGATIVE
  real(kind=8), parameter :: x_max = 2.75  ! [m] needs to be LARGER THAN PLATE LENGTH L_plate
  real(kind=8), parameter :: y_min = -0.7 ! [m] needs to be NEGATIVE
  real(kind=8), parameter :: y_max = 2.1  ! [m] needs to be POSITIVE

  ! Total number of cells (including 2 ghost cells for each side)
  ! (using 2 ghost cells makes it easy to reach second order accuracy)

  integer, parameter :: Nx = 100
  integer, parameter :: Ny = 100

  real(kind=8), parameter :: dx = (x_max-x_min)/(Nx-4)
  real(kind=8), parameter :: dy = (y_max-y_min)/(Ny-4)

  ! Flat plate inside the domain.
  ! The plate is placed with the leading edge at (x,y) = (0,0).
  ! Make sure the domain is chosen correspondingly.

  real(kind=8), parameter :: L_plate = 1 ! [m] length of the flat plate

  integer, parameter :: j_plate   = floor(Ny/(y_max - y_min)*(0 - y_min)) ! find j-index of plate
  integer, parameter :: i_1_plate = floor(Nx/(x_max - x_min)*(0 - x_min)) ! starting coordinate of plate
  integer, parameter :: i_2_plate = floor(Nx/(x_max - x_min)*(L_plate - x_min)) ! starting coordinate of plate

  ! Free stream

  real(kind=8), parameter :: rho0 = 1.225d0   ! [kg/m3]
  real(kind=8), parameter :: ux0  = 0.0     ! [m/s]
  real(kind=8), parameter :: uy0  = 2867.2  ! [m/s]
  real(kind=8), parameter :: T0   = 300.0   ! [K]

  ! Utilities
  real(kind=8) :: ws_maxabs

end module


module analysis_module

  use bl_types
  use bl_constants_module
  use multifab_module
  use define_bc_module
  use ml_layout_module
  use init_lowmach_module
  use init_temp_module
  use probin_multispecies_module, only: nspecies
  use probin_common_module, only: total_volume

  implicit none

  private

  public :: print_errors,sum_mass,compute_cov

  contains

  subroutine print_errors(mla,rho,rho_exact,Temp,dx,time,the_bc_level)

    type(ml_layout) , intent(in)     :: mla
     type(multifab) , intent(in)     :: rho(:)
     type(multifab) , intent(inout)  :: rho_exact(:)
     type(multifab) , intent(inout)  :: Temp(:)
     real(kind=dp_t), intent(in   )  :: dx(:,:)
     real(kind=dp_t), intent(in   )  :: time
     type(bc_level) , intent(in   )  :: the_bc_level(:)

     ! local variables
     real(kind=dp_t), dimension(nspecies) :: norm_inf,norm_l1,norm_l2
     real(kind=dp_t)                      :: norm_inf_tot,norm_l1_tot,norm_l2_tot
     integer                              :: i,n,nlevs,dm
     type(multifab)                       :: umac_tmp(mla%nlevel,mla%dim)

     type(bl_prof_timer), save :: bpt

     call build(bpt,"print_errors")

     nlevs = mla%nlevel
     dm = mla%dim

     do n=1,nlevs
        do i=1,dm
           call multifab_build_edge(umac_tmp(n,i),mla%la(n),1,1,i)
        end do
     end do

     ! calculate rho_exact
     call init_rho_and_umac(mla,rho_exact,umac_tmp,dx,time,the_bc_level)
     call init_Temp(Temp,dx,time,the_bc_level)

     ! substract the values
     do n=1,nlevs
        call multifab_sub_sub_c(rho_exact(n),1,rho(n),1,nspecies,0)
     end do

     ! calculate norms for each species
     do n=1,nlevs
        do i=1, nspecies

           ! Linf norm = max(diff_i)
           norm_inf(i) = multifab_norm_inf_c(rho_exact(n),i,1,all=.false.)

           ! L1 norm = 1/total_volume*sum(diff_i)
           norm_l1(i) = multifab_sum_c(rho_exact(n),i,1,all=.false.)/total_volume

           ! L2 norm = sqrt{1/total_volume*sum(diff_i^2)}
           norm_l2(i) = multifab_norm_l2_c(rho_exact(n),i,1,all=.false.)/sqrt(dble(total_volume))

        end do
     end do

     ! calculate total norms
     norm_inf_tot = multifab_norm_inf_c(rho_exact(1),1,nspecies,all=.false.)
     norm_l1_tot = multifab_sum_c(rho_exact(1),1,nspecies,all=.false.)/total_volume
     norm_l2_tot = multifab_norm_l2_c(rho_exact(1),1,nspecies,all=.false.)/sqrt(dble(total_volume))

     ! print the norms
     if(.false.) then
        if (parallel_IOProcessor()) then
            if(time.gt.2.99d0) then
            !if(time.gt.0.49d0) then
               write(*,*), time, norm_inf(1:nspecies), norm_l1(1:nspecies),norm_l2(1:nspecies),&
                           norm_inf_tot,norm_l1_tot,norm_l2_tot
            end if
        end if
     end if

     ! for checking analytic solution with Visit
     call init_rho_and_umac(mla,rho_exact,umac_tmp,dx,time,the_bc_level)
     call init_Temp(Temp,dx,time,the_bc_level)

     do n=1,nlevs
        do i=1,dm
           call multifab_destroy(umac_tmp(n,i))
        end do
     end do

     call destroy(bpt)

  end subroutine print_errors

  subroutine sum_mass(rho, step)

    type(multifab), intent(in   ) :: rho(:)
    integer,        intent(in   ) :: step

    ! local variables
    real(kind=dp_t) :: mass(nspecies)
    integer         :: i,n,nlevs

    type(bl_prof_timer), save :: bpt

    call build(bpt,"sum_mass")

    nlevs = size(rho,1)

    do n=1,nlevs
       do i=1,nspecies
          mass(i) = multifab_sum_c(rho(n),i,1,all=.false.)
          if (parallel_IOProcessor()) then
             print*, step, ' sum of rho_i for i=',i,mass(i)
          end if
       end do
       if (parallel_IOProcessor()) then
          print*, step, ' sum of rho=',sum(mass(1:nspecies))
       end if
    end do

    call destroy(bpt)

  end subroutine sum_mass

  subroutine compute_cov(mla,rho,wit,wiwjt)

    type(ml_layout), intent(in)     :: mla
    type(multifab),  intent(in)     :: rho(:)
    real(kind=dp_t), intent(inout)  :: wit(nspecies)
    real(kind=dp_t), intent(inout)  :: wiwjt(nspecies,nspecies)

    ! local variables
    integer :: n,i,j,dm,nlevs
    integer :: lo(rho(1)%dim), hi(rho(1)%dim)
    real(kind=dp_t), dimension(nspecies) :: cellW, cellW_procavg
    real(kind=dp_t), dimension(nspecies,nspecies) :: cellWij, cellWij_procavg

    ! pointer for rho
    real(kind=dp_t), pointer  :: dp(:,:,:,:)

    type(bl_prof_timer), save :: bpt

    call build(bpt, "compute_cov")

    dm     = mla%dim     ! dimensionality
    nlevs  = mla%nlevel

    cellW_procavg   = 0.d0
    cellWij_procavg = 0.d0
    cellW           = 0.d0
    cellWij         = 0.d0

    ! loop over all boxes
    do n=1,nlevs
       do i=1,nfabs(rho(n))
          dp => dataptr(rho(n),i)
          lo = lwb(get_box(rho(n),i))
          hi = upb(get_box(rho(n),i))

          select case(dm)
          case (2)
             call compute_cov_2d(dp(:,:,1,:),cellW,cellWij,lo,hi)
          case (3)
             call compute_cov_3d(dp(:,:,:,:),cellW,cellWij,lo,hi)
          end select
       end do
    end do

    ! average over all processors
    call parallel_reduce(cellW_procavg, cellW, MPI_SUM)
    do i=1,nspecies
       do j=1, nspecies
          call parallel_reduce(cellWij_procavg(i,j), cellWij(i,j), MPI_SUM)
       end do
    end do

    ! average over total_volume and calculate covW
    wit   = wit   + cellW_procavg/total_volume
    wiwjt = wiwjt + cellWij_procavg/total_volume

    call destroy(bpt)

    end subroutine compute_cov

    subroutine compute_cov_2d(rho,cellW,cellWij,lo,hi)

       integer         :: lo(2), hi(2)
       real(kind=dp_t) :: rho(lo(1):,lo(2):,:)
       real(kind=dp_t) :: cellW(nspecies)
       real(kind=dp_t) :: cellWij(nspecies,nspecies)

       ! local variables
       integer  :: i,j

       ! for specific box, now start loops over alloted cells
       do j=lo(2), hi(2)
          do i=lo(1), hi(1)
             call compute_cov_local(rho(i,j,:),cellW,cellWij)
          end do
       end do

    end subroutine compute_cov_2d

    subroutine compute_cov_3d(rho,cellW,cellWij,lo,hi)

       integer          :: lo(3), hi(3)
       real(kind=dp_t)  :: rho(lo(1):,lo(2):,lo(3):,:)
       real(kind=dp_t)  :: cellW(nspecies)
       real(kind=dp_t)  :: cellWij(nspecies,nspecies)

       ! local variables
       integer :: i,j,k

       ! for specific box, now start loops over alloted cells
       do k=lo(3), hi(3)
          do j=lo(2), hi(2)
             do i=lo(1), hi(1)
                call compute_cov_local(rho(i,j,k,:),cellW,cellWij)
             end do
          end do
       end do

     end subroutine compute_cov_3d

     subroutine compute_cov_local(rho,cellW,cellWij)

       real(kind=dp_t)  :: rho(nspecies)
       real(kind=dp_t)  :: cellW(nspecies)
       real(kind=dp_t)  :: cellWij(nspecies,nspecies)

       ! local variables
       real(kind=dp_t), dimension(nspecies)           :: W
       real(kind=dp_t), dimension(nspecies,nspecies)  :: Wij
       real(kind=dp_t)                                :: rhotot
       integer                                        :: i,j

       type(bl_prof_timer), save :: bpt

       call build(bpt, "compute_cov_local")

       ! calculate total density inside each cell
       rhotot=0.d0
       do i=1, nspecies
          rhotot = rhotot + rho(i)
       end do

       ! calculate mass fraction and sum over cell for each species
       do i=1, nspecies
          W(i)     = rho(i)/rhotot
          cellW(i) = cellW(i) + W(i) ! compute this for average
       end do

       ! calculate Wij=wi*wj matrix and spatial sum over Wij
       do i=1,nspecies
          do j=1, i-1
             Wij(i,j) = W(i)*W(j)
             Wij(j,i) = Wij(i,j)
             cellWij(i,j) = cellWij(i,j) + Wij(i,j)
             cellWij(j,i) = cellWij(j,i) + Wij(j,i)
          end do
          Wij(i,i) = W(i)*W(i)
          cellWij(i,i) = cellWij(i,i) + Wij(i,i)
       end do

       call destroy(bpt)

     end subroutine compute_cov_local

end module analysis_module


      function ilog2(l)
      ilog2 = dlog(real(l, 8))/dlog(2.0d0)
      end

      subroutine f(l, x)
      double precision x
      do i = 1, l
         m = 2**(ilog2(l)-
     +           ilog2(1+int(mod(1013.0d0*3.0d0**x*real(i, 8),
     +                           real(l, 8)))))
         print *, m
      end do
      end

      program main
      read *, l
      call f(l, 3.0d0)
      end


C> \file orrucbl.f
C> \brief Solves Orr-Sommerfeld using method of Deissler
C> \author S. Scott Collis
c***********************************************************************
      program orr_uc_bl
c***********************************************************************
c
c     Purpose:  This program solves the Orr-Sommerfeld equation using a
c               Chebyshev-collocation method.
c
c     Version:  This version solves the boudary layer problem with
c               algebraic mapping and allows for moving reference frame
c               so as to determine absolute/convective instability like
c               Deissler.
c
c     Author:   S. Scott Collis
c
c     Date:     3-14-92
c
c     Revision: 9-18-92
c
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap, uorg(0:idim)
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim), uc
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,uc,uorg,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      integer     nar, nai, ians
      real        alphar(100), alphai(100), delta
      real        minar, maxar, incar, minai, maxai, incai, dar, dai
      complex     eigenvalue(100), eigenvector(0:idim), ctemp, A, B
      complex     alp(3), as, oldeig(3,100), fd
      real        oldeigr1, oldeigi1
      real        oldeigr2, oldeigi2
      character*9 filename
      logical     print
c***********************************************************************
c
c     Setup IMSL workspace
c
#ifdef USE_IMSL
      REAL             RWKSP(100000)
      COMMON /WORKSP/  RWKSP
      call IWKIN(100000)
#endif
c
c     User input
c
      write (*,10)
  10  format (/,/,10x,'Solve Orr-Sommerfeld (Collocation)')
      write (*,20)
  20  format (/,1x,'Enter the number of modes ==> ',$)
      read (*,*) n
      write (*,30)
  30  format (/,1x,'Enter Reynolds number ==> ',$)
      read (*,*) Re
      write (*,65)
  65  format (/,1x,'Enter reference frame velocity u_c ==> ',$)
      read (*,*) uc
      Lmap = 2.0
      write (*,40)
  40  format (/,1x,'Enter alpha_1 (r,i) ==> ',$)
      read (*,*) alphar(1),alphai(1)
      write (*,45)
  45  format (/,1x,'Enter delta ==> ',$)
      read (*,*) delta
      write (*,46)
  46  format (/,1x,'Enter deltau ==> ',$)
      read (*,*) deltau
      write (*,50)
  50  format (/,1x,'New run (1/0) ==> ',$)
      read (*,*) irun
      if (irun.eq.0) then
        write (*,70)
  70    format (/,1x,'Enter oldeig1 (r,i) ==> ',$)
        read (*,*) oldeigr1,oldeigi1
        write (*,85)
  85    format (/,1x,'Enter oldeig2 (r,i) ==> ',$)
        read (*,*) oldeigr2,oldeigi2
        do i = 1, 3
          oldeig(i,1) = CMPLX(oldeigr1,oldeigi1)
          oldeig(i,2) = CMPLX(oldeigr2,oldeigi2)
        end do
        istart = 3
      else
        istart = 1
      end if

      alphar(2) = alphar(1) + delta
      alphar(3) = alphar(1) - delta
      alphai(2) = alphai(1) - delta
      alphai(3) = alphai(1) - delta
      ians = 0
      if (ians.eq.1) then
         print = .true.
      else
         print = .false.
      end if

      call MAKE_DERIVATIVES
      call MAKE_BL_METRICS
      call INIT_BL_PROFILE
      as = cmplx(10,10)

      do k = istart, 40+istart-1

        resid = 10.
        if (k .le. 2)  then
          do i = 1, 3
            oldeig(i,k) = 999.
          end do
        else
          do i = 1, 3
            fd = (oldeig(i,k-1)-oldeig(i,k-2))/deltau
            oldeig(i,k) = oldeig(i,k-1) + fd*deltau
          end do
        end if
        call SHIFT_BL
        icount = 0
        do while (abs(resid) .gt. 1e-7 )
          icount = icount + 1
          do i = 1, 3
            aso = as
            alpha = cmplx (alphar(i), alphai(i))
            alp(i) = alpha
            call MAKE_MATRIX
            ctemp = oldeig(i,k)
            call SOLVE(ctemp, eigenvector, print)
            eigenvalue(i) = ctemp
            oldeig(i,k) = ctemp
c           write (*,60)  real(alpha),aimag(alpha),real(eigenvalue(i)),
c    .                    aimag(eigenvalue(i))
  60        format (1x,4(e17.10,4x))
          end do
          A  = cmplx(0.,-1.)*(eigenvalue(2)-eigenvalue(1))
          B  = cmplx(0.,-1.)*(eigenvalue(3)-eigenvalue(1))
          as = (A*(alp(3)**2-alp(1)**2)-B*(alp(2)**2-alp(1)**2))/
     .         (2.*B*(alp(1)-alp(2))-2.*A*(alp(1)-alp(3)))
          resid = as-aso
          if (k .eq. 1 .or. icount .gt. 5) then
            write (*,80) real(as),aimag(as), abs(resid)
  80        format (1x,'==> ',3(e17.10,4x))
          end if
          alphar(1) = real(as)
          alphai(1) = aimag(as)
          alphar(2) = alphar(1) + delta
          alphar(3) = alphar(1) - delta
          alphai(2) = alphai(1) - delta
          alphai(3) = alphai(1) - delta
        end do
        write (*,90)  uc, real(eigenvalue(1)),
     .                aimag(eigenvalue(1)),
     .                real(as),aimag(as)
 90     format (1x,f6.4,2x,4(e17.10,4x))
        uc = uc - deltau
      end do

      stop
      end

C***********************************************************************
      subroutine MAKE_DERIVATIVES
C***********************************************************************
C
C     Make the required matrices that take derivatives in Chebyshev
C     space
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap, uorg(0:idim)
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim), uc
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,uc,uorg,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      integer  m, p, LDD, i, j, k
      real     Identity(0:idim,0:idim), D1hat(0:idim,0:idim)

      LDD = idim
      call CHEBYD (D1hat, LDD, n)
      call CHEBYD (D1   , LDD, n)
c
c     We enforce the Neumann boundary conditions indirectly by setting
c     v' = 0 at 0 and n.  NOTE THAT D1-D4 SHOULD ONLY BE APPLIED TO THE
c     v FIELD ONLY.
c
      do i = 0, n
        D1(0,i) = 0.0
        D1(N,i) = 0.0
      end do
C
C     To get higher derivatives just do matrix multiplication
C
      do i = 0, n
        do j = 0, n
          D2(i,j) = 0.0
          do k = 0, n
            D2(i,j) = D2(i,j) +  D1hat(i,k)*D1(k,j)
          end do
        end do
      end do
      do i = 0, n
        do j = 0, n
          D3(i,j) = 0.0
          do k = 0, n
            D3(i,j) = D3(i,j) +  D1hat(i,k)*D2(k,j)
          end do
        end do
      end do
      do i = 0, n
        do j = 0, n
          D4(i,j) = 0.0
          do k = 0, n
            D4(i,j) = D4(i,j) +  D1hat(i,k)*D3(k,j)
          end do
        end do
      end do

c      CALL WRRRN ('D1', N+1, N+1, D1, LDd+1, 0)
c      CALL WRRRN ('D2', N+1, N+1, D2, LDd+1, 0)
c      CALL WRRRN ('D3', N+1, N+1, D3, LDd+1, 0)
c      CALL WRRRN ('D4', N+1, N+1, D4, LDd+1, 0)

      return
      end

C***********************************************************************
      subroutine MAKE_BL_METRICS
C***********************************************************************
C
C     Setup the collocation points in the mapped coordinate, eta and in
C     chebyshev space, th.  Also compute the transformation metrics.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap, uorg(0:idim)
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim), uc
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,uc,uorg,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      real       pi, dth
      integer    i

      pi  = ACOS(-1.0)
      dth = pi/FLOAT(n)
c
c     Make mesh in transformed, eta, and Chebyshev space, th
c
      do i = 0, n
        th(i) = FLOAT(i)*dth
        eta(i) = COS(th(i))
      end do
c
c     Make transformation metrics
c
      do i = 0, n
        m1(i) = (eta(i)-1.)**2/(2.*Lmap)
        m2(i) = (eta(i)-1.)**3/(2.*Lmap**2)
        m3(i) = 3.*(eta(i)-1.)**4/(4.*Lmap**3)
        m4(i) = 3.*(eta(i)-1.)**5/(2.*Lmap**4)
        if (i.eq.0) then
          c(i) = 2.
        else
          c(i) = 1.
        end if
      end do

      return
      end

C***********************************************************************
      SUBROUTINE FUNCD(X,F,DF)
C***********************************************************************
      REAL          X, ETA, GAMMA, ETAOUT
      COMMON        /map/  ETA

      GAMMA = 1.2
      ETAOUT  = 15.0

      F = ETAOUT*(1.-TANH(GAMMA))/2.*(X+1)/
     .           (1.-TANH(GAMMA/2.*(X+1)))-ETA
      A = ETAOUT/2.*(1-TANH(GAMMA))
      B = GAMMA/2.
      DF = A/2.*(1.+EXP(2.*B*(1.+X)) + 2.*B*EXP(2.*B*(1.+X)) +
     .           2.*B*EXP(2.*B*(1.+X))*X)
      RETURN
      END

C***********************************************************************
      subroutine INIT_BL_PROFILE
C***********************************************************************
C
C     Setup the initial BL profile
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap, uorg(0:idim)
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim), uc
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,uc,uorg,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      parameter     (nu = 64)
      real          utemp(0:nu),utemp1(0:nu),utemp2(0:nu),junk, pi
      real          gamma, yout, y, x, xi, IU, IV, IW
      integer       nmode, i, merge
      character*15  filename
      integer       LDD
      real          D1hat(0:idim,0:idim), D2hat(0:idim,0:idim)

      common        /map/  x

      pi = ACOS(-1.0)
      LDD = idim
      gamma = 1.2
      xout  = 15.0

      write (*,5)
   5  format (/,1x,'Read Mean Profile',/)
      write (*,9)
   9  format (1x,'Enter filename ==> ',$)
      read (*,'(a)') filename
      open (unit=11,file=filename,status='unknown')

      read (11,*) nmode
      do i = 0, nmode
        read (11,*) y,utemp(i),junk
      end do
      close (11)
c
c     I need to spectrally interpolate this profile onto the new grid.
c
      call CHEBYSHEV (utemp,nmode,1)
c
c     y is nondimensionalized by dr = sqrt(2*x*nu/u_inf)
c
      i = n
      y = Lmap*(1.+eta(i))/(1.-eta(i))
      do while (y/sqrt(2.) .le. xout)
        u(i) = 0.0
        X = Y/SQRT(2.)
        xi = RTNEWT(-2.,2.2,1e-12,FUNCD)
        do m = 0, nmode
          u(i) = u(i)+utemp(m)*COS(float(m)*ACOS(xi))
        end do
        i = i - 1
        y = Lmap*(1.+eta(i))/(1.-eta(i))
      end do
      merge = i
c      write (*,11) merge
  11  format(/,1x,'Merging at i = ',i4)
      do j = merge, 0, -1
        u(j) = 1.0
      end do
c
c     Compute the collocation derivatives
c
      call CHEBYD (D1hat, LDD, n)
      do i = 0, n
        do j = 0, n
          D2hat(i,j) = 0.0
          do k = 0, n
            D2hat(i,j) = D2hat(i,j) +  D1hat(i,k)*D1hat(k,j)
          end do
        end do
      end do
      do i = 0, n
        d1u(i) = 0.0
        d2u(i) = 0.0
        do k = 0, n
            d1u(i) = d1u(i) + D1hat(i,k)*u(k)
            d2u(i) = d2u(i) + D2hat(i,k)*u(k)
        end do
        Uorg(i) = u(i)
      end do
c
c     Ensure that the derivatives are zero when they are supposed to be.
c
      do j = merge-2, 0, -1
        d1u(j) = 0.0
        d2u(j) = 0.0
      end do
c
c      call CHEBYSHEV (U,n,1)
c      call CHEBYSHEV (d1u,n,1)
c      call CHEBYSHEV (d2u,n,1)
c
c      do i = 0, 256
c        X = float(I)*PI/256
c        IU = 0.0
c        IV = 0.0
c        IW = 0.0
c        DO M = 0, N
c          IU = IU +   U(M)*COS(FLOAT(M)*X)
c          IV = IV + d1u(M)*COS(FLOAT(M)*X)
c          IW = IW + d2u(M)*COS(FLOAT(M)*X)
c        END DO
c        write (*,10) cos(x),Iu,Iv,Iw
c      end do
c
c      call CHEBYSHEV (U,n,-1)
c      call CHEBYSHEV (d1u,n,-1)
c      call CHEBYSHEV (d2u,n,-1)

      return
      end
C***********************************************************************
      subroutine SHIFT_BL
C***********************************************************************
C
C     Shift the boundary layer profile to a new frame of reference.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap, uorg(0:idim)
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim), uc
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,uc,uorg,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
c
c     Need to interpolate the velocity profile to evaluate it at
c     arbitrary y
c
      do i = 0, n
        U(i) = Uorg(i) - Uc
      end do

      return
      end
C***********************************************************************
      subroutine MAKE_MATRIX
C***********************************************************************
C
C     This routine generates the matrices which are combined to make
C     the generalized eigenvalue problem.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap, uorg(0:idim)
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim), uc
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,uc,uorg,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      real      identity(0:idim,0:idim)
      complex   work, ai

      do i = 0, n
        do j = 0, n
          A4(i,j) = 0.0
          A3(i,j) = 0.0
          A2(i,j) = 0.0
          A1(i,j) = 0.0
          B2(i,j) = 0.0
          B1(i,j) = 0.0
          B0(i,j) = 0.0
          identity(i,j) = 0.0
        end do
        identity(i,i) = 1.0
      end do
C
C     Include the independent variable transformation metrics
C
      do i = 0, n
        work = m1(i)**4
        do j = 0, n
          A4(i,j) = work*D4(i,j)
        end do
      end do

      do i = 0, n
        work = 6.*m1(i)**2*m2(i)
        do j = 0, n
          A3(i,j) = work*D3(i,j)
        end do
      end do

      do i = 0, n
        work = 3.*m2(i)**2+4.*m1(i)*m3(i)-2.*alpha**2*m1(i)**2-
     .         cmplx(0.,1.)*alpha*Re*U(i)*m1(i)**2
        do j = 0, n
          A2(i,j) = work*D2(i,j)
        end do
      end do

      do i = 0, n
        work = m4(i)-2.*alpha**2*m2(i)-cmplx(0.,1.)*alpha*Re*U(i)*m2(i)
        do j = 0, n
          A1(i,j) = work*D1(i,j)
        end do
      end do

      do i = 0, n
        work = alpha**4+cmplx(0.,1.)*alpha**3*Re*U(i)+
     .         cmplx(0.,1.)*alpha*Re*(d2u(i)*m1(i)**2+d1u(i)*m2(i))
        do j = 0, n
          A0(i,j) = work*identity(i,j)
        end do
      end do

      do i = 0, n
        work = -1.0*cmplx(0.,1.)*Re*m1(i)**2
        do j = 0, n
          B2(i,j) = work*D2(i,j)
        end do
      end do

      do i = 0, n
        work = -1.0*cmplx(0.,1.)*Re*m2(i)
        do j = 0, n
          B1(i,j) = work*D1(i,j)
        end do
      end do

      do i = 0, n
        work = cmplx(0.,1.)*alpha**2*Re
        do j = 0, n
          B0(i,j) = work*identity(i,j)
        end do
      end do

      return
      end
C***********************************************************************
      function CHECKEIG(N,A,LDA,EVAL,EVEC)
C***********************************************************************
C
C     Check an eigenvalue and eigenvector
C
C***********************************************************************
      integer    N
      complex    A(LDA,N), EVAL, EVEC(N)
      complex    X(N), Y(N)
      real       CHECKEIG
#ifdef USE_IMSL
      CALL MUCRV (N, N, A, LDA, N, EVEC, 1, N, X)
#else
      CALL ZGEMV ('N', N, N, 1.0, A, LDA, EVEC, 1, 0.0, X, 1)
#endif
      CHECKEIG = 0.0
      DO I = 1, N
        CHECKEIG = CHECKEIG + ABS(X(I)-EVAL*EVEC(I))
      END DO
      CHECKEIG = CHECKEIG/FLOAT(N)

      RETURN
      END
C***********************************************************************
      subroutine HTRAN(N,A,B,LD)
C***********************************************************************
C
C     Take the complex conjugate transpose of A and put it in B
C
C***********************************************************************
      integer    N, LD
      complex    A(LD,N), B(LD,N)

      do i = 1, N
        do j = 1, N
          B(j,i) = CONJG(A(i,j))
        end do
      end do

      RETURN
      END
C***********************************************************************
      subroutine CXDOTY (N,X,Y,C)
C***********************************************************************
C
C     Take the complex conjugate dot product of vector x and y
C
C***********************************************************************
      integer    N
      complex    X(N), Y(N), C

      C = CMPLX (0.0,0.0)
      do I = 1, N
        C = C + CONJG(X(I))*Y(I)
      end do

      RETURN
      END
C***********************************************************************
C               S O L V E   O R R   S O M M E R F E L D
C***********************************************************************
      subroutine SOLVE(eigenvalue,eigenvector,print)
C***********************************************************************
C
C     This routine generates the discrete eigenvalue problem in
C     Chebyshev space for the Orr-Sommerfeld equation.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (idim=256)
      integer     n
      real        eta(0:idim), th(0:idim), lmap, uorg(0:idim)
      real        m1(0:idim), m2(0:idim), m3(0:idim), m4(0:idim), uc
      real        c(0:idim), u(0:idim), d1u(0:idim), d2u(0:idim), Re
      real        D1(0:idim,0:idim), D2(0:idim,0:idim)
      real        D3(0:idim,0:idim), D4(0:idim,0:idim)
      complex     A1(0:idim,0:idim), A2(0:idim,0:idim)
      complex     A3(0:idim,0:idim), A4(0:idim,0:idim)
      complex     A0(0:idim,0:idim), B0(0:idim,0:idim)
      complex     B1(0:idim,0:idim), B2(0:idim,0:idim)
      complex     dA2(0:idim,0:idim), dA1(0:idim,0:idim)
      complex     dA0(0:idim,0:idim), dB0(0:idim,0:idim)
      complex     v(0:idim), alpha, omega(0:idim)
      character*1 type

      common      /data/   n,eta,th,m1,m2,m3,m4,c,u,d1u,d2u,Re,v,
     .                     alpha,omega,uc,uorg,type
      common      /deriv/  D1,D2,D3,D4,lmap
      common      /matrix/ A4, A3, A2, A1, A0, B2, B1, B0, dA2, dA1,
     .                     dA0, dB0
c***********************************************************************
      complex     A(0:idim,0:idim), B(0:idim,0:idim)
      complex     dA(0:idim,0:idim), dB(0:idim,0:idim)
      complex     T1(0:idim,0:idim), T2(0:idim,0:idim)
      complex     T3(0:idim,0:idim), T4(0:idim,0:idim)

      complex     eval(0:idim), evec(0:idim,0:idim), tvec(0:idim)
      complex     aeval(0:idim), aevec(0:idim,0:idim), tavec(0:idim)

      complex     eigenvalue, eigenvector(0:idim)
      complex     dwda, dw, dalp, y(0:idim), prod

      real        temp1(0:idim), temp2(0:idim), residual, CHECKEIG, min
      real        temp3(0:idim), temp4(0:idim), dalpha, diff(0:idim)

      integer     lda, ldb, ldevec, p, i, j, which, k, l, m
      integer     index(0:idim), index2(0:idim)
      logical     first, print
      external    CHECKEIG
C***********************************************************************
      lda = idim+1
      ldb = idim+1
      ldevec = idim+1

      do i = 1, n-1
        do j = 1, n-1
          A(i-1,j-1) = A4(i,j)+A3(i,j)+A2(i,j)+A1(i,j)+A0(i,j)
          B(i-1,j-1) = B2(i,j)+B1(i,j)+B0(i,j)
        end do
      end do
c
c     Now enforce the v = 0 @ +_ 1 boundary condition instead of the
c     Orr-Sommerfeld equation at n = 0 and n = N.  The Neumann
c     boundary condition is implicitly enforced.
c
c      do j = 0, n
c        B(0,j) = CMPLX(0.0, 0.0)
c        B(n,j) = CMPLX(0.0, 0.0)
c        A(0,j) = CMPLX(0.0, 0.0)
c        A(n,j) = CMPLX(0.0, 0.0)
c      end do
c      A(0,0) = CMPLX(1.0, 0.0)
c      A(n,n) = CMPLX(1.0, 0.0)
c
c     But the top and bottom rows are trivial so that they can be
c     removed
c
#ifdef USE_IMSL
      write(*,*) "Solving Eigenvalue Problem with IMSL interface"
      CALL LINCG (N-1, B, LDA, T1, LDA)
      CALL MCRCR (N-1, N-1, T1, LDA, N-1, N-1, A, LDA,
     .            N-1, N-1, T4, LDA)

      CALL EVCCG (N-1, T4, LDA, eval, evec, ldevec)
#else
      write(*,*) "Solving Eigenvalue Problem with new LAPACK interface"
      LWORK = 2*(N-1)
      INFO = 0
      CALL ZLACPY('A', N-1, N-1, B, LDA, T1, LDA)
      CALL ZGETRF(N-1, N-1, T1, LDA, IPIV, INFO)
      CALL ZGETRI(N-1, T1, LDA, IPIV, WORK, LWORK, INFO)
      CALL ZGEMM ('N','N',N-1,N-1,N-1,1.0,T1,LDA,A,LDA,0.0,T4,LDA)
      CALL ZGEEV ('N','V',N-1, T4, LDA, eval, VL, LDVL, evec, ldevec,
     .            WORK, LWORK, RWORK, INFO)
#endif
c
      do i = 0, N-2
        temp1(i) = REAL(eval(i))
        temp2(i) = AIMAG(eval(i))
      end do

c     Need to issolate the most unstable eigenvalue and eigenvector
c     Must watch out, this routine isn't very robust.

      do i = 0,N-2
        index(i) = i
      end do
      call PIKSR2(n-1,temp2,index)

      min = 10000.
      do i = 0, n-2
        temp1(i) = REAL(eval(index(i)))
        if ( ABS(ABS(eigenvalue)-ABS(cmplx(temp1(i),temp2(i))))
     .      .le. min ) then
          iloc = i
          min = ABS(ABS(eigenvalue)-ABS(cmplx(temp1(i),temp2(i))))
        end if
      end do

      if (ABS(eigenvalue).gt.99.) then
        eigenvalue = cmplx(temp1(n-2),temp2(n-2))
        iloc = n-2
      else
        eigenvalue = cmplx(temp1(iloc),temp2(iloc))
      end if

c     write (*,*) 'Eigenvalue at ',iloc
      eigenvector(0) = cmplx(0.0,0.0)
      eigenvector(n) = cmplx(0.0,0.0)

      do j = 1, n-1
        eigenvector(j) = evec(j-1,index(iloc))
        tvec(j-1)  = evec(j-1,index(iloc))
      end do

      residual = CHECKEIG (N-1,T4,lda,eigenvalue,tvec)
      if (residual .gt. .01) then
        write (*,*) 'WARNING eigenvalue not converged!'
      end if

      if (print) then
        write (*,100) residual
 100    format (/,1x,'Residual = ',e17.10)
        write (*,31) Re, real(alpha), aimag(alpha)
        write (*,32)
        do i = n-2,0,-1
          write (*,37) REAL(eval(index(i))/alpha),
     .                 AIMAG(eval(index(i))/alpha),index(i)
c          write (20,37) REAL(eval(index(i))),AIMAG(eval(index(i))),
c     .                  REAL(aeval(index(i))),AIMAG(aeval(index(i))),
c     .                  index(i)
        end do
        write (*,40)
        read (*,*) which
          do while (which .ne. 0)
          temp1(0) = 0.0
          temp2(0) = 0.0
          temp1(n) = 0.0
          temp2(n) = 0.0
          temp3(0) = 0.0
          temp4(0) = 0.0
          temp3(n) = 0.0
          temp4(n) = 0.0
          do j = 1, n-1
            temp1(j) = REAL(evec(j-1,index(iloc)))
            temp2(j) = AIMAG(evec(j-1,index(iloc)))
            temp3(j) = REAL(aevec(j-1,index(iloc)))
            temp4(j) = AIMAG(aevec(j-1,index(iloc)))
          end do
c          do j = 0, n
c            write (*,38) eta(j),temp1(j),temp2(j),temp3(j),temp4(j)
c          end do
          write (*,*)
          call CHEBYINT (n, temp1, temp2, 128)
c          write (*,*)
c          call CHEBYINT (n, temp3, temp4, 128)
          write (*,40)
          read (*,*) which
        end do
      end if

 31   format(/,1x,3(e17.10,4x))
 32   format(/,1x,'       w_r                w_i              count',/)
 35   format(1x,2(e17.10,4x),i5)
 36   format(1x,2(e17.10,4x))
 37   format(1x,2(e17.10,2x),i5)
 38   format(1x,5(e15.8,1x))
 40   format(/,1x,'Eigenvector for which eigenvalue (0 quits) ==> ',$)
 55   format(/,1x,'Performance Index = ',g12.5,/)

      return
      end

C***********************************************************************
      SUBROUTINE DCHEBYSHEV(N, Y, DY)
C***********************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued
C     data points and compute the derivative in Chebyshev space.
C     Then inverse transform and return the derivative in DY in real
C     space.  Note that Y is returned unscathed.
C
C***********************************************************************
      INTEGER N
      REAL Y(0:N), DY(0:N)

      PARAMETER (idim=256)
      REAL WORK(0:IDIM)

      IF (N.GT.IDIM) THEN
        WRITE (*,*) 'ERROR.  N > IDIM in DCHEBYSHEV'
        STOP
      END IF
C
C     SAVE THE INPUT VECTOR
C
      DO I = 0, N
        WORK(I) = Y(I)
      END DO
C
C     COMPUTE THE CHEBYSHEV TRANSFORM
C
      CALL CHEBYSHEV(Y,N,1)
C
C     NOW USE THE RECURSIVE RELATION TO TAKE THE DERIVATIVE
C
      DY(N) = 0.0
      DY(N-1) = 2.*FLOAT(N)*Y(N)
      DO K = N-2, 0, -1
        DY(K) = DY(K+2) + 2.*(K+1.)*Y(K+1)
      END DO
      DY(0) = DY(0)/2.
C
C     INVERSE TRANSFORM TO GET BACK TO REAL SPACE
C
      CALL CHEBYSHEV(DY,N,-1)

      DO I = 0, N
        Y(I) = WORK(I)
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE ICHEBYSHEV(Y,YI,N)
C***********************************************************************
C
C     Calculate the Chebyshev transform of a set Y of N+1 real-valued
C     data points and integrate in Chebyshev space.  The integral is
C     returned in real space in YI and Y is unscathed.
C
C***********************************************************************
      REAL Y(0:N), YI(0:N+1)
      PARAMETER (idim=256)
      REAL WORK(0:IDIM)

      DO I = 0, N
        WORK(I) = Y(I)
      END DO
C
C     COMPUTE THE CHEBYSHEV TRANSFORM
C
      CALL CHEBYSHEV(Y,N,1)
C
C     NOW INTEGRATE
C     NOTE I AM ASSUMING THAT Y(N) IS SMALL SUCH THAT YI(N+1) = 0.0
C
      YI(N+1) = Y(N)/(2.*(N+1.))
      YI(N) = Y(N-1)/(2.*N)
      YI(1) = 1./2.*(2.*Y(0)-Y(2))
      YI(0) = YI(1)
      DO K = 2, N-1
        YI(K) = 1./(2.*K)*(Y(K-1)-Y(K+1))
        YI(0) = YI(0) + (-1.)**(K-1)*YI(K)
      END DO

      CALL CHEBYSHEV(YI,N,-1)
      DO I = 0, N
        Y(I) = WORK(I)
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE CHEBYINT(nmode,U,V,NBIG)
C***********************************************************************
C
C     Interpolate two functions to a finer mesh
C
c***********************************************************************
      INTEGER   NBIG, nmode
      REAL      U(0:Nmode), V(0:Nmode)
      REAL      IU, IV, X, PI

      PI = ACOS(-1.0)

      call CHEBYSHEV (U,nmode,1)
      call CHEBYSHEV (V,nmode,1)

      do i = 0, NBIG
        X = I*PI/NBIG
        IU = 0.0
        IV = 0.0
        DO M = 0, Nmode
          IU = IU + U(M)*COS(FLOAT(M)*X)
          IV = IV + V(M)*COS(FLOAT(M)*X)
        END DO
        write (*,10) cos(x),Iu,Iv
      end do
  10  format (1x,3(e16.8,4x))

      RETURN
      END

C***********************************************************************
      SUBROUTINE COSFT3 (Y,N,ISIGN)
C***********************************************************************
C
C     Do a brute force transform.  ISIGN = 1 does a forward transform.
C     ISIGN = -1 a backward transform.  This is a hybrid double/single
C     precision routine.
C
C***********************************************************************
      integer     N, ISIGN
      real        Y(0:N), T(0:N)
      real*16     YY(0:N), TT(0:N), PI

      PI = DACOS(-1.0D0)

      DO I = 0, N
        TT(I) = DBLE(Y(I))
      END DO

      if (isign .eq. 1) then
        DO I = 0, N
          YY(I) = TT(0)/2.D0 + TT(N)*DCOS(DFLOAT(I)*PI)/2.D0
          DO M = 1, N-1
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
          YY(I) = YY(I)*2./DFLOAT(N)
        end do
        YY(0) = YY(0)/2.D0
        YY(N) = YY(N)/2.D0
      else
        DO I = 0, N
          YY(I) = 0.0
          DO M = 0, N
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
        END DO
      end if
C
C     GO BACK TO SINGLE PRECISION
C
      DO I = 0, N
        if (Y(i).le.1e-14) then
          Y(I) = 0.0
        end if
        Y(I) = SNGL(YY(I))
      END DO

      RETURN
      END

C***********************************************************************
      subroutine CHEBYSHEV (Y, N, ISIGN)
C***********************************************************************
C
C     Take the Chebyshev transform and normalize
C
C***********************************************************************
      integer  n, isign
      real     y(0:n), t(0:256)

      if (isign .ne. 1) then
        if (isign .ne. -1) then
          write (*,*) 'ERROR:  Invalid Isign in CHEBYSHEV'
          stop
        end if
      end if

      do i = 1, n
        t(i) = y(i)
      end do

      call COSFT3 (y,n,isign)

c     call COSFT (y,n,isign)

c     if (isign .eq. 1) then
c       do i = 0,n
c         y(i) = y(i)/float(n)*2.
c       end do
c     end if

      return
      end

C***********************************************************************
      subroutine CONVOLVE (NDIM, A, B, LDB, ES, LDE, C)
C***********************************************************************
C
C     Form the Chebyshev convolution of real vector A with real matrix B
C     and put the result in real matrix E.
c
c     A  double
c     B  double
c     ES single
C
C***********************************************************************
      INTEGER NDIM, LDB, LDE
      REAL    ES(0:LDE,0:NDIM), C(0:NDIM)
      REAL*16 A(0:NDIM),  B(0:LDB,0:NDIM),  E(0:LDE,0:NDIM)

      call COSFT3D (A,NDIM,1)

      DO N = 0, NDIM
        DO J = 0, NDIM
          E(N,J) = 0.0D0
        END DO
        DO M = -NDIM, NDIM
          IF (ABS(N-M).LE.NDIM) THEN
            DO J = 0, NDIM
              E(N,J) = E(N,J)+ DBLE(C(ABS(N-M))) * A(ABS(N-M)) *
     .                         DBLE(C(ABS(M)))   * B(ABS(M),J)
            END DO
          END IF
        END DO
        DO J = 0, NDIM
          E(N,J) = E(N,J)/2.D0
        END DO
      END DO
      DO J = 0, NDIM
        E(0,J) = E(0,J)/2.D0
      END DO

      DO N = 0, NDIM
        DO J = 0, NDIM
          ES(N,J) = SNGL(E(N,J))
        END DO
      END DO

      RETURN
      END

C***********************************************************************
      SUBROUTINE COSFT3D (YY,N,ISIGN)
C***********************************************************************
C
C     Do a brute force transform.  ISIGN = 1 does a forward transform.
C     ISIGN = -1 a backward transform.  This one is fully double
C     precision.
C
C***********************************************************************
      integer     N, ISIGN
      real*16     YY(0:N), TT(0:N), PI

      PI = DACOS(-1.0D0)

      DO I = 0, N
        TT(I) = YY(I)
      END DO

      if (isign .eq. 1) then
        DO I = 0, N
          YY(I) = TT(0)/2.D0 + TT(N)*DCOS(DFLOAT(I)*PI)/2.D0
          DO M = 1, N-1
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
          YY(I) = YY(I)*2./DFLOAT(N)
        end do
        YY(0) = YY(0)/2.D0
        YY(N) = YY(N)/2.D0
      else
        DO I = 0, N
          YY(I) = 0.0
          DO M = 0, N
            YY(I) = YY(I) + TT(M)*DCOS(DFLOAT(M)*DFLOAT(I)*PI/DFLOAT(N))
          END DO
        END DO
      end if

      RETURN
      END

C***********************************************************************
      SUBROUTINE CHEBYD (D, LDD1, N)
C***********************************************************************
C
C     Calculation the Chebyshev collocation derivative matrix
C
C***********************************************************************
      PARAMETER (IDIM=256)
      REAL      D(0:LDD1,0:N), PI
      REAL      C(0:IDIM)

      IF (N .GT. IDIM) THEN
        WRITE (*,*) 'ERROR:  N > IDIM in CHEBYD'
        STOP
      END IF

      PI = ACOS(-1.0)

      DO I = 1, N-1
        C(I) = 1.0
      END DO
      C(0) = 2.0
      C(N) = 2.0

      DO J = 0, N
        DO K = 0, N
          IF ( J.EQ.0 .AND. K.EQ.0) THEN
            D(J,K) = (2.0*FLOAT(N)**2+1.0)/6.0
          ELSE IF ( J.EQ.N .AND. K.EQ.N) THEN
            D(J,K) = -1.0*(2.*FLOAT(N)**2+1.0)/6.0
          ELSE IF (J.EQ.K) THEN
            D(J,K) =  -1.0*COS(FLOAT(J)*PI/FLOAT(N))/
     .                (2.*(1.-(COS(FLOAT(J)*PI/FLOAT(N)))**2))
          ELSE
            D(J,K) = C(J)*(-1.0)**(J+K)/(C(K)*(COS(FLOAT(J)*PI/
     .               FLOAT(N))-COS(FLOAT(K)*PI/FLOAT(N))))
          END IF
        END DO
      END DO

      RETURN
      END


      subroutine snlm (lmaxp1, mmaxp1)
      implicit double precision(a-h,o-z)

c     Set nlm, legendre normalization factors, xnlm in common /nlm/
c     Calculates legendre norm factors
c     xnlm= sqrt ((2l+1)(l-m)!/(l+m)!)

      include 'dim.h'
      include 'nlm.h'

c     flg(i) = i! * afac**i, set in factst
      dimension flg(0:210)

      call factst (afac, flg)

c     initialize xnlm explicitly
      do 5  il = 1, ltot+1
      do 5  im = 1, mtot+1
         xnlm(il,im) = 0
    5 continue

      do 10  il = 1, lmaxp1
         mmxp1 = min (mmaxp1, il)
         do 10  im = 1, mmxp1
            l = il-1
            m = im-1
            cnlm = (2*l+1) * flg(l-m) / flg(l+m)
            cnlm = sqrt(cnlm) * afac**m
            xnlm(il,im) = cnlm
   10 continue

      return
      end
      subroutine factst (afac, flg)
      implicit double precision (a-h,o-z)

c     FACTorial SeT, flg(i) = i! * afac**i
      dimension flg(0:210)

c     afac = 1/64 works with double precision on a VAX
      afac = 1./64.

      flzero = 1
      flg(0) = 1
      flg(1) = afac

      do 10  i = 2, 210
   10 flg(i) = flg(i-1) * i * afac

      return
      end


c> \file bmv.f

c> \brief This subroutine computes the product of the 2m x 2m middle matrix
c>        in the compact L-BFGS formula of B and a 2m vector v.
c>
c> This subroutine computes the product of the 2m x 2m middle matrix
c> in the compact L-BFGS formula of B and a 2m vector v;
c> it returns the product in p.
c>
c> @param m On entry m is the maximum number of variable metric corrections
c>             used to define the limited memory matrix.

c>          On exit m is unchanged.
c>
c> @param sy On entry sy specifies the matrix S'Y.

c>           On exit sy is unchanged.
c>
c> @param wt On entry wt specifies the upper triangular matrix J' which is
c>              the Cholesky factor of (thetaS'S+LD^(-1)L').

c>           On exit wt is unchanged.
c>
c> @param col On entry col specifies the number of s-vectors (or y-vectors)
c>               stored in the compact L-BFGS formula.

c>            On exit col is unchanged.
c>
c> @param v On entry v specifies vector v.

c>          On exit v is unchanged.
c>
c> @param p On entry p is unspecified.

c>          On exit p is the product Mv.
c>
c> @param info On entry info is unspecified.

c>             On exit info =

0       for normal return,

c>
nonzero for abnormal return when the system
c>                                    to be solved by dtrsl is singular.

      subroutine bmv(m, sy, wt, col, v, p, info)

      integer m, col, info
      double precision sy(m, m), wt(m, m), v(2*col), p(2*col)

c
c                           *  *  *
c
c     NEOS, November 1994. (Latest revision June 1996.)
c     Optimization Technology Center.
c     Argonne National Laboratory and Northwestern University.
c     Written by
c                        Ciyou Zhu
c     in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
c
c
c     ************

      integer          i,k,i2
      double precision sum

      if (col .eq. 0) return

c     PART I: solve [  D^(1/2)      O ] [ p1 ] = [ v1 ]
c                   [ -L*D^(-1/2)   J ] [ p2 ]   [ v2 ].

c       solve Jp2=v2+LD^(-1)v1.
      p(col + 1) = v(col + 1)
      do 20 i = 2, col
         i2 = col + i
         sum = 0.0d0
         do 10 k = 1, i - 1
            sum = sum + sy(i,k)*v(k)/sy(k,k)
  10     continue
         p(i2) = v(i2) + sum
  20  continue
c     Solve the triangular system
      !call dtrsl(wt,m,col,p(col+1),11,info)
      call dtrsm('l','u','t','n',col,1,one,wt,m,p(col+1),col)
      info = 0
      !if (info .ne. 0) return

c       solve D^(1/2)p1=v1.
      do 30 i = 1, col
         p(i) = v(i)/sqrt(sy(i,i))
  30  continue

c     PART II: solve [ -D^(1/2)   D^(-1/2)*L'  ] [ p1 ] = [ p1 ]
c                    [  0         J'           ] [ p2 ]   [ p2 ].

c       solve J^Tp2=p2.
      !call dtrsl(wt,m,col,p(col+1),01,info)
      !if (info .ne. 0) return
      call dtrsm('l','u','n','n',col,1,one,wt,m,p(col+1),col)
      info = 0

c       compute p1=-D^(-1/2)(p1-D^(-1/2)L'p2)
c                 =-D^(-1/2)p1+D^(-1)L'p2.
      do 40 i = 1, col
         p(i) = -p(i)/sqrt(sy(i,i))
  40  continue
      do 60 i = 1, col
         sum = 0.d0
         do 50 k = i + 1, col
            sum = sum + sy(k,i)*p(col+k)/sy(i,i)
  50     continue
         p(i) = p(i) + sum
  60  continue

      return

      end


$ gawk 'BEGIN{print"write(6,\"(2(g12.3,x))\")(i/10.0,besj1(i/10.0), i=0,1000)\nend";exit(0)}'|gfortran -ffree-form -x f95 - | gnuplot -p -e 'plot "<./a.out" t "Bessel function of 1st kind" w l'