      SUBROUTINE MB03XP( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB,
     $                   Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the periodic Schur decomposition and the eigenvalues of
C     a product of matrices, H = A*B, with A upper Hessenberg and B
C     upper triangular without evaluating any part of the product.
C     Specifically, the matrices Q and Z are computed, so that
C
C          Q' * A * Z = S,    Z' * B * Q = T
C
C     where S is in real Schur form, and T is upper triangular.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Indicates whether the user wishes to compute the full
C             Schur form or the eigenvalues only, as follows:
C             = 'E':  Compute the eigenvalues only;
C             = 'S':  compute the factors S and T of the full
C                     Schur form.
C
C     COMPQ   CHARACTER*1
C             Indicates whether or not the user wishes to accumulate
C             the matrix Q as follows:
C             = 'N':  The matrix Q is not required;
C             = 'I':  Q is initialized to the unit matrix and the
C                     orthogonal transformation matrix Q is returned;
C             = 'V':  Q must contain an orthogonal matrix U on entry,
C                     and the product U*Q is returned.
C
C     COMPZ   CHARACTER*1
C             Indicates whether or not the user wishes to accumulate
C             the matrix Z as follows:
C             = 'N':  The matrix Z is not required;
C             = 'I':  Z is initialized to the unit matrix and the
C                     orthogonal transformation matrix Z is returned;
C             = 'V':  Z must contain an orthogonal matrix U on entry,
C                     and the product U*Z is returned.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and B. N >= 0.
C
C     ILO     (input) INTEGER
C     IHI     (input) INTEGER
C             It is assumed that the matrices A and B are already upper
C             triangular in rows and columns 1:ILO-1 and IHI+1:N.
C             The routine works primarily with the submatrices in rows
C             and columns ILO to IHI, but applies the transformations to
C             all the rows and columns of the matrices A and B, if
C             JOB = 'S'.
C             1 <= ILO <= max(1,N+1); min(ILO,N) <= IHI <= N.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array A must
C             contain the upper Hessenberg matrix A.
C             On exit, if JOB = 'S', the leading N-by-N part of this
C             array is upper quasi-triangular with any 2-by-2 diagonal
C             blocks corresponding to a pair of complex conjugated
C             eigenvalues.
C             If JOB = 'E', the diagonal elements and 2-by-2 diagonal
C             blocks of A will be correct, but the remaining parts of A
C             are unspecified on exit.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading N-by-N part of this array B must
C             contain the upper triangular matrix B.
C             On exit, if JOB = 'S', the leading N-by-N part of this
C             array contains the transformed upper triangular matrix.
C             2-by-2 blocks in B corresponding to 2-by-2 blocks in A
C             will be reduced to positive diagonal form. (I.e., if
C             A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j)
C             and B(j+1,j+1) will be positive.)
C             If JOB = 'E', the elements corresponding to diagonal
C             elements and 2-by-2 diagonal blocks in A will be correct,
C             but the remaining parts of B are unspecified on exit.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, if COMPQ = 'V', then the leading N-by-N part of
C             this array must contain a matrix Q which is assumed to be
C             equal to the unit matrix except for the submatrix
C             Q(ILO:IHI,ILO:IHI).
C             If COMPQ = 'I', Q need not be set on entry.
C             On exit, if COMPQ = 'V' or COMPQ = 'I' the leading N-by-N
C             part of this array contains the transformation matrix
C             which produced the Schur form.
C             If COMPQ = 'N', Q is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= 1.
C             If COMPQ <> 'N', LDQ >= MAX(1,N).
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             On entry, if COMPZ = 'V', then the leading N-by-N part of
C             this array must contain a matrix Z which is assumed to be
C             equal to the unit matrix except for the submatrix
C             Z(ILO:IHI,ILO:IHI).
C             If COMPZ = 'I', Z need not be set on entry.
C             On exit, if COMPZ = 'V' or COMPZ = 'I' the leading N-by-N
C             part of this array contains the transformation matrix
C             which produced the Schur form.
C             If COMPZ = 'N', Z is not referenced.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= 1.
C             If COMPZ <> 'N', LDZ >= MAX(1,N).
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             The i-th (1 <= i <= N) computed eigenvalue is given by
C             BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two
C             eigenvalues are computed as a complex conjugate pair,
C             they are stored in consecutive elements of ALPHAR, ALPHAI
C             and BETA. If JOB = 'S', the eigenvalues are stored in the
C             same order as on the diagonales of the Schur forms of A
C             and B.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -19,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
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             > 0:  if INFO = i, then MB03XP failed to compute the Schur
C                   form in a total of 30*(IHI-ILO+1) iterations;
C                   elements 1:ilo-1 and i+1:n of ALPHAR, ALPHAI and
C                   BETA contain successfully computed eigenvalues.
C
C     METHOD
C
C     The implemented algorithm is a multi-shift version of the periodic
C     QR algorithm described in [1,3] with some minor modifications
C     proposed in [2].
C
C     REFERENCES
C
C     [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P.
C         The periodic Schur decomposition: Algorithms and applications.
C         Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42,
C         1992.
C
C     [2] Kressner, D.
C         An efficient and reliable implementation of the periodic QZ
C         algorithm. Proc. of the IFAC Workshop on Periodic Control
C         Systems, pp. 187-192, 2001.
C
C     [3] Van Loan, C.
C         Generalized Singular Values with Algorithms and Applications.
C         Ph. D. Thesis, University of Michigan, 1973.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O(N**3) floating point operations and is
C     backward stable.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, May 2008 (SLICOT version of the HAPACK routine DHGPQR).
C     V. Sima, Oct. 2011.
C
C     KEYWORDS
C
C     Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal
C     transformation, (periodic) Schur form
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      INTEGER            NSMAX, LDAS, LDBS
      PARAMETER          ( NSMAX = 15, LDAS = NSMAX, LDBS = NSMAX )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOB
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDWORK, LDZ, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*),
     $                   BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL            INITQ, INITZ, WANTQ, WANTT, WANTZ
      INTEGER            DUM, I, I1, I2, IERR, ITEMP, ITN, ITS, J, K,
     $                   KK, L, MAXB, NH, NR, NS, NV, PV2, PV3
      DOUBLE PRECISION   OVFL, SMLNUM, TAUV, TAUW, TEMP, TST, ULP, UNFL
C     .. Local Arrays ..
      INTEGER            ISEED(4)
      DOUBLE PRECISION   AS(LDAS,LDAS), BS(LDBS,LDBS), V(3*NSMAX+6)
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX, UE01MD
      DOUBLE PRECISION   DLAMCH, DLANHS
      EXTERNAL           DLAMCH, DLANHS, IDAMAX, LSAME, UE01MD
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DLABAD, DLACPY, DLARFG,
     $                   DLARFX, DLARNV, DLASET, DSCAL, DTRMV, MB03YA,
     $                   MB03YD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      WANTT = LSAME( JOB, 'S' )
      INITQ = LSAME( COMPQ, 'I' )
      WANTQ = INITQ.OR.LSAME( COMPQ, 'V' )
      INITZ = LSAME( COMPZ, 'I' )
      WANTZ = INITZ.OR.LSAME( COMPZ, 'V' )
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF ( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
         INFO = -1
      ELSE IF ( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
         INFO = -2
      ELSE IF ( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
         INFO = -3
      ELSE IF ( N.LT.0 ) THEN
         INFO = -4
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N+1 ) ) THEN
         INFO = -5
      ELSE IF ( IHI.LT.MIN( ILO,N ).OR.IHI.GT.N ) THEN
         INFO = -6
      ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN
         INFO = -12
      ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN
         INFO = -14
      ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN
         DWORK(1) = DBLE( MAX( 1, N ) )
         INFO = -19
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03XP', -INFO )
         RETURN
      END IF
C
C     Initialize Q and Z, if necessary.
C
      IF ( INITQ )
     $   CALL DLASET( 'All', N, N, ZERO, ONE, Q, LDQ )
      IF ( INITZ )
     $   CALL DLASET( 'All', N, N, ZERO, ONE, Z, LDZ )
C
C     Store isolated eigenvalues and standardize B.
C
C     FOR I = [1:ILO-1, IHI+1:N]
      I = 1
   10 CONTINUE
      IF ( I.EQ.ILO ) THEN
         I = IHI+1
      END IF
      IF ( I.LE.N ) THEN
         IF ( B(I,I).LT.ZERO ) THEN
            IF ( WANTT ) THEN
               DO 20  K = ILO, I
                  B(K,I) = -B(K,I)
   20          CONTINUE
               DO 30  K = I, IHI
                  A(I,K) = -A(I,K)
   30          CONTINUE
            ELSE
               B(I,I) = -B(I,I)
               A(I,I) = -A(I,I)
            END IF
            IF ( WANTQ ) THEN
               DO 40  K = ILO, IHI
                  Q(K,I) = -Q(K,I)
   40          CONTINUE
            END IF
         END IF
         ALPHAR(I) = A(I,I)
         ALPHAI(I) = ZERO
         BETA(I) = B(I,I)
         I = I + 1
C        END FOR
         GO TO 10
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. ILO.EQ.IHI+1 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Set rows and coloms ILO to IHI of B (A) to zero below the first
C     (sub)diagonal.
C
      DO  60 J = ILO, IHI - 2
         DO 50  I = J + 2, N
            A(I,J) = ZERO
   50    CONTINUE
   60 CONTINUE
      DO  80 J = ILO, IHI - 1
         DO 70  I = J + 1, N
            B(I,J) = ZERO
   70    CONTINUE
   80 CONTINUE
      NH = IHI - ILO + 1
C
C     Suboptimal choice of the number of shifts.
C
      IF ( WANTQ ) THEN
         NS   = UE01MD( 4, 'MB03XP', JOB // COMPQ, N, ILO, IHI )
         MAXB = UE01MD( 8, 'MB03XP', JOB // COMPQ, N, ILO, IHI )
      ELSE
         NS   = UE01MD( 4, 'MB03XP', JOB // COMPZ, N, ILO, IHI )
         MAXB = UE01MD( 8, 'MB03XP', JOB // COMPZ, N, ILO, IHI )
      END IF
C
      IF ( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN
C
C        Standard double-shift product QR.
C
         CALL MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILO, IHI, A,
     $                LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA,
     $                DWORK, LDWORK, INFO )
         RETURN
      END IF
      MAXB = MAX( 3, MAXB )
      NS = MIN( NS, MAXB, NSMAX )
C
C     Set machine-dependent constants for the stopping criterion.
C     If max(norm(A),norm(B)) <= sqrt(OVFL), then overflow should not
C     occur.
C
      UNFL = DLAMCH( 'Safe minimum' )
      OVFL = ONE / UNFL
      CALL DLABAD( UNFL, OVFL )
      ULP = DLAMCH( 'Precision' )
      SMLNUM = UNFL*( DBLE( NH ) / ULP )
C
C     I1 and I2 are the indices of the first rows and last columns of
C     A and B to which transformations must be applied.
C
      IF ( WANTT ) THEN
         I1 = 1
         I2 = N
      END IF
      ISEED(1) = 1
      ISEED(2) = 0
      ISEED(3) = 0
      ISEED(4) = 1
C
C     ITN is the maximal number of QR iterations.
C
      ITN = 30*NH
      DUM = 0
C
C     Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO
C     or A(L,L-1) is negligible.
C
      I = IHI
   90 CONTINUE
      L = ILO
      IF ( I.LT.ILO )
     $   GO TO 210
C
      DO 190  ITS = 0, ITN
         DUM = DUM + (IHI-ILO)*(IHI-ILO)
C
C        Look for deflations in A.
C
         DO 100  K = I, L + 1, -1
            TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) )
            IF ( TST.EQ.ZERO )
     $         TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK )
            IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) )
     $         GO TO 110
  100    CONTINUE
  110    CONTINUE
C
C        Look for deflation in B if problem size is greater than 1.
C
         IF ( I-K.GE.1 ) THEN
            DO 120  KK = I, K, -1
               IF ( KK.EQ.I ) THEN
                  TST = ABS( B(KK-1,KK) )
               ELSE IF ( KK.EQ.K ) THEN
                  TST = ABS( B(KK,KK+1) )
               ELSE
                  TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) )
               END IF
               IF ( TST.EQ.ZERO )
     $            TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK )
               IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) )
     $            GO TO 130
  120       CONTINUE
         ELSE
            KK = K-1
         END IF
  130    CONTINUE
         IF ( KK.GE.K ) THEN
C
C           B has an element close to zero at position (KK,KK).
C
            B(KK,KK) = ZERO
            CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILO, IHI, KK,
     $                   A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )
            K = KK+1
         END IF
         L = K
         IF( L.GT.ILO ) THEN
C
C           A(L,L-1) is negligible.
C
            A(L,L-1) = ZERO
         END IF
C
C        Exit from loop if a submatrix of order <= MAXB has split off.
C
         IF ( L.GE.I-MAXB+1 )
     $      GO TO 200
C
C        The active submatrices are now in rows and columns L:I.
C
         IF ( .NOT.WANTT ) THEN
            I1 = L
            I2 = I
         END IF
         IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN
C
C           Exceptional shift. The first column of the shift polynomial
C           is a pseudo-random vector.
C
            CALL DLARNV( 3, ISEED, NS+1, V )
         ELSE
C
C           Use eigenvalues of trailing submatrix as shifts.
C
            CALL DLACPY( 'Full', NS, NS, A(I-NS+1,I-NS+1), LDA, AS,
     $                   LDAS )
            CALL DLACPY( 'Full', NS, NS, B(I-NS+1,I-NS+1), LDB, BS,
     $                   LDBS )
            CALL MB03YD( .FALSE., .FALSE., .FALSE., NS, 1, NS, 1, NS,
     $                   AS, LDAS, BS, LDBS, Q, LDQ, Z, LDZ,
     $                   ALPHAR(I-NS+1), ALPHAI(I-NS+1), BETA(I-NS+1),
     $                   DWORK, LDWORK, IERR )
         END IF
C
C        Compute the nonzero elements of the first column of
C        (A*B-w(1)) (A*B-w(2)) .. (A*B-w(ns)).
C
         V(1) = ONE
         NV = 1
C        WHILE NV <= NS
  140    CONTINUE
         IF ( NV.LE.NS ) THEN
            IF ( NV.EQ.NS .OR. AS(NV+1,NV).EQ.ZERO ) THEN
C
C              Real shift.
C
               V(NV+1) = ZERO
               PV2 = NV+2
               CALL DCOPY( NV, V, 1, V(PV2), 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal',
     $                     NV, B(L,L), LDB, V(PV2), 1 )
               CALL DSCAL( NV, BS(NV,NV), V, 1 )
               ITEMP = IDAMAX( 2*NV+1, V, 1 )
               TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM )
               CALL DSCAL( 2*NV+1, TEMP, V, 1 )
               CALL DGEMV( 'No transpose', NV+1, NV, ONE, A(L,L), LDA,
     $                     V(PV2), 1, -AS(NV,NV), V, 1 )
               NV = NV + 1
            ELSE
C
C              Double shift using a product formulation of the shift
C              polynomial [2].
C
               V(NV+1) = ZERO
               V(NV+2) = ZERO
               PV2 = NV+3
               PV3 = 2*NV+5
               CALL DCOPY( NV+2, V, 1, V(PV2), 1 )
               CALL DCOPY( NV+1, V, 1, V(PV3), 1 )
               CALL DSCAL( NV, BS(NV+1,NV+1), V(PV2), 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal',
     $                     NV, B(L,L), LDB, V(PV3), 1 )
               ITEMP = IDAMAX( 2*NV+3, V(PV2), 1 )
               TEMP = ONE / MAX( ABS( V(PV2+ITEMP-1) ), SMLNUM )
               CALL DSCAL( 2*NV+3, TEMP, V(PV2), 1 )
C
               CALL DCOPY( NV, V(PV2), 1, V, 1 )
               CALL DGEMV( 'No transpose', NV+1, NV, -ONE, A(L,L), LDA,
     $                     V(PV3), 1, AS(NV+1,NV+1), V(PV2), 1 )
               CALL DSCAL( NV, AS(NV,NV+1), V, 1 )
               ITEMP = IDAMAX( 2*NV+3, V, 1 )
               TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM )
               CALL DSCAL( 2*NV+3, TEMP, V, 1 )
C
               CALL DSCAL( NV, -AS(NV+1,NV), V, 1 )
               CALL DAXPY( NV+1, AS(NV,NV), V(PV2), 1, V, 1)
               ITEMP = IDAMAX( 2*NV+3, V, 1 )
               TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM )
               CALL DSCAL( 2*NV+3, TEMP, V, 1 )
C
               CALL DSCAL( NV+1, BS(NV,NV), V, 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal',
     $                     NV+1, B(L,L), LDB, V(PV2), 1 )
               ITEMP = IDAMAX( 2*NV+3, V, 1 )
               TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM )
               CALL DSCAL( 2*NV+3, TEMP, V, 1 )
C
               CALL DGEMV( 'No transpose', NV+2, NV+1, -ONE, A(L,L),
     $                     LDA, V(PV2), 1, ONE, V, 1 )
               NV = NV + 2
            END IF
            ITEMP = IDAMAX( NV, V, 1 )
            TEMP = ABS( V(ITEMP) )
            IF ( TEMP.EQ.ZERO ) THEN
               V(1) = ONE
               DO 150  K = 2, NV
                  V(K) = ZERO
  150          CONTINUE
            ELSE
               TEMP = MAX( TEMP, SMLNUM )
               CALL DSCAL( NV, ONE/TEMP, V, 1 )
            END IF
            GO TO 140
C        END WHILE
         END IF
C
C        Multi-shift product QR step.
C
         PV2 = NS+2
         DO 180  K = L,I-1
            NR = MIN( NS+1,I-K+1 )
            IF ( K.GT.L )
     $         CALL DCOPY( NR, A(K,K-1), 1, V, 1 )
            CALL DLARFG( NR, V(1), V(2), 1, TAUV )
            IF ( K.GT.L ) THEN
               A(K,K-1) = V(1)
               DO 160  KK = K+1,I
                  A(KK,K-1) = ZERO
  160          CONTINUE
            END IF
C
C           Apply reflector V from the right to B in rows
C           I1:min(K+NS,I).
C
            V(1) = ONE
            CALL DLARFX( 'Right', MIN(K+NS,I)-I1+1, NR, V, TAUV,
     $                   B(I1,K), LDB, DWORK )
C
C           Annihilate the introduced nonzeros in the K-th column.
C
            CALL DCOPY( NR, B(K,K), 1, V(PV2), 1 )
            CALL DLARFG( NR, V(PV2), V(PV2+1), 1, TAUW )
            B(K,K) = V(PV2)
            DO 170  KK = K+1,I
               B(KK,K) = ZERO
  170       CONTINUE
            V(PV2) = ONE
C
C           Apply reflector W from the left to transform the rows of the
C           matrix B in columns K+1:I2.
C
            CALL DLARFX( 'Left', NR, I2-K, V(PV2), TAUW, B(K,K+1), LDB,
     $                   DWORK )
C
C           Apply reflector V from the left to transform the rows of the
C           matrix A in columns K:I2.
C
            CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA,
     $                   DWORK )
C
C           Apply reflector W from the right to transform the columns of
C           the matrix A in rows I1:min(K+NS,I).
C
            CALL DLARFX( 'Right', MIN(K+NS+1,I)-I1+1, NR, V(PV2), TAUW,
     $                   A(I1,K), LDA, DWORK )
C
C           Accumulate transformations in the matrices Q and Z.
C
            IF ( WANTQ )
     $         CALL DLARFX( 'Right', NH, NR, V, TAUV, Q(ILO,K), LDQ,
     $                      DWORK )
            IF ( WANTZ )
     $         CALL DLARFX( 'Right', NH, NR, V(PV2), TAUW, Z(ILO,K),
     $                      LDZ, DWORK )
  180    CONTINUE
  190 CONTINUE
C
C     Failure to converge.
C
      INFO = I
      RETURN
  200 CONTINUE
C
C     Submatrix of order <= MAXB has split off. Use double-shift
C     periodic QR algorithm.
C
      CALL MB03YD( WANTT, WANTQ, WANTZ, N, L, I, ILO, IHI, A, LDA, B,
     $             LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK,
     $             LDWORK, INFO )
      IF ( INFO.GT.0 )
     $   RETURN
      ITN = ITN - ITS
      I = L - 1
      GO TO 90
C
  210 CONTINUE
      DWORK(1) = DBLE( MAX( 1,N ) )
      RETURN
C *** Last line of MB03XP ***
      END


!==============================================================================!
  logical function Math_Mod_Smaller_Real(a, b, tol)
!------------------------------------------------------------------------------!
!   Returns .true. if a is approximatelly smaller than "b", .false. otherwise. !
!                                                                              !
!   The approximation is controlled by optional parameter "tol".  If it is     !
!   not given, the function will use DEFAULT_TOLERANCE specified in Math_Mod   !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  real           :: a, b
  real, optional :: tol
!-----------------------------------[Locals]-----------------------------------!
  real :: tolerance
!==============================================================================!

  if( .not. present(tol) ) then
    tolerance = DEFAULT_TOLERANCE
  else
    tolerance = tol
  end if

  if( a < b - tolerance ) then
    Math_Mod_Smaller_Real = .true.
  else
    Math_Mod_Smaller_Real = .false.
  end if

  end function


! { dg-do run }
! PR83191 Writing a namelist with repeated complex

program test

implicit none

integer, parameter :: UNIT = 1
character(len=8), parameter :: FILE = "namelist"

complex, dimension(3) :: a = (/ (0.0, 0.0), (0.0, 0.0), (3.0, 4.0) /)

namelist /complex_namelist/ a

open(UNIT, file=FILE)
write(UNIT, nml=complex_namelist)
close(UNIT)

open(UNIT, file=FILE)
read(UNIT, nml=complex_namelist)
close(UNIT, status="delete")
if (any(a.ne.(/ (0.0, 0.0), (0.0, 0.0), (3.0, 4.0) /))) call abort
end program test


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_full2low( n, A, L )

!  Given the n x n PSD matrix L, return in L the lower
!  triangle of A in packed format.

implicit none
integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: A(n,n)
real(k_dp), intent(out) :: L((n*(n+1))/2)

integer    :: i, j, k

k = 0
do j = 1, n
   do i = j,n
      k = k + 1
	  L(k) = A(i,j)
   end do
end do

return
end subroutine ell_full2low


      subroutine bongrid(irho, ians, ihere)

c  First time through, form the THETA-ZETAH grid
c  Every time through, evaluate B and QSAFETY on the grid for this RHO.
c  Here, m is the poloidal mode number and n (and nh, for n-hat) is the
c  toroidal mode number.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use parambs
      use vmec0
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer irho, ians, ihere
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec), parameter :: zero = 0, one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: i, j, nh, m, mbuse1, imax, jmax
!      integer, save :: ihere = 0
      integer :: ij_max(2)
      real(rprec), save :: twopi, dth, dzetah, dthm, dzetahm
      real(rprec) :: d, dbmintok, sbmaxtok,
     1 b, del
C-----------------------------------------------

      if (ihere .eq. 0) then

c  allocate all of the variables needed on the theta-zeta grid

         call allocate_angles

c-----------------------------------------------------------------------
c  Form the THETA-ZETAH grid.

         twopi = 8*atan(one)
         dth = twopi/nthetah
         dzetah = twopi/nzetah

         do i = 1, nthetah
            theta(i) = (i - 1)*dth
         end do
         do j = 1, nzetah
            zetah(j) = (j - 1)*dzetah
         end do

!   Form a finer mesh to evaluate fine grained bmax.

         dthm = dth/(nthetahm-1)
         dzetahm = dzetah/(nzetahm-1)

!  load sin and cosine arrays

         do j = 1, nzetah
            do nh = 0, nbuse
               sinnj(nh,j) = sin(zetasign*nh*zetah(j))
               cosnj(nh,j) = cos(zetasign*nh*zetah(j))
            enddo
         enddo
         do i = 1, nthetah
            do m = -mbuse, mbuse
               sinmi(m,i) = sin(m*theta(i))
               cosmi(m,i) = cos(m*theta(i))
            end do
         end do
         ihere = 1
      endif          !end of ihere initial evaluation

c  Now evaluate B on the theta-zetah grid for this RHO using the epsilons just
c  found.  Loop over theta and phihat, summing up all the (m,nh) terms in B.

      do j = 1, nzetah
         do i = 1, nthetah
            b = zero
            do m = -mbuse, mbuse
               do nh = 0, nbuse
                  b = b + amnfit(irho,m,nh)*
     1               (cosmi(m,i)*cosnj(nh,j)-sinmi(m,i)*sinnj(nh,j))
                  IF (lasym_bootsj) b = b + amnfit2(irho,m,nh)*
     1               (sinmi(m,i)*cosnj(nh,j)+cosmi(m,i)*sinnj(nh,j))
               end do
            end do
            bfield(i,j) = abs(b)
         end do
      end do

c   find max of b on global mesh

      ij_max = maxloc(bfield)
      imax = ij_max(1)
      jmax = ij_max(2)

c  use the theta and zeta from this search as the center of a finer search

c  first form the grid

      thetam(1) = theta(imax) - dth/2
      zetahm(1) = zetah(jmax) - dzetah/2

      do i = 2, nthetahm
         thetam(i) = thetam(i-1) + dthm
      enddo
      do j = 2, nzetahm
         zetahm(j) = zetahm(j-1) + dzetahm
      enddo

c  load the sines and cosines on the finer mesh

      do j = 1, nzetahm
         do nh = 0, nbuse
            sinnjm(nh,j) = sin(zetasign*nh*zetahm(j))
            cosnjm(nh,j) = cos(zetasign*nh*zetahm(j))
         enddo
      enddo
      do i = 1, nthetahm
         do m = -mbuse, mbuse
            sinmim(m,i) = sin(m*thetam(i))
            cosmim(m,i) = cos(m*thetam(i))
         end do
      end do

c  evaluate b on the finer mesh

      do j = 1, nzetahm
         do i = 1, nthetahm
            b = zero
            do m = -mbuse, mbuse
               do nh = 0, nbuse
                  b = b + amnfit(irho,m,nh)*
     1              (cosmim(m,i)*cosnjm(nh,j)-sinmim(m,i)*sinnjm(nh,j))
                  IF (lasym_bootsj) b = b + amnfit2(irho,m,nh)*
     1               (sinmim(m,i)*cosnjm(nh,j)+cosmim(m,i)*sinnjm(nh,j))
               end do
            end do
            bfieldm(i,j) = abs(b)
         end do
      end do

c- evaluate bmax1(irho), thetamax(irho), b2avg(irho), and zetahmax(irho)
c  based on finer mesh evaluation

      ij_max = maxloc(bfieldm)
      imax = ij_max(1)
      jmax = ij_max(2)
      thetamax(irho) = thetam(imax)
      zetahmax(irho) = zetahm(jmax)
      bmax1(irho) = bfieldm(imax,jmax)

c  evaluate jacobian.  Leave off flux surface quantites.  Evaluate
c  the sum for later use.  Note that the value is not scaled to
c  Bmax.

      gsqrt_b(:nthetah,:nzetah) = one/bfield(:nthetah,:nzetah)**2
      sum_gsqrt_b = sum(gsqrt_b)

c  find b2avg LAB--boozer paper uses both bzero2 (1/leading coefficient of 1/b**2 expansion
c  and <b**2>.  They are the same (in boozer coordinates).  Both result from
c  flux surface averages. I will use <b2> everywhere

      b2avg(irho) = sum(bfield**2 * gsqrt_b)/sum_gsqrt_b

c  Scale the array BFIELD so that it contains B/Bmax instead of B.

      bfield(:nthetah,:nzetah) = bfield(:nthetah,:nzetah)/bmax1(irho)
      where(bfield .gt. one) bfield = one
      b2obm = bfield**2

c   pressure related derivatives are needed
c   first calculate difference denominators for pressure related derivatives
c   difference array has differences on the full mesh

c   use a parabolic fit near rho = 0 to get derivatives at 1st half mesh

      if(irho .eq. 1) then
         drho = (rhoar(2)**2 - rhoar(1)**2)/(2*rhoar(1))

c   use slope of last two points at outer rho point

      elseif(irho .eq. irup) then
         drho = 0.5_dp*(d_rho(irho)+d_rho(irho-1))

c  all other points

      else
         drho = d_rho(irho) + 0.5_dp*(d_rho(irho+1)+d_rho(irho-1))
      endif

c  evaluate Electron temperature gradients in Kev

      if (irho .ne. 1 .and. irho .ne. irup) temperho1 =
     1   (tempe1(irho+1)-tempe1(irho-1))/drho
      if (irho .eq. 1) temperho1 = (tempe1(irho+1)-tempe1(irho))/drho
      if (irho .eq. irup) temperho1=(tempe1(irho)-tempe1(irho-1))/drho

c evaluate Ion temperature gradients in Kev

      if (irho .ne. 1 .and. irho .ne. irup) tempirho1 =
     1  (tempi1(irho+1)-tempi1(irho-1))/drho
      if (irho .eq. 1)tempirho1 = (tempi1(irho+1)-tempi1(irho))/drho
      if (irho .eq. irup)temperho1=(tempi1(irho)-tempi1(irho-1))/drho

c  evaluate electron density gradients in 10**20 m-3

      if (irho .ne. 1 .and. irho .ne. irup) densrho1 =
     1  (dense(irho+1)-dense(irho-1))/drho
      if (irho .eq. 1) densrho1 = (dense(irho+1)-dense(irho))/drho
      if (irho .eq. irup) densrho1 = (dense(irho)-dense(irho-1))/drho

c  write out the lower order Boozer coefficients

      mbuse1 = mbuse
      if (mbuse > 5) mbuse1 = 5            !mbuse1 > 5 will not fit on page

      write (ians, 400)
  400 format(/' nh ',$)
      do m = -mbuse1, mbuse1
         write (ians, 402) m
      end do
  402 format('   m=',i2,'   ',$)
      write (ians, '(a1)') ' '
c
      do nh = 0, nbuse
         write (ians, 406) nh, (amnfit(irho,m,nh),m=(-mbuse1),mbuse1)
      end do
  406 format(1x,i2,1p13e10.3)

c  Calculate the fraction trapped and fraction passing for the "equivalent"

      call tok_fraction(fttok(irho),irho)

      fptok(irho) = one - fttok(irho)

      end subroutine bongrid


module intersect_curve
use config, only: ftol
use math
use generic_list
use geom_utils
use evaluate
use modify
use divide
use bounding_box
use intersect_bbox
use geom_results
use nelder_mead, only: simplex
implicit none

private :: ci_data, ci_ptr

! Curve intersection data.
type ci_data
    double precision :: u0
    double precision :: u1
    double precision :: t, u, v
end type ci_data

type ci_ptr
    type(ci_data), pointer :: ci
end type ci_ptr

contains

subroutine intersect_curve_curve(n1, p1, uk1, cpw1, n2, p2, uk2, cpw2, itol, flag)
    !> Intersect two curves.
    !> n1 - Numer of control points - 1 for curve 1.
    !> p1 - Degree for curve 1.
    !> uk1 - Knot vector for curve 1.
    !> cpw1 - Control points for curve 1.
    !> n2 - Numer of control points - 1 for curve 2.
    !> p2 - Degree for curve 2.
    !> uk2 - Knot vector for curve 2.
    !> cpw2 - Control points for curve 2.
    !> itol - Intersection tolerance.
    !> flag - Status flag.

    !f2py intent(in) n1, p1, uk1, cpw1, n2, p2, uk2, cpw2, itol
    !f2py intent(out) flag
    !f2py depend(n1, p1) uk1
    !f2py depend(n2, p2) uk2
    !f2py depend(n1) cpw1
    !f2py depend(n2) cpw2

    ! Input
    integer, intent(in) :: n1, p1, n2, p2
    double precision, intent(in) :: uk1(0:n1 + p1 + 1)
    double precision, intent(in) :: uk2(0:n2 + p2 + 1)
    double precision, intent(in) :: cpw1(0:n1, 0:3)
    double precision, intent(in) :: cpw2(0:n2, 0:3)
    double precision, intent(in) :: itol

    ! Output
    integer, intent(out) :: flag

    ! Working
    logical :: is_cand
    integer :: i, j
    integer :: nsol

    integer :: nbez1, nbez2
    double precision :: ucheck, di, a1, b1, a2, b2
    double precision :: qw1(0:n1 + p1 + 1, 0:p1, 0:3)
    double precision :: qw2(0:n2 + p2 + 1, 0:p2, 0:3)
    double precision :: ab1(0:n1 + p1 + 1, 0:1)
    double precision :: ab2(0:n2 + p2 + 1, 0:1)
    double precision :: qwi1(0:p1, 0:3), abi1(0:1)
    double precision :: qwi2(0:p2, 0:3), abi2(0:1)

    logical :: unique, test1, test2
    double precision :: p0(0:2), pi1(0:2), pi2(0:2), vi(0:2), pi12(0:2)
    double precision :: p10(0:2), p11(0:2), p20(0:2), p21(0:2)

    ! Nelder-Mead
    logical :: success
    double precision :: tol
    double precision :: x(2)

    ! Generic list for storing results.
    type(list_node_t), pointer :: cci_list => null()
    type(ci_ptr) :: cci_ptr

    ! Initialize
    nsol = 0
    call list_init(cci_list)

    ! Step 1: Check for possible intersection.
    is_cand = candidate_intersect(n1, cpw1, n2, cpw2)
    if (is_cand .eqv. .false.) then
        flag = 0
        call list_free(cci_list)
        call set_empty_results()
        return
    end if

    ! Step 2: Decompose curves into Bezier segments.
    call decompose_curve(n1, p1, uk1, cpw1, nbez1, qw1, ab1)
    call decompose_curve(n2, p2, uk2, cpw2, nbez2, qw2, ab2)

    ! Step 3: Perform recursive subdivision on candidate curves.
    do i = 0, nbez1 - 1
        qwi1 = qw1(i, :, :)
        abi1 = ab1(i, :)
        do j = 0, nbez2 - 1
            qwi2 = qw2(j, :, :)
            abi2 = ab2(j, :)
            is_cand = candidate_intersect(p1, qwi1, p2, qwi2)
            if (is_cand) then
                call subdivide(p1, qwi1, abi1, p2, qwi2, abi2)
            end if
        end do
    end do

    ! Return if no intersections are found.
    if (nsol .eq. 0) then
        flag = 0
        call list_free(cci_list)
        call set_empty_results()
        return
    end if

    ! Allocate result arrays.
    call reset_results()
    allocate(points_(nsol + 4, 3))
    allocate(params2d_(nsol + 4, 2))
    points_(:, :) = 0.0d0
    params2d_(:, :) = 0.0d0

    ! Manually check curve endpoint intersection to improve robustness.
    call curve_point(n1, p1, uk1, cpw1, uk1(p1), p10)
    call curve_point(n1, p1, uk1, cpw1, uk1(n1 + 1), p11)
    call curve_point(n2, p2, uk2, cpw2, uk2(p2), p20)
    call curve_point(n2, p2, uk2, cpw2, uk2(n2 + 1), p21)
    test1 = are_points_equal(p10, p20, itol)
    test2 = are_points_equal(p10, p21, itol)
    if (test1) then
        pi12 = 0.5d0 * (p10 + p20)
        call add_pnt(uk1(p1), uk2(p2), pi12)
    elseif (test2) then
        pi12 = 0.5d0 * (p10 + p21)
        call add_pnt(uk1(p1), uk2(n2 + 1), pi12)
    end if

    test1 = are_points_equal(p11, p20, itol)
    test2 = are_points_equal(p11, p21, itol)
    if (test1) then
        pi12 = 0.5d0 * (p11 + p20)
        call add_pnt(uk1(n1 + 1), uk2(p2), pi12)
    elseif (test2) then
        pi12 = 0.5d0 * (p11 + p21)
        call add_pnt(uk1(n1 + 1), uk2(n2 + 1), pi12)
    end if

    ! Step 4: Refine intersection points.
    a1 = uk1(0)
    b1 = uk1(n1 + p1 + 1)
    a2 = uk2(0)
    b2 = uk2(n2 + p2 + 1)
    tol = itol / 100.0d0
    do i = 1, nsol
        ! Get next
        cci_list = list_next(cci_list)
        cci_ptr = transfer(list_get(cci_list), cci_ptr)
        x(1) = cci_ptr%ci%u0
        x(2) = cci_ptr%ci%u1
        ! Call Nelder-Mead.
        call simplex(obj, 2, x, tol, success)
        ! Check parameter domains.
        ucheck = x(1)
        call check_param(n1, p1, uk1, ucheck)
        x(1) = ucheck
        ucheck = x(2)
        call check_param(n2, p2, uk2, ucheck)
        x(2) = ucheck
        ! Get point and add to results only if unique.
        call curve_point(n1, p1, uk1, cpw1, x(1), pi1)
        call curve_point(n2, p2, uk2, cpw2, x(2), pi2)
        vi = pi1 - pi2
        di = norm(vi)
        if (di .le. itol) then
            pi12 = 0.50d0 * (pi1 + pi2)
            call add_pnt(x(1), x(2), pi12)
        end if
    end do

    ! Return results.
    call list_free(cci_list)
    flag = 1

    ! Internal subroutines.
    contains

    subroutine add_pnt(u1, u2, pi)
        ! Add point to intersection results.

        ! Input
        double precision, intent(in) :: u1, u2
        double precision, intent(in) :: pi(0:2)

        ! Working
        logical :: unique, test
        integer :: i
        double precision :: p0(0:2)

        unique = .true.
        do i = 1, npts_
            p0 = points_(i, :)
            test = are_points_equal(pi, p0, itol)
            if (test) then
                unique = .false.
                exit
            end if
        end do
        if (unique) then
            npts_ = npts_ + 1
            points_(npts_, :) = pi
            params2d_(npts_, :) = (/ u1, u2 /)
        end if

    end subroutine add_pnt

    subroutine obj(nx, x, fx)
        integer, intent(in) :: nx
        double precision, intent(in) :: x(nx)
        double precision, intent(out) :: fx

        ! Working
        double precision :: factor
        double precision :: r(0:2)
        double precision :: pi1(0:2), pi2(0:2)

        ! Penalize objective function if variable is outside domain.
        factor = 1.0d0
        if ((x(1) .lt. a1) .or. (x(1) .gt. b1))  then
            factor = 1000.0d0
        end if
        if ((x(2) .lt. a2) .or. (x(2) .gt. b2))  then
            factor = 1000.0d0
        end if

        ! Evaluate distance between points.
        call curve_point(n1, p1, uk1, cpw1, x(1), pi1)
        call curve_point(n2, p2, uk2, cpw2, x(2), pi2)
        r = pi1 - pi2
        fx = norm(r) * factor

    end subroutine obj

    recursive subroutine subdivide(n1, cpw1, ab1, n2, cpw2, ab2)
        ! Recursive subdivision.
        integer, intent(in) :: n1, n2
        double precision, intent(in) :: cpw1(0:n1, 0:3), ab1(0:1), &
                                        cpw2(0:n2, 0:3), ab2(0:1)

        logical :: flat1, flat2, candidate
        double precision :: cp1(0:n1, 0:2), w1(0:n1), &
                            cp2(0:n2, 0:2), w2(0:n2), &
                            qw11(0:n1, 0:3), qw12(0:n1, 0:3), &
                            qw21(0:n2, 0:3), qw22(0:n2, 0:3), &
                            ab11(0:1), ab12(0:1), ab21(0:1), ab22(0:1)

        call dehomogenize_array1d(n1, cpw1, cp1, w1)
        call dehomogenize_array1d(n2, cpw2, cp2, w2)

        call is_curve_flat(n1, cp1, ftol, flat1)
        call is_curve_flat(n2, cp2, ftol, flat2)

        if (flat1 .and. flat2) then
            call intersect(n1, cp1, ab1, n2, cp2, ab2)
        else
            call split_bezier_curve(cpw1, n1, 0.50d0, ab1(0), ab1(1), &
                                    qw11, ab11(0), ab11(1), &
                                    qw12, ab12(0), ab12(1))
            call split_bezier_curve(cpw2, n2, 0.50d0, ab2(0), ab2(1), &
                                    qw21, ab21(0), ab21(1), &
                                    qw22, ab22(0), ab22(1))

            candidate = candidate_intersect(n1, qw11, n2, qw21)
            if (candidate) then
                call subdivide(n1, qw11, ab11, n2, qw21, ab21)
            end if
            candidate = candidate_intersect(n1, qw11, n2, qw22)
            if (candidate) then
                call subdivide(n1, qw11, ab11, n2, qw22, ab22)
            end if
            candidate = candidate_intersect(n1, qw12, n2, qw21)
            if (candidate) then
                call subdivide(n1, qw12, ab12, n2, qw21, ab21)
            end if
            candidate = candidate_intersect(n1, qw12, n2, qw22)
            if (candidate) then
                call subdivide(n1, qw12, ab12, n2, qw22, ab22)
            end if
        end if

    end subroutine subdivide

    subroutine intersect(n1, cp1, ab1, n2, cp2, ab2)
        ! Intersect lines.
        integer, intent(in) :: n1, n2
        double precision, intent(in) :: cp1(0:n1, 0:2), ab1(0:1), &
                                        cp2(0:n2, 0:2), ab2(0:1)

        double precision :: p1(0:2), p2(0:2), p3(0:2), p4(0:2), &
                            d1343, d4321, d1321, d4343, d2121, &
                            numer, denom, u12, u34, ui1, ui2, &
                            p12(0:2), p34(0:2)

        p1 = cp1(0, :)
        p2 = cp1(n1, :)
        p3 = cp2(0, :)
        p4 = cp2(n2, :)
        d4321 = dot_product(p4 - p3, p2 - p1)
        d1321 = dot_product(p1 - p3, p2 - p1)
        d4343 = dot_product(p4 - p3, p4 - p3)
        d2121 = dot_product(p2 - p1, p2 - p1)
        denom = d2121 * d4343 - d4321 * d4321
        if (dabs(denom) .le. 1.0d-12) then
            ui1 = local_to_global_param(ab1(0), ab1(1), 0.50d0)
            ui2 = local_to_global_param(ab2(0), ab2(1), 0.50d0)
            ! Store result.
            allocate(cci_ptr%ci)
            cci_ptr%ci%u0 = ui1
            cci_ptr%ci%u1 = ui2
            call list_insert(cci_list, transfer(cci_ptr, list_data))
            nsol = nsol + 1
        else
            d1343 = dot_product(p1 - p3, p4 - p3)
            numer = d1343 * d4321 - d1321 * d4343
            u12 = numer / denom
            u34 = (d1343 + u12 * d4321) / d4343
            ui1 = local_to_global_param(ab1(0), ab1(1), u12)
            ui2 = local_to_global_param(ab2(0), ab2(1), u34)
            ! Store result.
            allocate(cci_ptr%ci)
            cci_ptr%ci%u0 = ui1
            cci_ptr%ci%u1 = ui2
            call list_insert(cci_list, transfer(cci_ptr, list_data))
            nsol = nsol + 1
        end if

    end subroutine intersect

    function candidate_intersect(n1, cpw1, n2, cpw2) result(candidate)
        ! Check if the two curves intersect.
        integer, intent(in) :: n1, n2
        double precision, intent(in) :: cpw1(0:n1, 0:3), cpw2(0:n2, 0:3)
        logical :: candidate

        double precision :: bbox1(0:2, 0:1), bbox2(0:2, 0:1)

        bbox1 = curve_bbox(n1, cpw1)
        bbox2 =  curve_bbox(n2, cpw2)
        candidate = bboxes_intersect(3, bbox1, bbox2, itol)

    end function candidate_intersect

end subroutine intersect_curve_curve

subroutine intersect_curve_plane(n, p, uk, cpw, origin, normal, itol, flag)
    !> Intersect a curve and a plane.
    !> n - Numer of control points - 1.
    !> p - Degree.
    !> uk - Knot vector.
    !> cpw - Control points.
    !> origin - Origin point of plane.
    !> normal - Unit normal vector of plane.
    !> itol - Intersection tolerance.
    !> flag - Status flag.

    !f2py intent(in) n, p, uk, cpw, origin, normal, itol
    !f2py intent(out) flag
    !f2py depend(n, p) uk
    !f2py depend(n) cpw

    ! Input
    integer, intent(in) :: n, p
    double precision, intent(in) :: uk(0:n + p + 1)
    double precision, intent(in) :: cpw(0:n, 0:3)
    double precision, intent(in) :: origin(0:2), normal(0:2)
    double precision, intent(in) :: itol

    ! Output
    integer, intent(out) :: flag

    ! Working
    logical :: is_cand, unique
    integer :: i, j
    integer :: nsol, nbez
    double precision :: di, ucheck, a, b
    double precision :: pnorm(0:2)
    double precision :: qw(0:n + p + 1, 0:p, 0:3), ab(0:n + p + 1, 0:1)
    double precision :: qwi(0:p, 0:3), abi(0:1)
    double precision :: p0(0:2), p1(0:2), vi(0:2)

    ! Nelder-Mead
    logical :: success
    double precision :: tol
    double precision :: x(1)

    ! Generic list for storing results.
    type(list_node_t), pointer :: cpi_list => null()
    type(ci_ptr) :: cpi_ptr

    ! Initialize
    nsol = 0
    call list_init(cpi_list)

    ! Make sure a unit normal vector is used.
    di = norm(normal)
    pnorm = normal / di

    ! Step 1: Check bounding box and plane for possible intersection.
    is_cand = candidate_intersect(n, cpw)
    if (is_cand .eqv. .false.) then
        flag = 0
        call list_free(cpi_list)
        call set_empty_results()
        return
    end if

    ! Step 2: Decompose curve into Bezier segments.
    call decompose_curve(n, p, uk, cpw, nbez, qw, ab)

    ! Step 3: Perform recursive subdivision on candidate curves.
    do i = 0, nbez - 1
        qwi = qw(i, :, :)
        abi = ab(i, :)
        is_cand = candidate_intersect(p, qwi)
        if (is_cand) then
            call subdivide(p, qwi, abi)
        end if
    end do

    ! Return if no intersections are found.
    if (nsol .eq. 0) then
        flag = 0
        call list_free(cpi_list)
        call set_empty_results()
        return
    end if

    ! Allocate result arrays.
    call reset_results()
    allocate(points_(nsol, 3))
    allocate(params1d_(nsol))
    points_(:, :) = 0.0d0
    params1d_(:) = 0.0d0
    ! Step 4: Refine intersection points.
    a = uk(0)
    b = uk(n + p + 1)
    tol = itol / 100.0d0
    do i = 1, nsol
        ! Get next
        cpi_list = list_next(cpi_list)
        cpi_ptr = transfer(list_get(cpi_list), cpi_ptr)
        x(1) = cpi_ptr%ci%u0
        ! Call Nelder-Mead.
        call simplex(obj, 1, x, tol, success)
        ! Check parameter domains.
        ucheck = x(1)
        call check_param(n, p, uk, ucheck)
        x(1) = ucheck
        ! Get point and add to results only if unique.
        call curve_point(n, p, uk, cpw, x(1), p0)
        ! Project to plane and use midpoint.
        p1 = p0 - pnorm * dot_product(pnorm, p0 - origin)
        p0 = 0.50d0 * (p0 + p1)
        unique = .true.
        do j = 1, npts_
            p1 = points_(j, :)
            vi = p1 - p0
            di = norm(vi)
            if (di .le. itol) then
                unique = .false.
                exit
            end if
        end do
        if (unique) then
            npts_ = npts_ + 1
            points_(npts_, :) = p0
            params1d_(npts_) = x(1)
        end if
    end do

    ! Return results.
    call list_free(cpi_list)
    flag = 1

    ! Internal subroutines.
    contains

    subroutine obj(nx, x, fx)
        ! Objective function for point refinement.

        ! Input/Output
        integer, intent(in) :: nx
        double precision, intent(in) :: x(nx)
        double precision, intent(out) :: fx

        ! Working
        double precision :: factor
        double precision :: pi(0:2), pj(0:2), r(0:2)

        ! Penalize objective function if variable is outside domain.
        factor = 1.0d0
        if ((x(1) .lt. a) .or. (x(1) .gt. b))  then
            factor = 1000.0d0
        end if

        ! Evaluate curve point and project to plane.
        call curve_point(n, p, uk, cpw, x(1), pi)
        pj = pi - pnorm * dot_product(pnorm, pi - origin)
        r = pi - pj
        fx = norm(r) * factor

    end subroutine obj

    recursive subroutine subdivide(n, cpw, ab)
        ! Recursive subdivision.
        integer, intent(in) :: n
        double precision, intent(in) :: cpw(0:n, 0:3), ab(0:1)

        logical :: flat, candidate
        double precision :: cp(0:n, 0:2), w(0:n), &
                            qw1(0:n, 0:3), qw2(0:n, 0:3), &
                            ab1(0:1), ab2(0:1)

        call dehomogenize_array1d(n, cpw, cp, w)

        call is_curve_flat(n, cp, ftol, flat)

        if (flat) then
            call intersect(n, cp, ab)
        else
            call split_bezier_curve(cpw, n, 0.50d0, ab(0), ab(1), &
                                    qw1, ab1(0), ab1(1), &
                                    qw2, ab2(0), ab2(1))

            candidate = candidate_intersect(n, qw1)
            if (candidate) then
                call subdivide(n, qw1, ab1)
            end if
            candidate = candidate_intersect(n, qw2)
            if (candidate) then
                call subdivide(n, qw2, ab2)
            end if
        end if

    end subroutine subdivide

    subroutine intersect(n, cp, ab)
        ! Intersect line and plane.
        integer, intent(in) :: n
        double precision, intent(in) :: cp(0:n, 0:2), ab(0:1)

        double precision :: p1(0:2), p2(0:2), ui, ug, denom

        p1 = cp(0, :)
        p2 = cp(n, :)
        denom = dot_product(pnorm, p2 - p1)
        if (dabs(denom) .le. 1.0d-12) then
            ug = local_to_global_param(ab(0), ab(1), 0.50d0)
            ! Store result.
            allocate(cpi_ptr%ci)
            cpi_ptr%ci%u0 = ug
            call list_insert(cpi_list, transfer(cpi_ptr, list_data))
            nsol = nsol + 1
        else
            ui = dot_product(pnorm, origin - p1) / denom
            ug = local_to_global_param(ab(0), ab(1), ui)
            ! Store result.
            allocate(cpi_ptr%ci)
            cpi_ptr%ci%u0 = ug
            call list_insert(cpi_list, transfer(cpi_ptr, list_data))
            nsol = nsol + 1
        end if
    end subroutine intersect

    function candidate_intersect(n, cpw) result(candidate)
    ! Check for possible curve-plane intersection.
        integer, intent(in) :: n
        double precision, intent(in) :: cpw(0:n, 0:3)

        logical :: candidate

        double precision :: bbox(0:2, 0:1)

        bbox = curve_bbox(n, cpw)
        candidate = bbox_intersects_plane(bbox, origin, pnorm, itol)

    end function candidate_intersect

end subroutine intersect_curve_plane

subroutine intersect_curve_surface(cn, cp, cuk, cpw, sn, sp, suk, sm, sq, &
                                   svk, spw, itol, flag)
    !> Intersect a curve and a surface.
    !> cn - Number of curve control points - 1.
    !> cp - Degree of curve.
    !> cuk - Knot vector of curve.
    !> cpw - Curve control points.
    !> sn - Number of surface control points - 1 in u-direction.
    !> sp - Degree of surface in u-direction.
    !> suk - Knot vector of surface in u-direction.
    !> sm - Number of surface control points - 1 in v-direction.
    !> sq - Degree of surface in v-direction.
    !> svk - Knot vector of surface in v-direction.
    !> spw - Surface control points.
    !> itol - Intersection tolerance.
    !> flag - Status flag.

    !f2py intent(in) cn, cp, cuk, cpw, sn, sp, suk, sm, sq, svk, spw, itol
    !f2py intent(out) flag
    !f2py depend(cn, cp) cuk
    !f2py depend(cn) cpw
    !f2py depend(sn, sp) suk
    !f2py depend(sm, sq) svk
    !f2py depend(sn, sm) spw

    ! Input
    integer, intent(in) :: cn, cp, sn, sp, sm, sq
    double precision, intent(in) :: cuk(0: cn + cp + 1)
    double precision, intent(in) :: cpw(0:cn, 0:3)
    double precision, intent(in) :: suk(0:sn + sp + 1)
    double precision, intent(in) :: svk(0:sm + sq + 1)
    double precision, intent(in) :: spw(0:sn, 0:sm, 0:3)
    double precision, intent(in) :: itol

    ! Output
    integer, intent(out) :: flag

    ! Working
    integer :: nsol

    logical :: is_cand
    integer :: i, j, k, cbez, sbez_u
    double precision :: cqw(0:cn + cp + 1, 0:cp, 0:3)
    double precision :: cab(0:cn + cp + 1, 0:1)
    double precision :: sqw_u(0:sn + sp + 1, 0:sp, 0:sm, 0:3)
    double precision :: sab_u(0:sn + sp + 1, 0:1)

    double precision :: suk_ui(0:2 * sp - 1)
    double precision :: sqw_ui(0:sp, 0:sm, 0:3)

    integer :: sbez_v
    double precision :: sqw_v(0:sm + sq + 1, 0:sp, 0:sq, 0:3)
    double precision :: sab_v(0:sm + sq + 1, 0:1)

    double precision :: sqwi(0:sp, 0:sq, 0:3)
    double precision :: sabi(0:1, 0:1)

    double precision :: cqwi(0:cp, 0:3)
    double precision :: cabi(0:1)

    logical :: unique
    double precision :: di, ucheck, vcheck, a, b, au, bu, av, bv
    double precision :: pc(0:2), ps(0:2), vi(0:2), p0(0:2), pi(0:2)

    ! Nelder-Mead
    logical :: success
    double precision :: tol
    double precision :: x(3)

    ! Generic list for storing results.
    type(list_node_t), pointer :: csi_list => null()
    type(ci_ptr) :: csi_ptr

    ! Initialize
    nsol = 0
    call list_init(csi_list)

    ! Step 1: Check for possible intersection.
    is_cand = candidate_intersect(cn, cpw, sn, sm, spw)
    if (is_cand .eqv. .false.) then
        flag = 0
        call list_free(csi_list)
        call set_empty_results()
        return
    end if

    ! Step 2: Decompose curve and surface into Bezier segments.
    call decompose_curve(cn, cp, cuk, cpw, cbez, cqw, cab)

    ! Decompose surface into u-direction strips.
    call decompose_surface(sn, sp, suk, sm, sq, svk, spw, 'u', sn + sp + 1, &
                           sp, sm, sbez_u, sqw_u, sab_u)

    ! Step 3: Perform recursive subdivision to find potential intersection points.
    do i = 0, sbez_u - 1
        ! Decompose each strip in v-direction.
        sqw_ui = sqw_u(i, :, :, :)
        suk_ui(0:sp) = sab_u(i, 0)
        suk_ui(sp + 1:) = sab_u(i, 1)
        call decompose_surface(sp, sp, suk_ui, sm, sq, svk, sqw_ui, 'v', &
                               sm + sq + 1, sp, sq, sbez_v, sqw_v, sab_v)
        ! Check each Bezier surface patch with Bezier curve segment.
        do j = 0, sbez_v - 1
            sqwi = sqw_v(j, :, :, :)
            sabi(0, :) = sab_u(i, :)
            sabi(1, :) = sab_v(j, :)
            do k = 0, cbez - 1
                cqwi = cqw(k, :, :)
                cabi = cab(k, :)
                is_cand = candidate_intersect(cp, cqwi, sp, sq, sqwi)
                if (is_cand) then
                    call subdivide(cp, cqwi, cabi, sp, sq, sqwi, sabi)
                end if
            end do
        end do
    end do

    ! Return if not candidate points are found.
    if (nsol .eq. 0) then
        flag = 0
        call list_free(csi_list)
        call set_empty_results()
        return
    end if

    ! Allocate result arrays.
    call reset_results()
    allocate(points_(nsol,  3))
    allocate(params2d_(nsol, 3))
    points_(:, :) = 0.0d0
    params2d_(:, :) = 0.0d0

    ! Step 4: Refine points.
    a = cuk(0)
    b = cuk(cn + cp + 1)
    au = suk(0)
    bu = suk(sn + sp + 1)
    av = svk(0)
    bv = svk(sm + sq + 1)
    tol = itol / 100.0d0
    do i = 1, nsol
        ! Get next
        csi_list = list_next(csi_list)
        csi_ptr = transfer(list_get(csi_list), csi_ptr)
        x(1) = csi_ptr%ci%t
        x(2) = csi_ptr%ci%u
        x(3) = csi_ptr%ci%v
        ! Call Nelder-Mead
        call simplex(obj, 3, x, tol, success)
        ! Check parameter domains.
        ucheck = x(1)
        call check_param(cn, cp, cuk, ucheck)
        x(1) = ucheck
        ucheck = x(2)
        call check_param(sn, sp, suk, ucheck)
        x(2) = ucheck
        vcheck = x(3)
        call check_param(sm, sq, svk, vcheck)
        x(3) = vcheck
        ! Add to results if point is unique.
        call curve_point(cn, cp, cuk, cpw, x(1), pc)
        call surface_point(sn, sp, suk, sm, sq, svk, spw, x(2), x(3), ps)
        vi = pc - ps
        di = norm(vi)
        if (di .le. itol) then
            pi = 0.50d0 * (pc + ps)
            unique = .true.
            do j = 1, npts_
                p0 = points_(j, :)
                vi = pi - p0
                di = norm(vi)
                if (di .le. itol) then
                    unique = .false.
                    exit
                end if
            end do
            if (unique) then
                npts_ = npts_ + 1
                points_(npts_, :) = pi
                params2d_(npts_, :) = x
            end if
        end if
    end do

    ! Normal completion.
    call list_free(csi_list)
    flag = 1

    ! Internal subroutines.
    contains

    subroutine obj(nx, x, fx)
        ! Subroutine for point refinment.
        ! Input/Output
        integer, intent(in) :: nx
        double precision, intent(in) :: x(nx)
        double precision, intent(out) :: fx

        ! Working
        double precision :: factor
        double precision :: r(0:2)
        double precision :: pc(0:2)
        double precision :: ps(0:2)

        ! Penalize objective function if variable is outside domain.
        factor = 1.0d0
        if ((x(1) .lt. a) .or. (x(1) .gt. b))  then
            factor = 1000.0d0
        end if
        if ((x(2) .lt. au) .or. (x(2) .gt. bu))  then
            factor = 1000.0d0
        end if
        if ((x(3) .lt. av) .or. (x(3) .gt. bv))  then
            factor = 1000.0d0
        end if

        ! Evaluate curve and surface point.
        call curve_point(cn, cp, cuk, cpw, x(1), pc)
        call surface_point(sn, sp, suk, sm, sq, svk, spw, x(2), x(3), ps)
        r = pc - ps
        fx = norm(r) * factor

    end subroutine obj

    recursive subroutine subdivide(cn, cpw, cab, sn, sm, spw, sab)
        ! Recursive subdivision.
        ! Input
        integer, intent(in) :: cn, sn, sm
        double precision, intent(in) :: cpw(0:cn, 0:3)
        double precision, intent(in) :: cab(0:1)
        double precision, intent(in) :: spw(0:sn, 0:sm, 0:3)
        double precision, intent(in) :: sab(0:1, 0:1)

        ! Working
        logical :: flat1, flat2, candidate
        double precision :: cpp(0:cn, 0:2), wc(0:cn)
        double precision :: spp(0:sn, 0:sm, 0:2), ws(0:sn, 0:sm)
        double precision :: cqw1(0:cn, 0:3), cqw2(0:cn, 0:3)
        double precision :: cab1(0:1), cab2(0:1)
        double precision :: sqw1(0:sn, 0:sm, 0:3), sab1(0:1, 0:1)
        double precision :: sqw2(0:sn, 0:sm, 0:3), sab2(0:1, 0:1)
        double precision :: sqw3(0:sn, 0:sm, 0:3), sab3(0:1, 0:1)
        double precision :: sqw4(0:sn, 0:sm, 0:3), sab4(0:1, 0:1)
        double precision :: sqw5(0:sn, 0:sm, 0:3), sab5(0:1, 0:1)
        double precision :: sqw6(0:sn, 0:sm, 0:3), sab6(0:1, 0:1)

        call dehomogenize_array1d(cn, cpw, cpp, wc)
        call dehomogenize_array2d(sn, sm, spw, spp, ws)

        call is_curve_flat(cn, cpp, ftol, flat1)
        call is_surface_flat(sn, sm, spp, ftol, flat2)

        if (flat1 .and. flat2) then
            call intersect(cn, cpp, cab, sn, sm, spp, sab)
        else
            call split_bezier_curve(cpw, cn, 0.5d0, cab(0), cab(1), &
                                    cqw1, cab1(0), cab1(1), &
                                    cqw2, cab2(0), cab2(1))
            call split_bezier_surface(spw, sn, sm, 0.5d0, -1.0d0, &
                                      sab(0, 0), sab(0, 1), &
                                      sab(1, 0), sab(1, 1), &
                                      sqw1, sqw2, sab1, sab2)
            call split_bezier_surface(sqw1, sn, sm, -1.0d0, 0.5d0, &
                                      sab1(0, 0), sab1(0, 1), &
                                      sab1(1, 0), sab1(1, 1), &
                                      sqw3, sqw4, sab3, sab4)
            call split_bezier_surface(sqw2, sn, sm, -1.0d0, 0.5d0, &
                                      sab2(0, 0), sab2(0, 1), &
                                      sab2(1, 0), sab2(1, 1), &
                                      sqw5, sqw6, sab5, sab6)
            ! Curve 1 and all surfaces.
            candidate = candidate_intersect(cn, cqw1, sn, sm, sqw3)
            if (candidate) then
                call subdivide(cn, cqw1, cab1, sn, sm, sqw3, sab3)
            end if
            candidate = candidate_intersect(cn, cqw1, sn, sm, sqw4)
            if (candidate) then
                call subdivide(cn, cqw1, cab1, sn, sm, sqw4, sab4)
            end if
            candidate = candidate_intersect(cn, cqw1, sn, sm, sqw5)
            if (candidate) then
                call subdivide(cn, cqw1, cab1, sn, sm, sqw5, sab5)
            end if
            candidate = candidate_intersect(cn, cqw1, sn, sm, sqw6)
            if (candidate) then
                call subdivide(cn, cqw1, cab1, sn, sm, sqw6, sab6)
            end if
            ! Curve 2 and all surfaces.
            candidate = candidate_intersect(cn, cqw2, sn, sm, sqw3)
            if (candidate) then
                call subdivide(cn, cqw2, cab2, sn, sm, sqw3, sab3)
            end if
            candidate = candidate_intersect(cn, cqw2, sn, sm, sqw4)
            if (candidate) then
                call subdivide(cn, cqw2, cab2, sn, sm, sqw4, sab4)
            end if
            candidate = candidate_intersect(cn, cqw2, sn, sm, sqw5)
            if (candidate) then
                call subdivide(cn, cqw2, cab2, sn, sm, sqw5, sab5)
            end if
            candidate = candidate_intersect(cn, cqw2, sn, sm, sqw6)
            if (candidate) then
                call subdivide(cn, cqw2, cab2, sn, sm, sqw6, sab6)
            end if
        end if

    end subroutine subdivide

    subroutine intersect(cn, cpp, cab, sn, sm, spp, sab)
        ! Intersect line-plane.
        integer, intent(in) :: cn, sn, sm
        double precision, intent(in) :: cpp(0:cn, 0:2)
        double precision, intent(in) :: cab(0:1)
        double precision, intent(in) :: spp(0:sn, 0:sm, 0:2)
        double precision, intent(in) :: sab(0:1, 0:1)

        double precision :: ti, t, u, v, mag, denom
        double precision :: p0(0:2), vu(0:2), vv(0:2), p1(0:2)
        double precision :: p2(0:2), pnorm(0:2), pi(0:2)
        double precision :: t3d(0:2, 0:2), t2d(0:2, 0:1)

        p0 = spp(0, 0, :)
        vu = spp(sn, 0, :) - p0
        vv = spp(0, sm, :) - p0
        p1 = cpp(0, :)
        p2 = cpp(cn, :)
        pnorm = cross(vu, vv)
        mag = norm(pnorm)
        pnorm = pnorm / mag
        denom = dot_product(pnorm, p2 - p1)
        if (dabs(denom) .le. 1.0d-12) then
            t = local_to_global_param(cab(0), cab(1), 0.50d0)
            u = local_to_global_param(sab(0, 0), sab(0, 1), 0.50d0)
            v = local_to_global_param(sab(1, 0), sab(1, 1), 0.50d0)
            ! Store result.
            allocate(csi_ptr%ci)
            csi_ptr%ci%t = t
            csi_ptr%ci%u = u
            csi_ptr%ci%v = v
            call list_insert(csi_list, transfer(csi_ptr, list_data))
            nsol = nsol + 1
        else
            ti = dot_product(pnorm, p0 - p1) / denom
            t = local_to_global_param(cab(0), cab(1), ti)
            pi = p1 + ti * (p2 - p1)
            t3d(0, :) = spp(0, 0, :)
            t3d(1, :) = spp(sn, 0, :)
            t3d(2, :) = spp(0, sm, :)
            t2d(0, :) = (/ sab(0, 0), sab(1, 0) /)
            t2d(1, :) = (/ sab(0, 1), sab(1, 0) /)
            t2d(2, :) = (/ sab(0, 0), sab(1, 1) /)
            call invert_point_in_triangle(pi, t3d, t2d, u, v)
            ! Store result.
            allocate(csi_ptr%ci)
            csi_ptr%ci%t = t
            csi_ptr%ci%u = u
            csi_ptr%ci%v = v
            call list_insert(csi_list, transfer(csi_ptr, list_data))
            nsol = nsol + 1
        end if

    end subroutine intersect

    function candidate_intersect(cn, cpw, sn, sm, spw) result(candidate)
        ! Check for possible curve-surface intersection.
        integer, intent(in) :: cn, sn, sm
        double precision, intent(in) :: cpw(0:cn, 0:3)
        double precision, intent(in) :: spw(0:sn, 0:sm, 0:3)

        logical :: candidate

        double precision :: bbox1(0:2, 0:1), bbox2(0:2, 0:1)

        bbox1 = curve_bbox(cn, cpw)
        bbox2 = surface_bbox(sn, sm, spw)
        candidate = bboxes_intersect(3, bbox1, bbox2, itol)

    end function candidate_intersect

end subroutine intersect_curve_surface

end module intersect_curve


      SUBROUTINE MB04TU( N, X, INCX, Y, INCY, C, S )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To perform the Givens transformation, defined by C (cos) and S
C     (sin), and interchange the vectors involved, i.e.
C
C        |X(i)|    | 0   1 |   | C   S |   |X(i)|
C        |    | := |       | x |       | x |    |, i = 1,...N.
C        |Y(i)|    | 1   0 |   |-S   C |   |Y(i)|
C
C     REMARK. This routine is a modification of DROT from BLAS.
C             This routine is called only by the SLICOT routines MB04TX
C             and MB04VX.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB04FU by Th.G.J. Beelen,
C     Philips Glass Eindhoven, Holland.
C
C     REVISIONS
C
C     January 26, 1998.
C
C     KEYWORDS
C
C     Othogonal transformation.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           INCX, INCY, N
      DOUBLE PRECISION  C, S
C     .. Array Arguments ..
      DOUBLE PRECISION  X(*), Y(*)
C     .. Local Scalars ..
      DOUBLE PRECISION  DTEMP
      INTEGER           I, IX, IY
C     .. Executable Statements ..
C
      IF ( N.LE.0 ) RETURN
      IF ( ( INCX.NE.1 ) .OR. ( INCY.NE.1 ) ) THEN
C
C        Code for unequal increments or equal increments not equal to 1.
C
         IX = 1
         IY = 1
         IF ( INCX.LT.0 ) IX = (-N+1)*INCX + 1
         IF ( INCY.LT.0 ) IY = (-N+1)*INCY + 1
C
         DO 20 I = 1, N
            DTEMP = C*Y(IY) - S*X(IX)
            Y(IY) = C*X(IX) + S*Y(IY)
            X(IX) = DTEMP
            IX = IX + INCX
            IY = IY + INCY
   20    CONTINUE
C
      ELSE
C
C        Code for both increments equal to 1.
C
         DO 40 I = 1, N
            DTEMP = C*Y(I) - S*X(I)
            Y(I) = C*X(I) + S*Y(I)
            X(I) = DTEMP
   40    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of MB04TU ***
      END


!
!	Print weighted sum totals by item categories.
!	itemname contains item names.
!	wtname is the weight name.
!	numcatobs counts observed categories.
!	unitmarginwtitem provides the unit for output.
!	resid indicates if residuals are displayed.
!	fitpwtitem is the  fitted average of products.
!	fitwtitem is the fitted total of products.
!	obspwtitem is the observed average of products.
!	obsmargwtitem is the observed total of products.
!	presentedwtitem counts weighted items presented with items.
!	residawtitem is the adjusted residual.
!	residpwtitem is the residual for the average of products.
!	residwtitem is the residual for the total of products.
!	stdobspwtitem is the standard deviation of the observed average of products.
!	stdobswtitem is the asymptotic standard deviation of the observed
!		total of products.
!	stdresidpwtitem is the asymptotic standard error for the residual for average
!       of products.
!	stdresidwtitem is the asymptotic standard error for the residual for total
!       of products.

subroutine printmarginwtitem(itemname,wtname,numcatobs,unitmarginwtitem,&
    resid,fitpwtitem,fitwtitem,obspwtitem,obswtitem,presentedwtitem,&
    residawtitem,residpwtitem,residwtitem,&
    stdobspwtitem,stdobswtitem,stdresidpwtitem,stdresidwtitem)
implicit none
character(len=*),intent(in)::itemname(:)
character(len=*),intent(in)::wtname
integer,intent(in)::numcatobs(:),unitmarginwtitem
logical,intent(in)::resid
real(kind=8),intent(in)::fitpwtitem(:),fitwtitem(:),&
    obspwtitem(:),obswtitem(:),presentedwtitem(:),&
    residawtitem(:),residpwtitem(:),residwtitem(:),&
    stdobspwtitem(:),stdobswtitem(:),stdresidpwtitem(:),stdresidwtitem(:)
!	buff1 and buff are buffers.
character(len=12)::buff1
character(len=25)::buff(15)

!	cat counts categories.
!	counter counts positions.
!	io is the flag for output error.
!	item counts items.
!	row counts rows.
integer::cat,counter,io,item,row
!	var is a variance.
real(kind=8)::var
counter=1
write(unit=unitmarginwtitem,fmt='(2a)',iostat=io) 'Totals and averages of products for ',wtname

if(io/=0) stop "Printing of marginal distribution failed."
if(resid)then
	write(unit=unitmarginwtitem,fmt='(27a)',iostat=io) "Item_name",",",&
		"Cat_no",",","Item_freq",",","Obs_tot_prod",",","Std_err_obs_tot_prod",",",&
		"Fit_tot_prod",",","Obs_ave_prod",",","Std_err_obs_ave_prod",",",&
		"Fit_ave_prod",",",&
		"Res_tot_prod",",","Std_err_res_tot_prod",",",&
		"Res_ave_prod",",","Std_err_res_ave_prod",",",&
		"Adjusted_residual"
else
	write(unit=unitmarginwtitem,fmt='(17a)',iostat=io) "Item_name",",",&
        "Cat_no",",","Item_freq",",","Obs_tot_prod",",",&
        "Std_err_obs_tot_prod",",",&
        "Fit_tot_prod",",","Obs_ave_prod",",","Std_err_obs_ave_prod",",",&
        "Fit_ave_prod"
end if

do item=1,size(itemname)
	do cat=1,numcatobs(item)
		write(buff1,'(i12)') cat-1
		write(buff(1),'(g25.16e3)') presentedwtitem(item)
		write(buff(2),'(g25.16e3)') obswtitem(counter)
		write(buff(3),'(g25.16e3)') stdobswtitem(counter)
		write(buff(4),'(g25.16e3)') fitwtitem(counter)
		write(buff(5),'(g25.16e3)') obspwtitem(counter)
		write(buff(6),'(g25.16e3)') stdobspwtitem(counter)
		write(buff(7),'(g25.16e3)') fitpwtitem(counter)
		if(resid)then
			write(buff(8),'(g25.16e3)') residwtitem(counter)
			write(buff(9),'(g25.16e3)') stdresidwtitem(counter)
			write(buff(10),'(g25.16e3)') residpwtitem(counter)
			write(buff(11),'(g25.16e3)') stdresidpwtitem(counter)
			write(buff(12),'(g25.16e3)') residawtitem(counter)
			write(unit=unitmarginwtitem,fmt='(27a)',iostat=io)trim(adjustl(itemname(item))),",",trim(adjustl(buff1)),&
				(",",trim(adjustl(buff(row))),row=1,12)
		else
			write(unit=unitmarginwtitem,fmt='(17a)',iostat=io)trim(adjustl(itemname(item))),",",trim(adjustl(buff1)),&
				(",",trim(adjustl(buff(row))),row=1,7)
		end if
		if(io/=0) stop "Printing of product summaries failed."
		counter=counter+1
	end do
end do
return
end subroutine printmarginwtitem


      subroutine f1 (neq, t, y, ydot)
      integer neq
      double precision t, y, ydot
      dimension y(1), ydot(1)
      dimension neq(*)
      ydot(1) = ((2.0d0*log(y(1)) + 8.0d0)/t - 5.0d0)*y(1)
      return
      end


! =====================================================================
! subroutine RHSR
!
! This subroutine computes the matrix-vector multiplication required to
! construct the right-hand side vector of the Peaceman-Rachford step
! involving the radial kinetic energy terms. It has been modified for
! imaginary time propagation.
! ---------------------------------------------------------------------
      subroutine RHSR(nRP,nR,nP,dT,TRL,TRD,TRU,V,U,UT)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: dT
      double precision :: TRL(nR-1)
      double precision :: TRD(nR)
      double precision :: TRU(nR-1)
      double precision :: V(nRP)
      double complex :: U(nRP)
      double complex :: UT(nRP)

      integer :: i
      integer :: j
      integer :: k

      k = 0
      do j = 1, nP
         k = k + 1
         UT(k) = dcmplx(1.0d0-0.5d0*dT*TRD(1)-0.25d0*dT*V(k),0.0d0)*U(k)
         UT(k) = UT(k)+dcmplx(0.5d0*dT*TRU(1),0.0d0)*U(k+1)
         do i = 2, nR-1
            k = k + 1
            UT(k) = dcmplx(0.5d0*dT*TRL(i-1),0.0d0)*U(k-1)
            UT(k) = UT(k)+dcmplx(1.0d0-0.5d0*dT*TRD(i)- 0.25d0*dT*V(k),0.0d0)*U(k)
            UT(k) = UT(k)+dcmplx(0.5d0*dT*TRU(i),0.0d0)*U(k+1)
         enddo
         k = k + 1
         UT(k) = dcmplx(0.5d0*dT*TRL(nR-1),0.0d0)*U(k-1)
         UT(k) = UT(k)+dcmplx(1.0d0-0.5d0*dT*TRD(nR)- 0.25d0*dT*V(k),0.0d0)*U(k)
      enddo

      do k = 1, nRP
         U(k) = UT(k)
      enddo

      return
      end
! =====================================================================


      SUBROUTINE SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO )
*
*  -- LAPACK auxiliary test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     June 2010
*
*     .. Scalar Arguments ..
      INTEGER            IDIST, INFO, IRSIGN, MODE, N
      REAL               COND
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      REAL               D( * )
*     ..
*
*  Purpose
*  =======
*
*     SLATM1 computes the entries of D(1..N) as specified by
*     MODE, COND and IRSIGN. IDIST and ISEED determine the generation
*     of random numbers. SLATM1 is called by SLATMR to generate
*     random test matrices for LAPACK programs.
*
*  Arguments
*  =========
*
*  MODE     (input) INTEGER
*           On entry describes how D is to be computed:
*           MODE = 0 means do not change D.
*           MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
*           MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
*           MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
*           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
*           MODE = 5 sets D to random numbers in the range
*                    ( 1/COND , 1 ) such that their logarithms
*                    are uniformly distributed.
*           MODE = 6 set D to random numbers from same distribution
*                    as the rest of the matrix.
*           MODE < 0 has the same meaning as ABS(MODE), except that
*              the order of the elements of D is reversed.
*           Thus if MODE is positive, D has entries ranging from
*              1 to 1/COND, if negative, from 1/COND to 1,
*           Not modified.
*
*  COND     (input) REAL
*           On entry, used as described under MODE above.
*           If used, it must be >= 1. Not modified.
*
*  IRSIGN   (input) INTEGER
*           On entry, if MODE neither -6, 0 nor 6, determines sign of
*           entries of D
*           0 => leave entries of D unchanged
*           1 => multiply each entry of D by 1 or -1 with probability .5
*
*  IDIST    (input) CHARACTER*1
*           On entry, IDIST specifies the type of distribution to be
*           used to generate a random matrix .
*           1 => UNIFORM( 0, 1 )
*           2 => UNIFORM( -1, 1 )
*           3 => NORMAL( 0, 1 )
*           Not modified.
*
*  ISEED    (input/output) INTEGER array, dimension ( 4 )
*           On entry ISEED specifies the seed of the random number
*           generator. The random number generator uses a
*           linear congruential sequence limited to small
*           integers, and so should produce machine independent
*           random numbers. The values of ISEED are changed on
*           exit, and can be used in the next call to SLATM1
*           to continue the same random number sequence.
*           Changed on exit.
*
*  D        (input/output) REAL array, dimension ( MIN( M , N ) )
*           Array to be computed according to MODE, COND and IRSIGN.
*           May be changed on exit if MODE is nonzero.
*
*  N        (input) INTEGER
*           Number of entries of D. Not modified.
*
*  INFO     (output) INTEGER
*            0  => normal termination
*           -1  => if MODE not in range -6 to 6
*           -2  => if MODE neither -6, 0 nor 6, and
*                  IRSIGN neither 0 nor 1
*           -3  => if MODE neither -6, 0 nor 6 and COND less than 1
*           -4  => if MODE equals 6 or -6 and IDIST not in range 1 to 3
*           -7  => if N negative
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E0 )
      REAL               HALF
      PARAMETER          ( HALF = 0.5E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      REAL               ALPHA, TEMP
*     ..
*     .. External Functions ..
      REAL               SLARAN
      EXTERNAL           SLARAN
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLARNV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, EXP, LOG, REAL
*     ..
*     .. Executable Statements ..
*
*     Decode and Test the input parameters. Initialize flags & seed.
*
      INFO = 0
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Set INFO if an error
*
      IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN
         INFO = -1
      ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $         ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN
         INFO = -2
      ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $         COND.LT.ONE ) THEN
         INFO = -3
      ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND.
     $         ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -7
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLATM1', -INFO )
         RETURN
      END IF
*
*     Compute D according to COND and MODE
*
      IF( MODE.NE.0 ) THEN
         GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE )
*
*        One large D value:
*
   10    CONTINUE
         DO 20 I = 1, N
            D( I ) = ONE / COND
   20    CONTINUE
         D( 1 ) = ONE
         GO TO 120
*
*        One small D value:
*
   30    CONTINUE
         DO 40 I = 1, N
            D( I ) = ONE
   40    CONTINUE
         D( N ) = ONE / COND
         GO TO 120
*
*        Exponentially distributed D values:
*
   50    CONTINUE
         D( 1 ) = ONE
         IF( N.GT.1 ) THEN
            ALPHA = COND**( -ONE / REAL( N-1 ) )
            DO 60 I = 2, N
               D( I ) = ALPHA**( I-1 )
   60       CONTINUE
         END IF
         GO TO 120
*
*        Arithmetically distributed D values:
*
   70    CONTINUE
         D( 1 ) = ONE
         IF( N.GT.1 ) THEN
            TEMP = ONE / COND
            ALPHA = ( ONE-TEMP ) / REAL( N-1 )
            DO 80 I = 2, N
               D( I ) = REAL( N-I )*ALPHA + TEMP
   80       CONTINUE
         END IF
         GO TO 120
*
*        Randomly distributed D values on ( 1/COND , 1):
*
   90    CONTINUE
         ALPHA = LOG( ONE / COND )
         DO 100 I = 1, N
            D( I ) = EXP( ALPHA*SLARAN( ISEED ) )
  100    CONTINUE
         GO TO 120
*
*        Randomly distributed D values from IDIST
*
  110    CONTINUE
         CALL SLARNV( IDIST, ISEED, N, D )
*
  120    CONTINUE
*
*        If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
*        random signs to D
*
         IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND.
     $       IRSIGN.EQ.1 ) THEN
            DO 130 I = 1, N
               TEMP = SLARAN( ISEED )
               IF( TEMP.GT.HALF )
     $            D( I ) = -D( I )
  130       CONTINUE
         END IF
*
*        Reverse if MODE < 0
*
         IF( MODE.LT.0 ) THEN
            DO 140 I = 1, N / 2
               TEMP = D( I )
               D( I ) = D( N+1-I )
               D( N+1-I ) = TEMP
  140       CONTINUE
         END IF
*
      END IF
*
      RETURN
*
*     End of SLATM1
*
      END


C
C
C       $Id: interp.f,v 1.1 1994-08-11 23:17:27 boote Exp $
C
C This subprogram is used by subroutines TERP1 and TERP2 in
C library ncarm.  It is lower-level, i.e. not called by users.
C *************************************************************
      SUBROUTINE INTERP (N,X,F,W,Y,I,INT,TAB,ITAB)
      DIMENSION       X(1)       ,F(1)       ,W(1)       ,TAB(3)
     -                ,ITAB(3)
      SAVE
C
C ARITHMETIC STATEMENT FUNCTION USED TO LOCATE ENTRIES IN F AND W ARRAYS
C
      II(INDEX)=(INDEX-1)*INT+1
C
C PERFORM INTERPOLATION OR EXTRAPOLATION
C
      FLK = X(I+1)-X(I)
      FLP = X(I+1)-Y
      FL0 = Y-X(I)
      I0 = II(I)
      IP = I0+INT
      IF (ITAB(1) .NE. 0) GO TO 101
      GO TO 102
  101 CONTINUE
C
C CALCULATE F(Y)
C
      A = (W(I0)*FLP**3+W(IP)*FL0**3)/(6.*FLK)
      B = (F(IP)/FLK-W(IP)*FLK/6.)*FL0
      C = (F(I0)/FLK-W(I0)*FLK/6.)*FLP
      TAB(1) = A+B+C
  102 CONTINUE
      IF (ITAB(2) .NE. 0) GO TO 103
      GO TO 104
  103 CONTINUE
C
C CALCULATE FIRST DERIVATIVE AT Y
C
      A = (W(IP)*FL0**2-W(I0)*FLP**2)/(2.*FLK)
      B = (F(IP)-F(I0))/FLK
      C = (W(I0)-W(IP))*FLK/6.
      TAB(2) = A+B+C
  104 CONTINUE
      IF (ITAB(3) .NE. 0) GO TO 105
      GO TO 106
  105 CONTINUE
C
C CALCULATE SECOND DERIVATIVE AT Y
C
      TAB(3) = (W(I0)*FLP+W(IP)*FL0)/FLK
  106 CONTINUE
      RETURN
      END


      SUBROUTINE ZL1NRM (N,Z,ZNORM)
      INTEGER N
      DOUBLE PRECISION ZNORM
      DOUBLE COMPLEX Z(N)
C
C     *** PURPOSE:
C
C     ZL1NRM COMPUTES AN L1-TYPE NORM OF A COMPLEX N-VECTOR Z AND
C     SCALES THE VECTOR Z BY THIS NORM.  SPECIFICALLY, THE NORM OF Z
C     IS DETERMINED AS THE SUMMATION OF  DABS(RE(Z(I)))+DABS(IM(Z(I)))
C     FOR I FROM 1 TO N WHERE RE(Z(I)) AND IM(Z(I)) ARE THE REAL AND
C     IMAGINARY PARTS, RESPECTIVELY, OF THE I-TH COMPONENT OF Z.
C
C     ON ENTRY:
C
C        N     INTEGER
C              THE LENGTH OF THE VECTOR Z.
C
C        Z     DOUBLE COMPLEX(N)
C              THE VECTOR WHICH IS TO BE SCALED BY ITS NORM.
C
C     ON RETURN:
C
C        ZNORM DOUBLE PRECISION
C              THE NORM OF THE VECTOR Z.
C
C        Z     THE VECTOR Z SCALED BY ZNORM.
C
C     THIS VERSION DATED JULY 1981.
C     ALAN J. LAUB, UNIVERSITY OF SOUTHERN CALIFORNIA.
C
C     INTERNAL VARIABLES:
C
      INTEGER I
      DOUBLE COMPLEX T,ZDUM
C
C     FORTRAN FUNCTIONS CALLED:
C
      DOUBLE PRECISION DABS
      DOUBLE COMPLEX DCMPLX
C
C     INTERNAL FUNCTIONS:
C
      DOUBLE PRECISION DIMAG,DREAL
      DREAL(ZDUM) = ZDUM
      DIMAG(ZDUM) = (0.0D0,-1.0D0)*ZDUM
C
      ZNORM = 0.0D0
      DO 10 I = 1,N
         ZNORM = ZNORM+DABS(DREAL(Z(I)))+DABS(DIMAG(Z(I)))
   10 CONTINUE
      IF (ZNORM .EQ. 0.0D0) RETURN
      T = DCMPLX((1.0D0/ZNORM),0.0D0)
      DO 20 I = 1,N
         Z(I) = T*Z(I)
   20 CONTINUE
      RETURN
      END


c---------------------------------------------------------------------
c---------------------------------------------------------------------
      subroutine setiv

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c   set the initial values of independent variables based on tri-linear
c   interpolation of boundary values in the computational space.
c
c---------------------------------------------------------------------

      implicit none

      include 'applu.incl'

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m
      double precision  xi, eta, zeta
      double precision  pxi, peta, pzeta
      double precision  ue_1jk(5),ue_nx0jk(5),ue_i1k(5),
     >        ue_iny0k(5),ue_ij1(5),ue_ijnz(5)

      do k = 2, nz - 1
         zeta = ( dble (k-1) ) / (nz-1)
         do j = 2, ny - 1
            eta = ( dble (j-1) ) / (ny0-1)
            do i = 2, nx - 1
               xi = ( dble (i-1) ) / (nx0-1)
               call exact (1,j,k,ue_1jk)
               call exact (nx0,j,k,ue_nx0jk)
               call exact (i,1,k,ue_i1k)
               call exact (i,ny0,k,ue_iny0k)
               call exact (i,j,1,ue_ij1)
               call exact (i,j,nz,ue_ijnz)
               do m = 1, 5
                  pxi =   ( 1.0d+00 - xi ) * ue_1jk(m)
     >                              + xi   * ue_nx0jk(m)
                  peta =  ( 1.0d+00 - eta ) * ue_i1k(m)
     >                              + eta   * ue_iny0k(m)
                  pzeta = ( 1.0d+00 - zeta ) * ue_ij1(m)
     >                              + zeta   * ue_ijnz(m)

                  u( m, i, j, k ) = pxi + peta + pzeta
     >                 - pxi * peta - peta * pzeta - pzeta * pxi
     >                 + pxi * peta * pzeta

               end do
            end do
         end do
      end do

      return
      end


      SUBROUTINE geteigm(ad, asup, asub, n, eigm, eigf)
      USE stel_kinds
      USE ballooning_data
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: n
      REAL(rprec), INTENT(IN), DIMENSION(n) :: ad
      REAL(rprec), INTENT(IN), DIMENSION(n-1) ::asup, asub
      REAL(rprec), INTENT(OUT) :: eigm
      REAL(rprec), INTENT(OUT),DIMENSION(n) :: eigf
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: j
      REAL(rprec), DIMENSION(:), ALLOCATABLE :: w, w2
      REAL(rprec):: MAXm, MINm, norm
!-------------------------------------------------------------------------------------
      ALLOCATE (w(n), w2(4*n), stat = j)
      IF (j .ne. 0) STOP 'Allocation error in COBRA geteigm'

      IF (ANY(asub*asup < 0)) THEN
         lfail_balloon = .TRUE.
         RETURN
      END IF

      CALL TVAL(eigm, -kth, asub, ad, asup, n, w)
      CALL TVECT(eigm, eigf, asub, ad, asup, n, w2)

      DEALLOCATE (w, w2)

      MAXm=MAXVAL(eigf)
      MINm=MINVAL(eigf)
      norm=MAX(ABS(maxm),ABS(minm))

      IF(norm.eq.ABS(maxm))norm=maxm
      IF(norm.eq.ABS(minm))norm=minm
      eigf=eigf/norm                                               ! normalize eigenfunction to unity at maximum
      eigm=-eigm                                                   ! convert to Sturm-Liouville eigenvalue

      END SUBROUTINE geteigm


module multiscaleNewLib
use funcAux
use globalVariables , only : NdimE
use TIME_STEP_ITER
use DETERMINANT, only : iElem

implicit none

public updateBifurcationState ,  Dhom, PKhom , writeBifurcationState
private getQ, getQbar

real*8 , allocatable :: Dhom(:,:,:,:) , PKhom(:,:)
real*8 :: minDetQ, minDetQbar, thetaCrit, betaCrit, thetaBarCrit, betaBarCrit

real*8, allocatable :: detQ_vec(:), detQbar_vec(:), theta_vec(:), betaBar_vec(:)

contains

subroutine initMultiscaleNewLib()
	allocate(Dhom(NdimE,NdimE,NdimE,NdimE) , PKhom(NdimE,NdimE))
end subroutine

subroutine getQ(Q,normal)
	real*8 , intent(out) :: Q(:,:)
	real*8 , intent(in) :: normal(:)
	integer :: i,j,k,l

	Q = 0.0d0
	do i = 1 , NdimE
	do j = 1 , NdimE
	do k = 1 , NdimE
	do l = 1 , NdimE
		Q(i,k) = Q(i,k) + Dhom(i,j,k,l)*normal(j)*normal(l)
	end do
	end do
	end do
	end do

end subroutine

subroutine getQbar(Qbar,beta)
	real*8 , intent(out) :: Qbar(:,:)
	real*8 , intent(in) :: beta(:)
	integer :: i,j,k,l

	Qbar = 0.0d0
	do i = 1 , NdimE
	do j = 1 , NdimE
	do k = 1 , NdimE
	do l = 1 , NdimE
		Qbar(j,l) = Qbar(j,l) + Dhom(i,j,k,l)*beta(i)*beta(k)
	end do
	end do
	end do
	end do

end subroutine

subroutine updateBifurcationState(nStepAngle,storeDetQ_vec)
	integer , intent(in) :: nStepAngle, storeDetQ_vec

	real*8 :: Q(NdimE,NdimE), Qbar(NdimE,NdimE), normal(NdimE), betaVec(NdimE), detQ, detQbar, angle, stepAngle
	integer :: n

	if((storeDetQ_vec == 1) .and. (.not. allocated(detQ_vec))) then
		allocate(detQ_vec(nStepAngle), detQbar_vec(nStepAngle), theta_vec(nStepAngle), betaBar_vec(nStepAngle))
	end if

	stepAngle = PI/real(NstepAngle)

	angle = -0.5*PI

	do n = 1 , NstepAngle

		normal(1) = dcos(angle)
		normal(2) = dsin(angle)

		betaVec(1) = dcos(angle)
		betaVec(2) = dsin(angle)

		call getQ(Q,normal)
		call getQbar(Qbar,betaVec)

		call MatDet(detQ,Q)
		call MatDet(detQbar,Qbar)

!~ 		call numprint(Q)
!~ 		call numprint(Qbar)

!~ 		pause

		if(storeDetQ_vec == 1) then
			theta_vec(n) = angle
			betaBar_vec(n) = angle
			detQ_vec(n) = detQ
			detQbar_vec(n) = detQbar
		end if

		if(n==1 .or. detQ<minDetQ) then
			minDetQ = detQ
			thetaCrit = angle
			betaCrit = datan2(Q(1,1),-Q(1,2)) ! only valid for 2D
		end if

		if(n==1 .or. detQbar<minDetQbar) then
			minDetQbar = detQbar
			betaBarCrit = angle
			thetaBarCrit = datan2(Qbar(1,1),-Qbar(1,2)) ! only valid for 2D
		end if

		angle = angle + stepAngle

	end do

end subroutine

subroutine writeBifurcationState(storeDetQ_vec)
	integer , intent(in) :: storeDetQ_vec
	integer, parameter :: OUnit_Q = 15, OUnit_Qbar = 16, OUnit_detQ = 17, OUnit_detQbar=18 , OUnit_Dhom = 19

	if(Nstep == 0) then ! Nstep starts in zero
		open (OUnit_Q, file='bifState.txt')
		open (OUnit_Qbar, file='bifStateBar.txt')
		open (OUnit_Dhom, file='Dhom.txt')

		if(storeDetQ_vec == 1) then
			open (OUnit_detQ, file='detQ.txt')
			open (OUnit_detQbar, file='detQbar.txt')
			write(OUnit_detQ,*) theta_vec
			write(OUnit_detQbar,*) betaBar_vec
		end if
	end if

	write(OUnit_Q,*) minDetQ , thetaCrit, betaCrit
	write(OUnit_Qbar,*) minDetQbar , thetaBarCrit, betaBarCrit
	write(OUnit_Dhom,*) transposeT4(Dhom)

	if(storeDetQ_vec == 1) then
		write(OUnit_detQ,*) detQ_vec
		write(OUnit_detQbar,*) detQbar_vec
	end if

end subroutine

end module


*DECK PRVEC
      FUNCTION PRVEC (M, U, V)
C***BEGIN PROLOGUE  PRVEC
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (PRVEC-S, DPRVEC-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C  This subroutine computes the inner product of a vector U
C  with the imaginary product or mate vector corresponding to V
C
C***SEE ALSO  BVSUP
C***ROUTINES CALLED  SDOT
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  PRVEC
C
      DIMENSION U(*),V(*)
C***FIRST EXECUTABLE STATEMENT  PRVEC
      N=M/2
      NP=N+1
      VP=SDOT(N,U(1),1,V(NP),1)
      PRVEC=SDOT(N,U(NP),1,V(1),1) - VP
      RETURN
      END


!==============================================================================!
  subroutine Grad_Mod_For_Phi(grid, phi, i, phii, boundary)
!------------------------------------------------------------------------------!
!   Calculates gradient of generic variable phi by a least squares method.     !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Comm_Mod
  use Grid_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
  integer         :: i
  real            :: phi (-grid % n_bnd_cells:grid % n_cells),  &
                     phii(-grid % n_bnd_cells:grid % n_cells)
  logical         :: boundary
!-----------------------------------[Locals]-----------------------------------!
  integer :: s, c1, c2
  real    :: dphi1, dphi2, dx_c1, dy_c1, dz_c1, dx_c2, dy_c2, dz_c2
!==============================================================================!

  call Comm_Mod_Exchange_Real(grid, phi)

  phii(1:grid % n_cells) = 0.

  if(i .eq. 1) then
    do s = 1, grid % n_faces
      c1 = grid % faces_c(1,s)
      c2 = grid % faces_c(2,s)
      dx_c1 = grid % dx(s)
      dy_c1 = grid % dy(s)
      dz_c1 = grid % dz(s)
      dx_c2 = grid % dx(s)
      dy_c2 = grid % dy(s)
      dz_c2 = grid % dz(s)
      dphi1 = phi(c2)-phi(c1)
      dphi2 = phi(c2)-phi(c1)

      if(c2 < 0) then
        if(Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. SYMMETRY) then
          dphi1 = 0.
          dphi2 = 0.
        end if
      end if

      if(boundary) then
        phii(c1) = phii(c1) + dphi1*(g(1,c1)*dx_c1  &
                                   + g(4,c1)*dy_c1  &
                                   + g(5,c1)*dz_c1)
        if(c2 > 0) then
          phii(c2) = phii(c2) + dphi2*(g(1,c2)*dx_c2  &
                                     + g(4,c2)*dy_c2  &
                                     + g(5,c2)*dz_c2)
        end if
      else
        if(c2 > 0) then
          phii(c1) = phii(c1) + dphi1*(g(1,c1)*dx_c1  &
                                     + g(4,c1)*dy_c1  &
                                     + g(5,c1)*dz_c1)
          phii(c2) = phii(c2) + dphi2*(g(1,c2)*dx_c2  &
                                     + g(4,c2)*dy_c2  &
                                     + g(5,c2)*dz_c2)
        end if
      end if
    end do
  end if

  if(i .eq. 2) then
    do s = 1, grid % n_faces
      c1 = grid % faces_c(1,s)
      c2 = grid % faces_c(2,s)
      dx_c1 = grid % dx(s)
      dy_c1 = grid % dy(s)
      dz_c1 = grid % dz(s)
      dx_c2 = grid % dx(s)
      dy_c2 = grid % dy(s)
      dz_c2 = grid % dz(s)
      dphi1 = phi(c2)-phi(c1)
      dphi2 = phi(c2)-phi(c1)

      if(c2 < 0) then
        if(Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. SYMMETRY) then
          dphi1 = 0.
          dphi2 = 0.
        end if
      end if

      if(boundary) then
        phii(c1) = phii(c1) + dphi1*(g(4,c1)*dx_c1 +  &
                                     g(2,c1)*dy_c1 +  &
                                     g(6,c1)*dz_c1)
        if(c2  > 0) then
          phii(c2) = phii(c2) + dphi2*(g(4,c2)*dx_c2 +  &
                                       g(2,c2)*dy_c2 +  &
                                       g(6,c2)*dz_c2)
        end if
      else
        if(c2  > 0) then
          phii(c1) = phii(c1) + dphi1*(g(4,c1)*dx_c1 +  &
                                       g(2,c1)*dy_c1 +  &
                                       g(6,c1)*dz_c1)
          phii(c2) = phii(c2) + dphi2*(g(4,c2)*dx_c2 +  &
                                       g(2,c2)*dy_c2 +  &
                                       g(6,c2)*dz_c2)
        end if
      end if
    end do
  end if

  if(i .eq. 3) then
    do s = 1, grid % n_faces
      c1 = grid % faces_c(1,s)
      c2 = grid % faces_c(2,s)
      dx_c1 = grid % dx(s)
      dy_c1 = grid % dy(s)
      dz_c1 = grid % dz(s)
      dx_c2 = grid % dx(s)
      dy_c2 = grid % dy(s)
      dz_c2 = grid % dz(s)
      dphi1 = phi(c2)-phi(c1)
      dphi2 = phi(c2)-phi(c1)

      if(c2 < 0) then
        if(Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. SYMMETRY) then
          dphi1 = 0.
          dphi2 = 0.
        end if
      end if

      if(boundary) then
        phii(c1) = phii(c1) + dphi1*(g(5,c1)*dx_c1  &
                                   + g(6,c1)*dy_c1  &
                                   + g(3,c1)*dz_c1)
        if(c2 > 0) then
          phii(c2) = phii(c2) + dphi2*(g(5,c2)*dx_c2  &
                                     + g(6,c2)*dy_c2  &
                                     + g(3,c2)*dz_c2)
        end if
      else
        if(c2 > 0) then
          phii(c1) = phii(c1) + dphi1*(g(5,c1)*dx_c1  &
                                     + g(6,c1)*dy_c1  &
                                     + g(3,c1)*dz_c1)
          phii(c2) = phii(c2) + dphi2*(g(5,c2)*dx_c2  &
                                     + g(6,c2)*dy_c2  &
                                     + g(3,c2)*dz_c2)
        end if
      end if
    end do
  end if

  call Comm_Mod_Exchange_Real(grid, phii)

  if(.not. boundary) call Grad_Mod_Correct_Bad_Cells(grid, phii)

  end subroutine


subroutine	cova(w,lambda_obs,mobs,lsfarr,pf,e,cov)

!
!	Calculation of the covariance matrix (linear term) assuming
!	Gaussian errors in the observations. See Eq. (14.4.11) of
!	the Numerical Recipes in fortran, and cov=[alpha]**-1.
!	A solution needs to be determined first and stored in pf,
!	which enters through the share data module.
!

use booklib, only	: mat_inv
use share, only		: dp,ndim,nov,indv,npix,nlambda1,badflux,winter,lambda_syn, &
                                    mlsf,nlsf

implicit none

!in/out
real(dp), intent(in)       :: w(nlambda1)           ! weights
real(dp), intent(in)       :: lambda_obs(nlambda1)  ! wavelengths for observations
real(dp), intent(in)       :: mobs                 ! mean or median of obs array
real(dp), intent(in)       :: lsfarr(mlsf,nlsf)    ! lsfarray
real(dp), intent(in)       :: pf(ndim)          ! vector of fixed parameters
real(dp), intent(in)  	   :: e(nlambda1)		!errors in the observations
real(dp), intent(out)  	   :: cov(nov,nov)	!covariance matrix

!locals
real(dp), parameter	   :: delta=1.1					!factor to compute derivatives
integer		  	   :: i,j,k							!counters
real(dp)		   :: p(ndim)	        	   		!parameters
real(dp)		   :: flux(nlambda1)				!fluxes
real(dp)		   :: flux1(nlambda1)				!fluxes
real(dp)		   :: flux2(nlambda1)				!fluxes
real(dp)		   :: par1,par2	        			!tmp vars. for partial derivat.
real(dp)		   :: partial(nov,nlambda1)				!partial derivatives
real(dp)		   :: alpha(nov,nov)				!curvature matrix
integer			   :: error = 0						!error code from mat_inv

p=pf
do i=1,nov

	call flx(pf,lambda_obs,e,mobs,lsfarr,flux)

	k=indv(i)

	!initialize
	flux1(1:nlambda1)=badflux
	flux2(1:nlambda1)=badflux

	!two estimates of the partials, increasing
	p(k)=pf(k)*delta
	if (p(k) <= 1.0_dp) then
		call flx(p,lambda_obs,e,mobs,lsfarr,flux1)
	endif

	!and decreasing the parameters
	p(k)=pf(k)/delta
	if (p(k) >= 0.0_dp) then
		call flx(p,lambda_obs,e,mobs,lsfarr,flux2)
	endif

	do j=1,nlambda1

	   par1=(flux1(j)-flux(j))/pf(k)/(delta-1._dp)
	   par2=(flux2(j)-flux(j))/pf(k)/(1._dp/delta-1._dp)

	   if (flux1(j) >= 0._dp .and. flux2(j) >=0._dp) then
	      	partial(i,j)=(par1+par2)/2._dp
	   else
		partial(i,j)=0.0_dp
		if (flux1(j) >= 0.0_dp)	partial(i,j)=par1
		if (flux2(j) >= 0.0_dp) partial(i,j)=par2

	   endif

	enddo
enddo

do i=1,nov
	do j=1,nov
		alpha(j,i)=sum(partial(i,1:nlambda1)*partial(j,1:nlambda1)/e(1:nlambda1)**2)
	enddo
enddo

!booklib lib
call mat_inv(alpha,cov,nov,nov,error)
!Pang's lib
!call migs(alpha,nov,cov,flux1)

if (error /= 0) then
	write(*,*) 'cova: ERROR'
	write(*,*) 'mat_inv returned an non-zero error=',error
	write(*,*) 'probably indicating a singular matrix'
	cov(:,:)=-1._dp
endif

end subroutine cova